From 66a7c31053ce4093f96db202a7bae5c42d108a24 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 24 Aug 1990 18:15:10 +0000
Subject: [PATCH] Moved MIPS branch onto trunk; no merge necessary.

---
 code/alieneval.lisp   |  625 ++++++++++++---------
 code/array.lisp       | 1206 ++++++++++++++++++++++-------------------
 code/defstruct.lisp   |   36 +-
 code/describe.lisp    |   35 +-
 code/error.lisp       |  257 +--------
 code/fd-stream.lisp   |  342 ++++++------
 code/fdefinition.lisp |    2 +-
 code/filesys.lisp     |   18 +-
 code/format.lisp      |  151 ++----
 code/gc.lisp          |  450 ++++-----------
 code/lispinit.lisp    |  470 +++-------------
 code/list.lisp        |   17 +-
 code/load.lisp        |  365 +++++--------
 code/machdef.lisp     |   83 +--
 code/macros.lisp      |  140 +++--
 code/misc.lisp        |   20 +-
 code/pred.lisp        |  779 ++++++++++----------------
 code/print.lisp       |  464 ++++++++--------
 code/purify.lisp      |   18 +
 code/reader.lisp      |   56 +-
 code/save.lisp        |    2 +-
 code/seq.lisp         |   74 +--
 code/serve-event.lisp |   21 +-
 code/stream.lisp      |   41 +-
 code/symbol.lisp      |   26 +-
 code/time.lisp        |   36 +-
 code/tty-inspect.lisp |   50 +-
 tools/worldcom.lisp   |  196 +++----
 tools/worldload.lisp  |  115 ++--
 29 files changed, 2609 insertions(+), 3486 deletions(-)

diff --git a/code/alieneval.lisp b/code/alieneval.lisp
index e4837681e..703907440 100644
--- a/code/alieneval.lisp
+++ b/code/alieneval.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.3 1990/08/24 18:09:34 wlott Exp $
+;;;
 ;;;    This file contains any the part of the Alien implementation that
 ;;; is not part of the compiler.
 ;;;
@@ -35,12 +37,14 @@
 
 ;;; The number of bits corresponding to a change of 1 in the value of a SAP.
 ;;;
-(defconstant alien-address-unit 8)
+(defconstant alien-address-unit vm:byte-bits)
+(defconstant alien-address-shift (1- (integer-length alien-address-unit)))
 
 ;;; The address pointed to by the SAP in an alien is always a multiple of this
 ;;; number of bits.
 ;;;
-(defconstant alien-alignment 16)
+(defconstant alien-alignment vm:word-bits)
+
 
 (defvar *alien-eval-when* '(compile load eval)
   "This is a list of the times to eval Alien compiler info.")
@@ -48,10 +52,11 @@
 (defun %print-alien-value (s stream d)
   (declare (ignore d))
   (let ((offset (alien-value-offset s)))
-    (format stream
-	    "#<Alien value, Address = #x~X~:[+~D/8~;~*~], Size = ~D, Type = ~S>"
-	    (%primitive sap-int (alien-value-sap s)) (zerop offset) offset
-	    (alien-value-size s) (alien-value-type s))))
+    (format
+     stream
+     "#<Alien value, Address = #x~X~:[+~D/~D~;~2*~], Size = ~D, Type = ~S>"
+     (sap-int (alien-value-sap s)) (zerop offset) offset alien-address-unit
+     (alien-value-size s) (alien-value-type s))))
 
 (defun %print-alien-info (s stream d)
   (declare (ignore s d))
@@ -61,34 +66,128 @@
 ;;;; Interpreter stubs for SAP functions:
 
 #+new-compiler (progn
+
+(defun pointer< (x y)
+  "Return T iff the SAP X points to a smaller address then the SAP Y."
+  (declare (type system-area-pointer x y))
+  (pointer< x y))
+
+(defun pointer> (x y)
+  "Return T iff the SAP X points to a larger address then the SAP Y."
+  (declare (type system-area-pointer x y))
+  (pointer> 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."
+  "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 words from SAP."
+  "Returns the 16-bit word at OFFSET half-words 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 words from SAP."
+  "Returns the 32-bit dualword at OFFSET words from SAP."
+  (declare (type system-area-pointer sap)
+	   (type index offset))
   (sap-ref-32 sap offset))
 
-(defun (setf sap-ref-8) (sap offset new-value)
+(defun sap-ref-sap (sap offset)
+  "Returns the 32-bit system-area-pointer at OFFSET words 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 words 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 words 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 words 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 words 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 (or (signed-byte 8) (unsigned-byte 8)) new-value))
   (setf (sap-ref-8 sap offset) new-value))
 
-(defun (setf sap-ref-16) (sap offset new-value)
+(defun %set-sap-ref-16 (sap offset new-value)
+  (declare (type system-area-pointer sap)
+	   (type index offset)
+	   (type (or (signed-byte 16) (unsigned-byte 16)) new-value))
   (setf (sap-ref-16 sap offset) new-value))
 
-(defun (setf sap-ref-32) (sap offset new-value)
-  (setf (sap-ref-32 sap offset) new-value))
+(defun %set-sap-ref-32 (sap offset new-value)
+  (declare (type system-area-pointer sap)
+	   (type index offset)
+	   (type (or (signed-byte 32) (unsigned-byte 32)) new-value))
+  (if (minusp new-value)
+      (truly-the (signed-byte 32) (setf (sap-ref-32 sap offset) new-value))
+      (truly-the (unsigned-byte 32) (setf (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))
 
 ); #+New-Compiler
 
@@ -112,17 +211,19 @@
     (unless (= size (alien-value-size from-alien))
       (error "Arguments to Alien-Assign are of different sizes:~%~S~%~S"
 	     to-alien from-alien))
-    (unless (zerop (logand size 7))
+    (unless (zerop (logand size (1- alien-address-unit)))
       (error "Size of assigned Alien is not a byte multiple:~%~S"
 	     from-alien))
-    (unless (zerop (logand src-off 7))
+    (unless (zerop (logand src-off (1- alien-address-unit)))
       (error "Alien is not byte aligned:~%~S" from-alien))
-    (unless (zerop (logand dst-off 7))
+    (unless (zerop (logand dst-off (1- alien-address-unit)))
       (error "Alien is not byte aligned:~%~S" to-alien))
-    (let ((dst-start (ash dst-off -3)))
-      (%primitive byte-blt (alien-value-sap from-alien) (ash src-off -3)
+    (let ((dst-start (ash dst-off (- alien-address-shift))))
+      (%primitive byte-blt
+		  (alien-value-sap from-alien)
+		  (ash src-off (- alien-address-shift))
 		  (alien-value-sap to-alien) dst-start
-		  (+ dst-start (ash size -3))))
+		  (+ dst-start (ash size (- alien-address-shift)))))
     to-alien))
 
 
@@ -144,7 +245,7 @@
 (defun alien-address (alien)
   "Return the address of the data for Alien."
   (check-type alien alien-value)
-  (+ (%primitive sap-int (alien-value-sap alien))
+  (+ (sap-int (alien-value-sap alien))
      (/ (alien-value-offset alien) alien-address-unit)))
 
 (defun alien-sap (alien)
@@ -190,22 +291,11 @@
 (defmacro define-alien-stack (name type size)
   "Define-Stack-Alien Name Type Size
   Defines a new alien stack for use with the With-Stack-Alien macro.
-  The aliens have the specifed Type and Size, and are static."
-  (let ((n-head (concat-pnames name '-alien-stack-head))
-	(n-current (concat-pnames name '-alien-stack))
-	(grow-fun (concat-pnames name '-grow-stack)))
-  `(progn
-    (eval-when ,*alien-eval-when*
-      (setf (info alien-stack info ',name)
-	    (make-stack-info :head ',n-head  :current ',n-current
-			     :grow ',grow-fun  :type ',type
-			     :size ,size)))
-    (defvar ,n-head ())
-    (defvar ,n-current ())
-    (defun ,grow-fun ()
-      (let ((new (list (make-alien ',type ,size :static))))
-	(setq ,n-head (nconc ,n-head new)  ,n-current new)
-	(car new))))))
+  The aliens have the specifed Type and Size, and are allocated on the
+  number stack."
+  `(eval-when ,*alien-eval-when*
+     (setf (info alien-stack info ',name)
+	   (make-stack-info :type ',type :size ,size))))
 
 
 ;;; Defoperator  --  Public
@@ -241,22 +331,19 @@
 
 ;;;; Alien allocation:
 
-(eval-when (compile)
-  (dolist (x '(system-space-start alien-allocation-end))
-    (remprop x 'lisp::%constant)))
-
 ;;;    In order to improve memory locality static alien values are allocated
 ;;; contiguously in a pre-validated area at the beginning of system space.  We
 ;;; keep a free pointer to the next word we can allocate.
 ;;;
-(defparameter system-space-start
-  (%primitive make-immediate-type 0 %static-alien-area)
+#+new-compiler
+(defparameter system-space-start (int-sap #x80000000)
   "The address of the first statically allocated alien.")
 
-(defparameter alien-allocation-end
-  (%primitive make-immediate-type #x40000 %static-alien-area)
+#+new-compiler
+(defparameter alien-allocation-end (int-sap #x8fffffff)
   "The end of statically allocated aliens.")
 
+#+new-compiler
 (defvar *current-alien-free-pointer* system-space-start
   "The next word in system space for static alien allocation.")
 
@@ -265,26 +352,60 @@
 ;;;    Allocate enough storage to hold the specified number of bits
 ;;; and return the address.
 ;;;
+#+new-compiler
 (defun allocate-static-alien (bits)
   (declare (fixnum bits))
   (let* ((alien *current-alien-free-pointer*)
-	 (bytes (logand (ash (the fixnum (+ bits 31)) -3) (lognot 3)))
-	 (new (%primitive sap+ *current-alien-free-pointer* bytes)))
-    (when (%primitive pointer> new alien-allocation-end)
+	 (bytes (logand (ash (the fixnum (+ bits alien-alignment -1))
+			     (- alien-address-shift))
+			(lognot (1- (truncate alien-alignment
+					      alien-address-unit)))))
+	 (new (sap+ *current-alien-free-pointer* bytes)))
+    (when (#-new-compiler %primitive pointer> new alien-allocation-end)
       (error "Not enough room to allocate a ~D bit alien." bits))
     (setq *current-alien-free-pointer* new)
     alien))
 
 
-;;; DO-VALIDATE  --  Internal Interface.
-;;;
-;;; Do a ValidateMemory on our kernel port and flame out if error.
-;;;
-;;; Hemlock and other code files use this, even though it is not exported from
-;;; a more appropriate package.
-;;;
-(defun do-validate (addr bytes mask)
-  (gr-call* mach::vm_allocate *task-self* addr bytes (if (eq mask -1) t NIL)))
+;;; ALLOCATE-SYSTEM-MEMORY -- public
+;;;
+;;; Allocate random memory from the system area.
+;;; 
+(defun allocate-system-memory (bytes)
+  (declare (type index bytes))
+  (gr-call* mach:vm_allocate *task-self* (int-sap 0) bytes t))
+
+;;; REALLOCATE-SYSTEM-MEMORY -- public
+;;;
+;;; Either allocate more memory at the end of this block, or allocate a new
+;;; block and move the old memory into it.
+;;; 
+(defun reallocate-system-memory (old old-size new-size)
+  (declare (type system-area-pointer old)
+	   (type index old-size new-size))
+  ;; ### Got to work the page size into this somehow.  The vm_allocate
+  ;; will fail much more often than it otherwise would 'cause if the old
+  ;; block stops in the middle of a page, we can't extend it.
+  (if (eql (mach:vm_allocate *task-self*
+			     (sap+ old old-size)
+			     (- new-size old-size)
+			     nil)
+	   mach:kern-success)
+      old
+      (let ((new (allocate-system-memory new-size)))
+	(declare (type system-area-pointer new))
+	(system-area-copy old 0 new 0 (* old-size vm:byte-bits))
+	(deallocate-system-memory old old-size)
+	new)))
+
+;;; DEALLOCATE-SYSTEM-MEMORY -- public
+;;;
+;;; Deallocate that memory.
+;;; 
+(defun deallocate-system-memory (addr bytes)
+  (declare (type system-area-pointer addr)
+	   (type index bytes))
+  (gr-call* mach:vm_deallocate *task-self* addr bytes))
 
 
 ;;; Make-Alien  --  Public
@@ -299,20 +420,19 @@
   supplied then memory is allocated to contain the data."
   (case address
     (:dynamic
-     (setq address (do-validate 0 (ash size -3) -1)))
+     (setq address (allocate-system-memory (ash size (- alien-address-shift)))))
     (:static
      (setq address (allocate-static-alien size)))
     (t
-     (if (not (integerp address))
-	 (setq address (%primitive sap-int address)))
-     (check-type address (rational 0))))
+     (check-type address (or #+new-compiler system-area-pointer
+			     (rational 0)))))
   (check-type size (integer 0))
   (if (numberp address)
       (multiple-value-bind (base frac) (truncate address)
 	(let ((offset (* frac alien-address-unit)))
 	  (unless (integerp frac)
 	    (error "Address ~S does not fall on a bit position." address))
-	  (make-alien-value (%primitive int-sap base) offset size type)))
+	  (make-alien-value (int-sap base) offset size type)))
       (make-alien-value address 0 size type)))
 
 
@@ -329,9 +449,11 @@
   (check-type alien alien-value)
   (let* ((offset (alien-value-offset alien))
 	 (length (alien-value-size alien))
-	 (bytes (ash (+ length offset 15) -3))
-	 (new (%primitive int-sap (do-validate 0 bytes -1))))
-    (%primitive byte-blt (alien-value-sap alien) (ash offset -3)
+	 (bytes (ash (+ length offset alien-alignment -1)
+		     (- alien-address-shift)))
+	 (new (allocate-system-memory bytes)))
+    (%primitive byte-blt
+		(alien-value-sap alien) (ash offset (- alien-address-shift))
 		new 0 bytes)
     (make-alien-value new offset length (alien-value-type alien))))
 
@@ -341,14 +463,16 @@
 ;;;    Invalidate the memory pointed to by unless it is a statically
 ;;; allocated alien.
 ;;;
+#+new-compiler
 (defun dispose-alien (alien)
   "Release the storage allocated for Alien."
   (check-type alien alien-value)
   (let ((address (alien-value-sap alien)))
-    (unless (not (or (%primitive pointer< address system-space-start)
-		     (%primitive pointer> address alien-allocation-end)))
+    (unless (not (or (pointer< address system-space-start)
+		     (pointer> address alien-allocation-end)))
       (gr-call mach:vm_deallocate *task-self* address
-	       (logand #x-200 (ash (+ (alien-value-size alien) #xFFF) -3))))))
+	       (logand #x-200 (ash (+ (alien-value-size alien) #xFFF)
+				   (- alien-address-shift)))))))
 
 
 ;;;; Operator definition primitives:
@@ -368,9 +492,11 @@
     (error "~S is too small to extract a ~A bit field at ~A."
 	   alien size offset))
   (multiple-value-bind (words bits)
-		       (truncate (+ offset (alien-value-offset alien)) 8)
+		       (truncate (+ offset (alien-value-offset alien))
+				 alien-alignment)
     (make-alien-value
-     (%primitive int-sap (+ words (%primitive sap-int (alien-value-sap alien))))
+     (int-sap (+ (* words (/ alien-alignment alien-address-unit))
+		 (sap-int (alien-value-sap alien))))
      bits
      size
      nil)))
@@ -391,14 +517,13 @@
   (unless (zerop (alien-value-offset alien))
     (error "~S is not word aligned."))
   (let* ((sap (alien-value-sap alien))
-	 (value (logior (ash (%primitive 16bit-system-ref sap 0) 16)
-			(%primitive 16bit-system-ref sap 1))))
+	 (value (sap-ref-sap sap 0)))
 #|
     (unless (<= system-space-start value most-positive-fixnum)
       (error "The value of ~S, #x~X, does not point into system space."
 	     alien value))
 |#
-    (make-alien-value (%primitive int-sap value) 0 size nil)))
+    (make-alien-value value 0 size nil)))
 
 
 ;;; Bits, Bytes, Words, Long-Words  --  Public
@@ -426,11 +551,11 @@
 ;;;
 (defun %alien-indirect (size sap offset exp)
   (unless (eql size 32)
-    (error "Argument to Alien-Indirect is ~D bits, 32:~% ~S." size exp))
+    (error "Argument to Alien-Indirect is ~D bits, not 32:~% ~S." size exp))
   (unless (zerop (logand offset #x1F))
     (error "Offset ~D to Alien-Indirect is not long-word-aligned:~% ~S."
 	   offset exp))
-  (%primitive sap-system-ref sap (ash offset -4)))
+  (sap-ref-sap sap (ash offset -5)))
 
 
 ;;; %Aligned-SAP  --  Internal
@@ -439,49 +564,69 @@
 ;;; aligned.  In this case, we absorb the offset into the SAP, and make the
 ;;; bound offset 0.
 ;;;
+#+new-compiler
 (defun %aligned-sap (sap offset form)
-  (unless (zerop (logand offset #xF))
+  (unless (zerop (logand offset #x1F))
     (error "Offset ~S was declared to be word aligned, but isn't:~% ~S"
 	   offset form))
-  (%primitive sap+ sap (ash offset -3)))
+  (sap+ sap (ash offset (- alien-address-unit))))
 
 #+new-compiler
 ;;; Naturalize-Integer  --  Internal
 ;;;
-;;;    Read a possibly signed integer somewhere.  For the 16 and 32 bit
-;;; cases we let the transform do the work, for random fields we do it
-;;; by hand.
+;;;    Read a possibly signed integer somewhere.
 ;;;
 (defun naturalize-integer (signed sap offset size form)
-  (multiple-value-bind (q r) (truncate offset 16)
+  (declare (type boolean signed)
+	   (type system-area-pointer sap)
+	   (type index offset size))
+  (let ((bit-offset (logand offset #x1f)))
     (cond
-     ((> size 15)
-      (unless (zerop r)
-	(error "Offset ~D for ~D bit access is not word-aligned:~% ~S"
-	       offset size form))
-      (case size
-	(32
-	 (if signed
-	     (%primitive signed-32bit-system-ref sap (ash q 4))
-	     (%primitive unsigned-32bit-system-ref sap (ash q 4))))
-	(16
-	 (if signed
-	     (naturalize-integer t sap (ash q 4) 16 nil)
-	     (naturalize-integer nil sap (ash q 4) 16 nil)))
-	(t
-	 (error "Access of ~D bit integers is not supported." size))))
-     (t
-      (when (> (+ size r) 16)
-	(error "~D bit field at ~D offset crosses a word boundry:~% ~S"
-	       size offset form))
+     ((and (= size 32) (zerop bit-offset))
+      (if signed
+	  (signed-sap-ref-32 sap (ash offset -5))
+	  (sap-ref-32 sap (ash offset -5))))
+     ((and (= size 16) (zerop (logand offset #xf)))
+      (if signed
+	  (signed-sap-ref-16 sap (ash offset -4))
+	  (sap-ref-16 sap (ash offset -4))))
+     ((and (= size 8) (zerop (logand offset #x7)))
       (if signed
-	  (let ((val (ldb (byte size (- 16 size r))
-			  (%primitive 16bit-system-ref sap q))))
-	    (if (logbitp val (1- size))
-		(logior val (ash -1 size))
-		val))
-	  (ldb (byte size (- 16 size r))
-	       (%primitive 16bit-system-ref sap q)))))))
+	  (signed-sap-ref-8 sap (ash offset -3))
+	  (sap-ref-8 sap (ash offset -3))))
+     ((> size 32)
+      (error "Access of ~D bit integers is not supported:~% ~S" size form))
+     ((zerop bit-offset)
+      (let ((value (ldb (byte size 0) (sap-ref-32 sap (ash offset -5)))))
+	(if (and signed (logbitp value (1- size)))
+	    (logior value (ash -1 size))
+	    value)))
+     ((<= (+ size bit-offset) 32)
+      (let ((value (ldb (byte size bit-offset)
+			(sap-ref-32 sap (ash offset -5)))))
+	(if (and signed (logbitp value (1- size)))
+	    (logior value (ash -1 size))
+	    value)))
+     (t
+      (macrolet ((low-byte ()
+			   (ecase vm:target-byte-order
+			     (:little-endian 'offset)
+			     (:bit-endian '(1+ offset))))
+		 (high-byte ()
+			    (ecase vm:target-byte-order
+			      (:little-endian '(1+ offset))
+			      (:bit-endian 'offset))))
+	(let* ((high-bits (- 32 bit-offset))
+	       (low-bits (- size high-bits))
+	       (value (logior (ash (ldb (byte high-bits 0)
+					(sap-ref-32 sap (high-byte)))
+				   low-bits)
+			      (ash (sap-ref-32 sap (low-byte))
+				   (- (- 32 low-bits))))))
+	  (if (and signed (logbitp value (1- size)))
+	      (logior value (ash -1 size))
+	      value)))))))
+
 
 #+new-compiler
 ;;; Deport-Integer  --  Internal
@@ -489,46 +634,44 @@
 ;;;    Like Naturalize-Integer, but writes an integer.
 ;;;
 (defun deport-integer (signed sap offset size value form)
+  (declare (type boolean signed)
+	   (type system-area-pointer sap)
+	   (type index offset size)
+	   (type integer value))
   (declare (ignore signed))
-  (multiple-value-bind (q r) (truncate offset 16)
+  (multiple-value-bind (q r) (truncate offset 32)
     (declare (fixnum r))
     (cond
-     ((> size 15)
-      (unless (zerop r)
-	(error "Offset ~D for ~D bit store is not word-aligned:~% ~S"
-	       offset size form))
-      (case size
-	(32
-	 (%primitive signed-32bit-system-set sap q value))
-	(16
-	 (%primitive 16bit-system-set sap q value))
-	(t
-	 (error "Storing of ~D bit integers is not supported:~% ~S"
-		size form))))
-     ((= size 8)
-      (setq q (ash q 1))
-      (when (= r 8)
-	(setq q (1+ q))
-	(setq r 0))
-      (when (/= r 0)
-	(error "8 bit field at ~D offset crosses a byte boundary:~% ~S"
-	       offset form))
-      (%primitive 8bit-system-set sap q value))
-     ((> size 7)
-      (when (> (+ size r) 16)
-	(error "~D bit field at ~D offset crosses a word boundry:~% ~S"
-	       size offset form))
-      (%primitive 16bit-system-set sap q
-		  (dpb value (byte size (- 16 size r))
-		       (%primitive 16bit-system-ref sap q))))
-     (T
-      (multiple-value-bind (nq nr) (truncate offset 8)
-	(when (> (+ size nr) 8)
-	  (error "~D bit field at ~D offset crosses a byte boundry:~% ~S"
-		 size offset form))
-	(%primitive 8bit-system-set sap nq
-		    (dpb value (byte size (- 8 size nr))
-			 (%primitive 8bit-system-ref sap nq)))))))
+     ((and (= size 32) (zerop r))
+      (setf (sap-ref-32 sap q) value))
+     ((and (= size 16) (zerop (logand r #xf)))
+      (setf (sap-ref-16 sap (ash offset -4)) value))
+     ((and (= size 8) (zerop (logand r #x7)))
+      (setf (sap-ref-8 sap (ash offset -3)) value))
+     ((> size 32)
+      (error "Storing of ~D bit integers is not supported:~% ~S"
+	     size form))
+     ((zerop r)
+      (setf (ldb (byte size 0) (sap-ref-32 sap q)) value))
+     ((<= (+ r size) 32)
+      (setf (ldb (byte size r) (sap-ref-32 sap q)) value))
+     (t
+      (macrolet ((low-byte ()
+			   (ecase vm:target-byte-order
+			     (:little-endian 'offset)
+			     (:bit-endian '(1+ offset))))
+		 (high-byte ()
+			    (ecase vm:target-byte-order
+			      (:little-endian '(1+ offset))
+			      (:bit-endian 'offset))))
+	(let* ((high-bits (- 32 r))
+	       (low-bits (- size high-bits)))
+	  (setf (ldb (byte high-bits 0)
+		     (sap-ref-32 sap (high-byte)))
+		(ash value (- low-bits)))
+	  (setf (ldb (byte low-bits (- 32 low-bits))
+		     (sap-ref-32 sap (low-byte)))
+		value))))))
   nil)
 
 
@@ -539,11 +682,16 @@
 ;;;
 #+new-compiler
 (defun naturalize-boolean (sap offset size form)
+  (declare (type system-area-pointer sap)
+	   (type index offset size))
   (declare (notinline naturalize-integer))
   (not (zerop (naturalize-integer nil sap offset size form))))
 ;;;
 #+new-compiler
 (defun deport-boolean (sap offset size value form)
+  (declare (type system-area-pointer sap)
+	   (type index offset size)
+	   (type boolean value))
   (declare (notinline deport-integer))
   (deport-integer nil sap offset size (if value 1 0) form)
   nil)
@@ -735,7 +883,7 @@
   constraints on the values they may assume.  If the value
   is Nil, that is taken to be a null constraint.  The following
   keys are defined:
-   :unit      -- A integer (default 16).
+   :unit      -- A integer (default 32).
 		 Asserts that the value is a multiple of this number, and
 		 that the value is to be divided by this number before any
 		 other options are processed.
@@ -750,31 +898,36 @@
   (let ((n-sap (gensym))
 	(n-offset (gensym))
 	(n-size (gensym)))
-    `(%define-alien-access
-      ',lisp-type '(,atype ,@more-types)
-      #'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var
-			,source-var)
-	  ,@(unless source-p
-	     `((declare (ignore ,source-var))))
-
-	  (unless (memq (mostcar ,alien-var) '(,atype ,@more-types))
-	    (error "Wrong Alien type ~S, should have been ~S~
-	            ~{~#[~; or~:;,~] ~S~}."
-		   ,alien-var ',atype ',more-types))
-	  
-	  (macrolet ((with-alien ((sap)
-				  (offset &key
-					  ((:unit ounit) 16))
-				  (size &key
-					((:constant sconst) nil)
-					((:minimum smin) nil)
-					((:unit sunit) 16))
-				  &body (body decls))
-		       (%with-alien sap offset ounit
-				    size sconst smin sunit
-				    ',n-sap ',n-offset ',n-size
-				    body decls)))
-	    ,@body)))))
+    `(progn
+       (%define-alien-access
+	',lisp-type '(,atype ,@more-types)
+	#'(lambda (,n-sap ,n-offset ,n-size ,alien-var ,kind-var ,value-var
+			  ,source-var)
+	    ,@(unless source-p
+		`((declare (ignore ,source-var))))
+	    
+	    (unless (member (mostcar ,alien-var) '(,atype ,@more-types)
+			    :test #'eq)
+	      (error "Wrong Alien type ~S, should have been ~S~
+	      ~{~#[~; or~:;,~] ~S~}."
+		     ,alien-var ',atype ',more-types))
+	    
+	    (macrolet ((with-alien ((sap)
+				    (offset &key
+					    ((:unit ounit) 32))
+				    (size &key
+					  ((:constant sconst) nil)
+					  ((:minimum smin) nil)
+					  ((:unit sunit) 32))
+				    &body (body decls))
+				   (%with-alien sap offset ounit
+						size sconst smin sunit
+						',n-sap ',n-offset ',n-size
+						body decls)))
+	      ,@body)))
+       #-new-compiler
+       (eval-when (compile)
+	 (clc::clc-mumble "alien-access ~S compiled.~%" ',lisp-type)))))
 
 
 (eval-when (compile load eval)
@@ -960,59 +1113,32 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 	`(naturalize-boolean ,sap ,offset ,size ',form)
 	`(deport-boolean ,sap ,offset ,size ,value ',form))))
 
-
-;;; Alien-Access expert for short-floats
+;;; Alien-Access expert for single-floats
 ;;;
-(define-alien-access (short-float) (type kind value)
+(define-alien-access (single-float) (type kind value)
   (with-alien (sap)
 	      (offset)
-	      (size :constant 2)
+	      (size :constant 1)
     (declare (ignore size))
     (if (eq kind :read)
-	`(%primitive int-sap
-	  (logior (ash (%primitive unsigned-32bit-system-ref ,sap ,offset)
-		       (- clc::short-float-shift-16))
-		  (ash clc::short-float-4bit-type
-		       (- 32 clc::short-float-shift-16))))
-	(let ((var (gensym)))
-	  `(let ((,var (float ,value 1.0s0)))
-	     (setq ,var (ash (%primitive sap-int ,var) clc::short-float-shift-16))
-	     (%primitive signed-32bit-system-set ,sap ,offset ,var))))))
+	`(sap-ref-single ,sap ,offset)
+	`(setf (sap-ref-single ,sap ,offset) ,value))))
 
-
-;;; Alien-Access expert for long-floats
+;;; Alien-Access expert for double-floats
 ;;;
-(define-alien-access (long-float) (type kind value)
+(define-alien-access (double-float) (type kind value)
   (with-alien (sap)
 	      (offset)
-	      (size :constant 4)
+	      (size :unit 64 :constant 1)
     (declare (ignore size))
     (if (eq kind :read)
-	(let ((var (gensym)))
-	  `(let ((,var (%primitive float-long 0)))
-	     (%primitive 16bit-system-set ,var 2
-			 (%primitive 16bit-system-ref ,sap ,offset))
-	     (%primitive 16bit-system-set ,var 3
-			 (%primitive 16bit-system-ref ,sap (1+ ,offset)))
-	     (%primitive 16bit-system-set ,var 4
-			 (%primitive 16bit-system-ref ,sap (+ ,offset 2)))
-	     (%primitive 16bit-system-set ,var 5
-			 (%primitive 16bit-system-ref ,sap (+ ,offset 3)))
-	     ,var))
-	(let ((var (gensym)))
-	  `(let ((,var (float ,value 1.0L0)))
-	     (%primitive 16bit-system-set ,sap ,offset
-			 (%primitive 16bit-system-ref ,var 2))
-	     (%primitive 16bit-system-set ,sap (1+ ,offset)
-			 (%primitive 16bit-system-ref ,var 3))
-	     (%primitive 16bit-system-set ,sap (+ ,offset 2)
-			 (%primitive 16bit-system-ref ,var 4))
-	     (%primitive 16bit-system-set ,sap (+ ,offset 3)
-			 (%primitive 16bit-system-ref ,var 5)))))))
+	`(sap-ref-double ,sap ,offset)
+	`(setf (sap-ref-double ,sap ,offset) ,value))))
 
 ;;; Alien-access expert for procedure objects.  These should be used
 ;;; with caution.
 ;;;
+#+nil ; ### This will need work.
 (define-alien-access (c-procedure) (type kind value)
   (with-alien (sap)
 	      (offset)
@@ -1039,7 +1165,7 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
     (if (eq kind :read)
 	(let ((size (gensym))
 	      (str (gensym)))
-	  `(let* ((,size (%primitive 8bit-system-ref ,n-sap ,n-offset))
+	  `(let* ((,size (sap-ref-8 ,n-sap ,n-offset))
 		  (,str (make-string ,size)))
 	     (%primitive byte-blt ,n-sap (1+ ,n-offset) ,str 0 ,size)
 	     ,str))
@@ -1049,7 +1175,7 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 				    ,n-value)))
 		 (,1+off (1+ ,n-offset)))
 	     (check<= ,len ,(cadr type))
-	     (%primitive 8bit-system-set ,n-sap ,n-offset ,len)
+	     (setf (sap-ref-8 ,n-sap ,n-offset) ,len)
 	     (%primitive byte-blt ,n-value 0 ,n-sap ,1+off
 			 (+ ,1+off ,len)))))))
 
@@ -1067,26 +1193,30 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
     (declare (ignore size))
     (if (eq kind :read)
 	(let ((size (gensym))
-	      (str (gensym)))
-	  `(let* ((,size (the fixnum
-			      (- (the fixnum
-				      (%primitive find-character
-						  ,n-sap ,n-offset
-						  most-positive-fixnum 0))
-				 (the fixnum ,n-offset))))
-		  (,str (make-string ,size)))
-	     (%primitive byte-blt ,n-sap ,n-offset ,str 0 ,size)
-	     ,str))
-	(let ((len (gensym))
-	      (end (gensym)))
-	  `(let* ((,len (the fixnum (1+ (length (the simple-string
-						     ,n-value)))))
-		  (,end (the fixnum (+ (the fixnum ,len) ,n-offset))))
-	     (declare (fixnum ,len ,end))
+	      (str (gensym))
+	      (ptr (gensym))
+	      (start (gensym)))
+	  `(do* ((,start (sap+ ,n-sap ,n-offset))
+		 (,ptr ,start (sap+ ,ptr 1)))
+	       ((zerop (sap-ref-8 ,ptr 0))
+		(let* ((,size (sap- ,ptr ,start))
+		       (,str (make-string ,size)))
+		  (declare (fixnum ,size)
+			   (type simple-base-string ,str))
+		  (copy-from-system-area ,start 0
+					 ,str (* vm:vector-data-offset
+						 vm:word-bits)
+					 (* ,size vm:byte-bits))
+		  ,str))
+	     (declare (type system-area-pointer ,start ,ptr))))
+	(let ((len (gensym)))
+	  `(let ((,len (the fixnum (1+ (length (the simple-string
+						    ,n-value))))))
+	     (declare (fixnum ,len))
 	     (check<= ,len ,(cadr type))
-	     (%primitive byte-blt ,n-value 0 ,n-sap ,n-offset ,end)
-	     (%primitive 8bit-system-set ,n-sap
-			 (the fixnum (1+ ,end)) 0))))))
+	     (copy-to-system-area ,n-value (* vm:vector-data-offset
+					      vm:word-bits)
+				  ,n-sap ,n-offset ,len))))))
 
 
 ;;;; Pointer alien access:
@@ -1100,11 +1230,11 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
   (type kind value)
   (with-alien (sap)
 	      (offset)
-	      (size :constant 2)
+	      (size :constant 1)
     (declare (ignore size))
     (if (eq kind :read)
-	`(%primitive sap-system-ref ,sap ,offset)
-	`(%primitive pointer-system-set ,sap ,offset ,value))))
+	`(sap-ref-sap ,sap ,offset)
+	`(setf (sap-ref-sap ,sap ,offset) ,value))))
 
 ;;; Alien-Access expert for (Alien <type> [<bits>])  --  Internal
 ;;;
@@ -1114,7 +1244,7 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 (define-alien-access (alien) (type kind value)
   (with-alien (sap)
 	      (offset)
-	      (size :constant 2)
+	      (size :constant 1)
     (declare (ignore size))
     (unless (and (consp type) (consp (cdr type)))
       (error "Bad type for accessing as an Alien: ~S" type))
@@ -1127,13 +1257,13 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 	(unless (and (integerp size) (>= size 0))
 	  (error "Size is not a positive integer: ~S" type))
 	`(make-alien-value
-	  (%primitive sap-system-ref ,sap ,offset)
+	  (sap-ref-sap ,sap ,offset)
 	  0
 	  ,size
 	  ',atype))
        (t
-	`(%primitive pointer-system-set ,sap ,offset
-		     (alien-value-sap ,value)))))))
+	`(setf (sap-ref-sap ,sap ,offset)
+	       (alien-value-sap ,value)))))))
 
 ;;; Alien-Access expert for (Pointer xxx)  --  Internal
 ;;;
@@ -1143,11 +1273,22 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 (define-alien-access (pointer pointer alien) (type kind value)
   (with-alien (sap)
 	      (offset)
-	      (size :constant 2)
+	      (size :constant 1)
     (declare (ignore size))
-    (when (eq kind :read)
-      (error "Cannot read with Pointer Alien type:~%~S" type))
-    `(%primitive pointer-system-set ,sap ,offset ,value)))
+    (if (eq kind :read)
+	`(error "Cannot reference pointer aliens")
+	(let ((n-value (gensym)))
+	  `(setf (sap-ref-sap ,sap ,offset)
+		 (let ((,n-value ,value))
+		   ,@(when (and (consp type) (consp (cdr type)))
+		       `((declare (type ,(cadr type) ,n-value))))
+		   (etypecase ,n-value
+		     (null (int-sap 0))
+		     (system-area-pointer ,n-value)
+		     ((or simple-string
+			  simple-bit-vector
+			  (simple-array unsigned-byte (*)))
+		      (%primitive c::vector-sap ,n-value)))))))))
 
 
 ;;;; Enumeration Alien access:
@@ -1189,7 +1330,7 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 	(unless (and min (< min val)) (setq min val))
 	(when (rassoc val (cdr el))
 	  (error "Element value ~S used more than once." val))
-	(when (assq sym (cdr el))
+	(when (assoc sym (cdr el) :test #'eq)
 	  (error "Enumeration element ~S used more than once." sym))))
     (let* ((signed (minusp min))
 	   (to (intern (concatenate 'simple-string (string name)
@@ -1244,7 +1385,7 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 	  (mapcar #'car alist))
    (write-string "New value: " *query-io*)
    (let* ((response (read *query-io*))
-	  (res (cdr (assq response alist))))
+	  (res (cdr (assoc response alist :test #'eq))))
      (when res (return res)))))
 
 
@@ -1272,7 +1413,7 @@ don't know that it is supposed to be used for.  I suspect it is a PERQ crock.
 			  ,to))))
 	  `(deport-integer
 	    ,signed ,sap ,offset ,size
-	    (or (cdr (assq ,value ,from))
+	    (or (cdr (assoc ,value ,from :test #'eq))
 		(enumeration-error ,from))
 	    ',form)))))
 
diff --git a/code/array.lisp b/code/array.lisp
index 77cbf80e1..5f1a04b7e 100644
--- a/code/array.lisp
+++ b/code/array.lisp
@@ -7,8 +7,11 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; Functions to implement arrays for Spice Lisp 
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.3 1990/08/24 18:10:14 wlott 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")
 
@@ -21,6 +24,7 @@
 	  fill-pointer vector-push vector-push-extend vector-pop adjust-array
           adjustable-array-p row-major-aref))
 
+
 (defconstant array-rank-limit 65529
   "The exclusive upper bound on the rank of an array.")
 
@@ -31,23 +35,75 @@
   "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-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))
+
 ;;; Random function used by WITH-ARRAY-DATA, which has to be defined in
-;;; init.lisp.
+;;; sysmacs.lisp.
 ;;;
 (defun find-data-vector (array)
-  (do ((data array (%primitive header-ref data %array-data-slot))
-       (cumulative-offset 0
-			  (the fixnum
-			       (+ cumulative-offset
-				  (the fixnum
-				       (or (%primitive header-ref data
-						       %array-displacement-slot)
-					   0))))))
-      ((not (array-header-p data))
-       (values data cumulative-offset))
-    (declare (fixnum cumulative-offset))))
-
+  (let ((cumulative-offset 0))
+    (declare (fixnum cumulative-offset))
+    (do ((data array (%array-data-vector array)))
+	((not (array-header-p data))
+	 (values data cumulative-offset))
+      (when (%array-displaced-p array)
+	(incf cumulative-offset (%array-displacement array))))))
 
+
+;;;; MAKE-ARRAY
+
+(defmacro pick-type (type &rest specs)
+  `(cond ,@(mapcar #'(lambda (spec)
+		       `((subtypep ,type ',(car spec))
+			 ,@(cdr spec)))
+		   specs)))
+
+(defun %vector-type-code (type)
+  (pick-type type
+    (base-character (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-character #.vm:complex-string-type)
+    (bit #.vm:complex-bit-vector-type)
+    (t #.vm:complex-vector-type)))
 
 (defun make-array (dimensions &key
 			      (element-type t)
@@ -56,75 +112,106 @@
 			      displaced-to displaced-index-offset)
   "Creates an array of the specified Dimensions.  See manual for details."
   (unless (listp dimensions) (setq dimensions (list dimensions)))
-  (let ((array-rank (length (the list dimensions))))
+  (let ((array-rank (length (the list dimensions)))
+	(simple (and (null fill-pointer)
+		     (not adjustable)
+		     (null displaced-to))))
     (declare (fixnum array-rank))
-    (if (eq fill-pointer t) (setq fill-pointer (car dimensions)))
-    (if (and fill-pointer (> array-rank 1))
-	(error "Multidimensional arrays can't have fill pointers."))
-    (cond (displaced-to
-	   ;; If the array is displaced, make a header and fill it up.
-	   (unless (subtypep element-type (array-element-type displaced-to))
-	     (error "One can't displace an array of type ~S into another of ~
-		    type ~S." element-type (array-element-type displaced-to)))
-	   (if (or initial-element initial-contents)
-	       (error "The :initial-element or initial-contents option may not ~
-		       be specified with :displaced-to."))
-	   (let ((displacement (or displaced-index-offset 0))
-		 (array-size (array-linear-length dimensions)))
-	     (declare (fixnum displacement array-size))
-	     (if (< (the fixnum (array-total-size displaced-to))
-		    (the fixnum (+ displacement array-size)))
-		 (error "The :displaced-to array is too small."))
-	     (set-array-header (%primitive alloc-array array-rank)
-			       displaced-to array-size
-			       (or fill-pointer array-size)
-			       displacement dimensions t)))
-	  ((and (not adjustable) (= array-rank 1) (not fill-pointer))
-	   ;; If the array can be represented as a simple thing, do that.
-	   (if (and initial-element-p initial-contents)
-	       (error "The :initial-contents option may not be specified with ~
-		       :initial-element."))
-	   (data-vector-from-inits dimensions (car dimensions) array-rank
-				   element-type initial-contents
-				   initial-element initial-element-p))
-	  (t
-	   ;; Otherwise, build a complex array.
-	   (if (and initial-element-p initial-contents)
-	       (error "The :initial-contents option may not be specified with ~
-		       :initial-element."))
-	   (let* ((array-size (array-linear-length dimensions))
-		  (array (%primitive alloc-array array-rank))
-		  (array-data (data-vector-from-inits
-			       dimensions array-size array-rank element-type
-			       initial-contents initial-element
-			       initial-element-p)))
-	     (set-array-header array array-data array-size
-			       (or fill-pointer array-size)
-			       0 ;displacement
-			       dimensions nil))))))
-
-;;; Some people out there are still calling MAKE-VECTOR:
-;;;
-(setf (symbol-function 'make-vector) #'make-array)
-
-(defun vector (&rest objects)
-  "Constructs a simple-vector from the given objects."
-  (coerce (the list objects) 'simple-vector))
-
+    (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 (%primitive
+			 allocate-vector
+			 type
+			 length
+			 (the index
+			      (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 multidemsional 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 (%primitive
+		       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"))
+		 (unless displaced-index-offset
+		   (setf displaced-index-offset 0))
+		 (when (> (+ displaced-index-offset total-size)
+			  (array-total-size displaced-to))
+		   (error "~S doesn't have enough elements." displaced-to))
+		 (setf (%array-displacement array) displaced-index-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 COPY-CONTENTS-AUX
+;;; 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 rank element-type
+(defun data-vector-from-inits (dimensions total-size element-type
 			       initial-contents initial-element
 			       initial-element-p)
-  (let ((data (cond ((subtypep element-type 'string-char)
-		     (%primitive alloc-string total-size))
-		    ((subtypep element-type '(unsigned-byte 32))
-		     (%primitive alloc-i-vector total-size
-				 (element-type-to-access-code element-type)))
-		    (t
-		     (%primitive alloc-g-vector total-size initial-element)))))
+  (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)
@@ -132,329 +219,313 @@
 		      initial-element element-type))
 	     (fill (the vector data) initial-element)))
 	  (initial-contents
-	   (copy-contents-aux dimensions initial-contents element-type
-			      rank 0 data)))
+	   (fill-data-vector data dimensions initial-contents)))
     data))
 
-;;; COPY-CONTENTS-AUX spins down into the Data vector and the Initial-Contents
-;;; filling the former from the latter.
-;;;
-(defun copy-contents-aux (dimensions initial-contents element-type
-			  depth index data)
-  (declare (fixnum depth index))
-  (cond ((= depth 0)
-	 (unless (typep initial-contents element-type)
-	   (error "~S cannot be used to initialize an array of element-type ~S."
-		  initial-contents element-type))
-	 (setf (aref data index) initial-contents)
-	 (the fixnum (1+ index)))
-	((listp initial-contents)
-	 (unless (= (length (the list initial-contents)) (car dimensions))
-	   (error "This part of initial-contents, ~S, is an unappropriate ~
-		   length for the dimension, ~S."
-		  initial-contents (car dimensions)))
-	 (do ((initial-contents initial-contents (cdr initial-contents))
-	      (next-dimensions (cdr dimensions))
-	      (next-depth (the fixnum (1- depth))))
-	     ((null initial-contents) index)
-	   (declare (list initial-contents))
-	   (setq index (copy-contents-aux
-			next-dimensions (car initial-contents) element-type
-			next-depth index data))))
-	((vectorp initial-contents)
-	 (unless (= (length (the vector initial-contents)) (car dimensions))
-	   (error "This part of initial-contents, ~S, is an unappropriate ~
-		   length for the dimension, ~S."
-		  initial-contents (car dimensions)))
-	 (do ((i-index 0 (1+ i-index))
-	      (i-end (length (the vector initial-contents)))
-	      (next-dimensions (cdr dimensions))
-	      (next-depth (the fixnum (1- depth))))
-	     ((= i-index i-end) index)
-	   (declare (fixnum i-index i-end))
-	   (setq index (copy-contents-aux
-			next-dimensions (aref initial-contents index)
-			element-type next-depth index data))))
-	(t
-	 (error "~S is not a sequence, and cannot be used to initialize~%~
-		the contents of an array." initial-contents))))
 
-;;; ELEMENT-TYPE-TO-ACCESS-CODE returns the Spice Lisp I-Vector access code to
-;;; be used for the data vector of an array with the given access code.
-;;;
-(defun element-type-to-access-code (type)
-  (cond ((subtypep type 'bit) 0)
-	((subtypep type '(unsigned-byte 2)) 1)
-	((subtypep type '(unsigned-byte 4)) 2)
-	((subtypep type '(unsigned-byte 8)) 3)
-	((subtypep type '(unsigned-byte 16)) 4)
-	((subtypep type '(unsigned-byte 32)) 5)
-	(t (error "Unexpected array element type -- ~S." type))))
-
-
-;;; ARRAY-LINEAR-LENGTH returns the number of elements an array with the
-;;; specified dimensions would have.
+(defun 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 (= (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)))
+		      (unless (listp contents)
+			(error "Malformed :initial-contents.  ~S is an atom, ~
+			but ~D more layer~:P needed."
+			       contents
+			       (- (length dimensions) axis)))
+		      (dolist (content contents)
+			(frob (1+ axis) (cdr dims) content))))))
+      (frob 0 dimensions initial-contents))))
+
+
+;;; Some people out there are still calling MAKE-VECTOR:
 ;;;
-(defun array-linear-length (dimensions)
-  (do ((dimensions dimensions (cdr dimensions))
-       (length 1))
-      ((null dimensions) length)
-    (declare (fixnum length))
-    (setq length (* length (the fixnum (car dimensions))))))
+(setf (symbol-function 'make-vector) #'make-array)
 
-(defun aref (array &rest subscripts)
-  "Returns the element of the Array specified by the Subscripts."
-  (if (and subscripts (null (cdr subscripts)))
-      (aref array (car subscripts))
-      (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
-	   (dim-index (1- (the fixnum (%primitive header-length array)))
-		      (1- dim-index))
-	   (chunk-size 1)
-	   (result 0))
-	  ((= (the fixnum dim-index) %array-dim-base)
-	   (if (atom subscripts)
-	       (with-array-data ((data array) (start) (end))
-		 (declare (ignore end))
-		 (aref data (the fixnum (+ start result))))
-	       (error "Too many subscripts for array reference.")))
-	(declare (fixnum dim-index chunk-size result))
-	(let ((axis (%primitive header-ref array dim-index)))
-	  (declare (fixnum axis))
-	  (cond ((atom subscripts)
-		 (error "Too few subscripts for array reference."))
-		((not (< -1 (the fixnum (car subscripts)) axis))
-		 (error "Subscript ~S is out of bounds." (car subscripts)))
-		(t
-		 (setq result (the fixnum
-				   (+ result
-				      (the fixnum
-					   (* (the fixnum (car subscripts))
-					      chunk-size)))))
-		 (setq chunk-size (* chunk-size axis))))))))
 
-(defun %aset (array &rest stuff)
-  (if (and (cdr stuff) (null (cddr stuff)))
-      (setf (aref array (car stuff)) (cadr stuff))
-      (let ((rstuff (nreverse (the list stuff))))
-	(do ((subscripts (cdr rstuff) (cdr subscripts))
-	     (dim-index (1- (the fixnum (%primitive header-length array)))
-			(1- dim-index))
+(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))
+    (macrolet ((dispatch (&rest stuff)
+		 `(etypecase vector
+		    ,@(mapcar #'(lambda (type)
+				  `(,type
+				    (data-vector-ref (the ,type vector)
+						     index)))
+			      stuff))))
+      (dispatch
+       simple-vector
+       simple-bit-vector
+       simple-string
+       (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 (*))))))
+
+(defun data-vector-set (array index new-value)
+  (with-array-data ((vector array) (index index) (end))
+    (declare (ignore end))
+    (macrolet ((dispatch (&rest stuff)
+		 `(etypecase vector
+		    ,@(mapcar #'(lambda (type)
+				  `(,type
+				    (data-vector-set (the ,type vector)
+						     index
+						     new-value)))
+			      stuff))))
+      (dispatch
+       simple-vector
+       simple-bit-vector
+       simple-string
+       (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 (*))))))
+
+
+
+(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))
-	    ((= dim-index %array-dim-base)
-	     (if (atom subscripts)
-		 (with-array-data ((data array) (start) (end))
-		   (declare (ignore end))
-		   (setf (aref data (+ start result)) (car rstuff)))
-		 (error "Too many subscripts for array reference.")))
-	  (declare (fixnum dim-index chunk-size result))
-	  (let ((axis (%primitive header-ref array dim-index)))
-	    (declare (fixnum axis))
-	    (cond ((atom subscripts)
-		   (error "Too few subscripts for array reference."))
-		  ((not (< -1 (the fixnum (car subscripts)) axis))
-		   (error "Subscript ~S is out of bounds."
-			  (car subscripts)))
-		  (t
-		   (setq result (+ result
-				   (the fixnum (* (the fixnum (car subscripts))
-						  chunk-size))))
-		   (setq chunk-size (* chunk-size axis)))))))))
+	    ((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)))
 
 ;;; %Apply-aset is called when (setf (apply #'aref ...) new-value) is
 ;;; called.
 
-(defun %apply-aset (new-value array &rest stuff)
-  (if (null (cdr stuff))
-      (setf (aref array (car stuff)) new-value)
-      (let ((rstuff (nreverse (the list stuff))))
-	(do ((subscripts rstuff (cdr subscripts))
-	     (dim-index (1- (the fixnum (%primitive header-length array)))
-			(1- dim-index))
-	     (chunk-size 1)
-	     (result 0))
-	    ((= dim-index %array-dim-base)
-	     (if (atom subscripts)
-		 (with-array-data ((data array) (start) (end))
-				  (declare (ignore end))
-				  (setf (aref data (+ start result)) new-value))
-		 (error "Too many subscripts for array reference.")))
-	  (declare (fixnum dim-index chunk-size result))
-	  (let ((axis (%primitive header-ref array dim-index)))
-	    (declare (fixnum axis))
-	    (cond ((atom subscripts)
-		   (error "Too few subscripts for array reference."))
-		  ((not (< -1 (the fixnum (car subscripts)) axis))
-		   (error "Subscript ~S is out of bounds."
-			  (car subscripts)))
-		  (t
-		   (setq result (+ result
-				   (the fixnum (* (the fixnum (car subscripts))
-						  chunk-size))))
-		   (setq chunk-size (* chunk-size axis)))))))))
+(defun %apply-aset (new-value array &rest subscripts)
+  (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."
+  (row-major-aref array index))
+
+(defun %set-row-major-aref (array index new-value)
+  (setf (row-major-aref array index) new-value))
+
+
+
+(defun svref (simple-vector index)
+  "Returns the Index'th element of the given Simple-Vector."
+  (declare (simple-vector simple-vector) (fixnum index))
+  (aref simple-vector index))
+
+(defun %svset (simple-vector index new)
+  (declare (simple-vector simple-vector) (fixnum index))
+  (setf (aref simple-vector index) new))
+
+;;; The following function is used when (setf (apply #'svref ...) new
+;;; is compiled.
+
+(defun %apply-svset (new simple-vector index)
+  (declare (simple-vector simple-vector) (fixnum index))
+  (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))
+  (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
+
+
+(defun %bitset (bit-array &rest stuff)
+  (declare (type (array bit) bit-array))
+  (let ((subscripts (butlast stuff))
+	(new-value (car (last stuff))))
+    (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))
+  (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))
+  (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)))
+
+
+
+
+
+;;;; Random array properties.
 
 (defun array-element-type (array)
   "Returns the type of the elements of the array"
-  (cond ((bit-vector-p array)
-	 '(mod 2))
-	((stringp array)
-	 'string-char)
-	((simple-vector-p array)
-	 t)
-	((array-header-p array)
-	 (with-array-data ((data array) (start) (end))
-	   (declare (ignore start end))
-	   (array-element-type data)))
-	((vectorp array)
-	 (case (%primitive get-vector-access-code array)
-	   (0 'bit)
-	   (1 '(unsigned-byte 2))
-	   (2 '(unsigned-byte 4))
-	   (3 '(unsigned-byte 8))
-	   (4 '(unsigned-byte 16))
-	   (5 '(unsigned-byte 32))))
-	(t (error "~S is not an array." array))))
+  (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-character)
+       ((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."
-  (if (array-header-p array)
-      (the fixnum (- (the fixnum (%primitive header-length array))
-		     %array-first-dim-slot))
-      1))
+  (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 (fixnum axis-number))
+  (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)
-      (if (and (>= axis-number 0)
-	       (< axis-number (the fixnum (array-rank array))))
-	  (%primitive header-ref array (the fixnum (+ %array-first-dim-slot axis-number)))
-	  (error "~S is an illegal axis number." axis-number))
-      (if (= axis-number 0)
-	  (%primitive vector-length array)
-	  (error "~S is an illegal axis number." axis-number))))
+      (%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 ((index %array-first-dim-slot (1+ index))
-	   (end (%primitive header-length array))
-	   (result ()))
-	  ((= index end) (nreverse result))
-	(declare (fixnum index end))
-	(push (%primitive header-ref array index) result))
-      (list (%primitive vector-length array))))
+      (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)
-      (%primitive header-ref array %array-length-slot)
-      (%primitive vector-length array)))
+      (%array-available-elements array)
+      (length (the vector array))))
 
-(defun array-in-bounds-p (array &rest subscripts)
-  "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
-  (if (array-header-p array)
-      (do ((dim-index %array-first-dim-slot (1+ dim-index))
-	   (dim-index-limit (+ %array-first-dim-slot
-			       (the fixnum (array-rank array))))
-	   (subs subscripts (cdr subs)))
-	  ((= dim-index dim-index-limit)
-	   (atom subs))
-	(declare (fixnum dim-index dim-index-limit))
-	(if (atom subs)
-	    (return nil)
-	    (if (not (< -1
-			(the fixnum (car subs))
-			(the fixnum (%primitive header-ref array dim-index))))
-		(return nil))))
-      (and (null (cdr subscripts))
-	   (< -1
-	      (the fixnum (car subscripts))
-	      (the fixnum (%primitive vector-length array))))))
-
-(defun array-row-major-index (array &rest subscripts)
-  "Returns the index into the Array's data vector for the given subscripts."
-  (if (array-header-p array)
-      (do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
-	   (dim-index (1- (the fixnum (%primitive header-length array)))
-		      (1- dim-index))
-	   (chunk-size 1)
-	   (result 0))
-	  ((= dim-index %array-dim-base)
-	   (if (atom subscripts)
-	       result
-	       (error "Too many subscripts for array reference.")))
-	(declare (fixnum dim-index chunk-size result))
-	(let ((axis (%primitive header-ref array dim-index)))
-	  (declare (fixnum axis))
-	  (cond ((null subscripts)
-		 (error "Too few subscripts for array reference."))
-		((not (< -1 (the fixnum (car subscripts)) axis))
-		 (error "Subscript ~S is out of bounds." (car subscripts)))
-		(t
-		 (setq result (+ result
-				 (the fixnum (* (the fixnum (car subscripts))
-						chunk-size))))
-		 (setq chunk-size (* chunk-size axis))))))
-      (cond ((null subscripts)
-	     (error "Too few subscripts for array reference."))
-	    ((not (< -1
-		     (the fixnum (car subscripts))
-		     (length (the simple-array array))))
-	     (error "Subscript ~S is out of bounds." (car subscripts)))
-	    (t
-	     (car subscripts)))))
 
 (defun adjustable-array-p (array)
-  "Returns T if the given Array is adjustable, or Nil otherwise."
+  "Returns T if the given Array is adjustable, or NIL otherwise."
+  (declare (array array))
   (array-header-p array))
 
 
-(defun row-major-aref (array index)
-  "Returns the element of array corressponding to the row-major index.  This is
-   SETF'able."
-  (with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (aref data (+ start index))))
 
-(defsetf row-major-aref %set-row-major-aref)
-
-(defun %set-row-major-aref (array index new-value)
-  (with-array-data ((data array) (start) (end))
-    (declare (ignore end))
-    (setf (aref data (+ start index)) new-value)))
-
-(defun svref (simple-vector index)
-  "Returns the Index'th element of the given Simple-Vector."
-  (svref simple-vector index))
-
-(defun %svset (simple-vector index new)
-  (setf (svref simple-vector index) new))
-
-;;; The following function is used when (setf (apply #'svref ...) new
-;;; is compiled.
-
-(defun %apply-svset (new simple-vector index)
-  (setf (svref simple-vector index) new))
+
+;;;; Fill pointer frobbing stuff.
 
 (defun array-has-fill-pointer-p (array)
   "Returns T if the given Array has a fill pointer, or Nil otherwise."
-  (and (vectorp array) (array-header-p array)))
+  (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."
-  (if (and (vectorp vector) (array-header-p vector))
-      (%primitive header-ref vector %array-fill-pointer-slot)
+  (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 (fixnum new))
-  (if (and (vectorp vector) (array-header-p vector))
-      (if (> new (the fixnum (%primitive header-ref vector %array-length-slot)))
-	  (error "New fill pointer, ~S, is larger than the length of the vector."
-		 new)
-	  (%primitive header-set vector %array-fill-pointer-slot new))
+  (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)
@@ -462,71 +533,46 @@
    to New-El and increment fill pointer by one.  If the fill pointer is
    too large, Nil is returned, otherwise the new fill pointer value is 
    returned."
-  (if (array-header-p array)
-      (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
-	(declare (fixnum fill-pointer))
-	(cond ((= fill-pointer
-		  (the fixnum (%primitive header-ref array %array-length-slot)))
-	       nil)
-	      (t (%primitive header-set array %array-fill-pointer-slot
-			     (1+ fill-pointer))
-		 (with-array-data ((data array) (start) (end))
-		   (declare (ignore end))
-		   (setf (aref data (+ fill-pointer start)) new-el))
-		 fill-pointer)))
-      (error "~S: Object has no fill pointer." array)))
-
-(defun vector-push-extend (new-el array &optional (extension (length array)))
+  (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))))))
+
+(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 (fixnum extension))
-  (if (array-header-p array)
-      (let ((length (%primitive header-ref array %array-length-slot))
-	    (fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
-	(declare (fixnum length fill-pointer))
-	(with-array-data ((data array) (start) (end))
-	  (declare (ignore end))
-	  (if (= fill-pointer length)
-	      (do* ((new-index 0 (1+ new-index))
-		    (new-length (let ((l (+ length extension)))
-				  (declare (fixnum l))
-				  (if (zerop l) 1 l)))
-		    (old-index start (1+ old-index))
-		    (new-data (make-array (if (zerop new-length) 1 new-length)
-					  :element-type (array-element-type
-							 array))))
-		   ((= new-index length)
-		    (setq data new-data)
-		    (setq start 0)
-		    (set-array-header array data new-length
-				      (1+ fill-pointer) start new-length nil))
-		(declare (fixnum new-index new-length old-index))
-		(setf (aref new-data new-index) (aref data old-index)))
-	      (%primitive header-set array
-			  %array-fill-pointer-slot (1+ fill-pointer)))
-	  (setf (aref data (+ fill-pointer start)) new-el)
-	  fill-pointer))
-      (error "~S has no fill pointer." array)))
+  (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))))
 
 (defun vector-pop (array)
   "Attempts to decrease the fill-pointer by 1 and return the element
    pointer to by the new fill pointer.  If the new value of the fill
    pointer is 0, an error occurs."
-  (if (array-header-p array)
-      (let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
-	(declare (fixnum fill-pointer))
-	(cond ((< fill-pointer 1)
-	       (error "Fill-pointer reached 0."))
-	      (t
-	       (let ((fill-pointer (1- fill-pointer)))
-		 (declare (fixnum fill-pointer))
-		 (with-array-data ((data array) (start) (end))
-		   (declare (ignore end))
-		   (%primitive header-set array %array-fill-pointer-slot
-			       fill-pointer)
-		   (aref data (+ fill-pointer start)))))))
-      (error "~S: Object has no fill pointer." array)))
+  (declare (vector array))
+  (let ((fill-pointer (fill-pointer array)))
+    (declare (fixnum fill-pointer))
+    (cond ((zerop fill-pointer)
+	   (error "Nothing left to pop."))
+	  (t
+	   (setf (%array-fill-pointer array)
+		 (1- fill-pointer))
+	   (aref array fill-pointer)))))
+
 
+
+;;;; Adjust-array
 
 (defun adjust-array (array dimensions &key
 			   (element-type (array-element-type array))
@@ -551,9 +597,9 @@
 	   (if (or initial-element-p displaced-to)
 	       (error "Initial contents may not be specified with ~
 		       the :initial-element or :displaced-to option."))
-	   (let* ((array-size (array-linear-length dimensions))
+	   (let* ((array-size (apply #'* dimensions))
 		  (array-data (data-vector-from-inits
-			       dimensions array-size array-rank element-type
+			       dimensions array-size element-type
 			       initial-contents initial-element
 			       initial-element-p)))
 	     (set-array-header array array-data array-size
@@ -568,7 +614,7 @@
 	     (error "One can't displace an array of type ~S into another of ~
 		     type ~S." element-type (array-element-type displaced-to)))
 	   (let ((displacement (or displaced-index-offset 0))
-		 (array-size (array-linear-length dimensions)))
+		 (array-size (apply #'* dimensions)))
 	     (declare (fixnum displacement array-size))
 	     (if (< (the fixnum (array-total-size displaced-to))
 		    (the fixnum (+ displacement array-size)))
@@ -578,37 +624,37 @@
 						     fill-pointer)
 			       displacement dimensions t)))
 	  ((= array-rank 1)
-	   (let ((old-length (%primitive header-ref array %array-length-slot))
+	   (let ((old-length (%array-available-elements 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 (%displacedp array) (< old-length new-length))
+	       (cond ((or (%array-displaced-p array) (< old-length new-length))
 		      (setf new-data
 			    (data-vector-from-inits
-			     dimensions new-length array-rank element-type
+			     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
-			       (%primitive shrink-vector old-data new-length))))
+			       (shrink-vector old-data new-length))))
 	       (set-array-header array new-data new-length
 				 (get-new-fill-pointer array new-length
 						       fill-pointer)
 				 0 dimensions nil))))
 	  (t
-	   (let ((old-length (%primitive header-ref array %array-length-slot))
-		 (new-length (array-linear-length dimensions)))
+	   (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 (%displacedp array)
+	       (let ((new-data (if (or (%array-displaced-p array)
 				       (> new-length old-length))
 				   (data-vector-from-inits
-				    dimensions new-length array-rank
+				    dimensions new-length
 				    element-type () initial-element
 				    initial-element-p)
 				   old-data)))
@@ -621,40 +667,75 @@
 
 (defun get-new-fill-pointer (old-array new-array-size fill-pointer)
   (cond ((not fill-pointer)
-	 (%primitive header-ref old-array %array-fill-pointer-slot))
+	 (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)
-	(t new-array-size)))
+	((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."
-  (cond ((array-header-p vector)
-	 ;; (%primitive shrink-vector
-	 ;;		(%primitive header-ref vector %array-data-slot)
-	 ;;		new-size)
-	 ;; (%primitive header-set vector %array-length-slot new-size)
-	 ;; Instead of shrinking the vector, just set the fill-pointer field.
-	 (%primitive header-set vector %array-fill-pointer-slot new-size)
-	 vector)
-	(t
-	 (%primitive shrink-vector vector new-size))))
+  (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)))))
+  (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."
-  (%primitive header-set array %array-data-slot data)
-  (%primitive header-set array %array-length-slot length)
-  (%primitive header-set array %array-fill-pointer-slot fill-pointer)
-  (%primitive header-set array %array-displacement-slot displacement)
+  (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)
-      (do ((index %array-first-dim-slot (1+ index))
-	   (dims dimensions (cdr dims)))
-	  ((null dims))
-	(declare (fixnum index))
-	(%primitive header-set array index (car dims)))
-      (%primitive header-set array %array-first-dim-slot dimensions))
-  (%set-array-displacedp array displacedp)
+      (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)
 
 
@@ -663,18 +744,20 @@
 
 ;;; Make a temporary to be used when old-data and new-data are EQ.
 ;;;
-(defvar *zap-array-data-temp* (%primitive alloc-g-vector 1000 t))
+(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* (%primitive alloc-g-vector length t)))
+    (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))
+    (fill (the simple-vector *zap-array-data-temp*) initial-element
+	  :end length))
   *zap-array-data-temp*)
 
 
@@ -701,7 +784,6 @@
 	(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)
@@ -714,7 +796,8 @@
 		      ((null subscripts) nil)
 		    (cond ((< (the fixnum (car subscripts))
 			      (the fixnum (car limits)))
-			   (rplaca subscripts (1+ (the fixnum (car subscripts))))
+			   (rplaca subscripts
+				   (1+ (the fixnum (car subscripts))))
 			   (return ,index))
 			  (t (rplaca subscripts 0))))))
       (do ((index (make-list (length old-dims) :initial-element 0)
@@ -748,126 +831,111 @@
 
 ;;;; Some bit stuff.
  
-(defun bit (bit-array &rest subscripts)
-  "Returns the bit from the Bit-Array at the specified Subscripts."
-  (apply #'aref bit-array subscripts))
-
-(defun %bitset (bit-array &rest stuff)
-  (apply #'%aset bit-array stuff))
-
-(defun sbit (simple-bit-array &rest subscripts)
-  "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
-  (apply #'aref simple-bit-array subscripts))
-
-(defun %sbitset (bit-array &rest stuff)
-  (apply #'%aset bit-array stuff))
-
 (defun bit-array-same-dimensions-p (array1 array2)
-  (and (= (the fixnum (%primitive header-length array1))
-	  (the fixnum (%primitive header-length array2)))
-       (do ((index %array-first-dim-slot (1+ index))
-	    (length (%primitive header-length array1)))
-	   ((= index length) t)
-	 (declare (fixnum index length))
-	 (if (/= (the fixnum (%primitive header-ref array1 index))
-		 (the fixnum (%primitive header-ref array2 index)))
-	     (return nil)))))
-
-(defun bit-array-boole (array1 array2 op result-array)
-  (if (eq result-array t) (setq result-array array1))
-  (cond ((simple-bit-vector-p array1)
-	 (let ((length (%primitive vector-length array1)))
-	   (declare (fixnum length))
-	   (unless (and (simple-bit-vector-p array2)
-			(= (the fixnum (%primitive vector-length array2)) length))
-	     (error "~S and ~S do not have the same dimensions." array1 array2))
-	   (if result-array
-	       (unless (and (simple-bit-vector-p result-array)
-			    (= (the fixnum (%primitive vector-length result-array))
-			       length))
-		 (error "~S and ~S do not have the same dimensions."
-			array1 result-array))
-	       (setq result-array (%primitive alloc-bit-vector length)))
-	   (%primitive bit-bash array1 array2 result-array op)))
-	(t
-	 (unless (bit-array-same-dimensions-p array1 array2)
-	   (error "~S and ~S do not have the same dimensions." array1 array2))
-	 (if result-array
-	     (unless (bit-array-same-dimensions-p array1 result-array)
-	       (error "~S and ~S do not have the same dimensions."
-		      array1 result-array))
-	     (setq result-array (make-array (array-dimensions array1)
-					    :element-type '(mod 2))))
-	 (with-array-data ((data1 array1) (start1) (end1))
-	   (declare (ignore end1))
-	   (with-array-data ((data2 array2) (start2) (end2))
-	     (declare (ignore end2))
-	     (with-array-data ((data3 result-array) (start3) (end3))
-	       (declare (ignore end3))
-	       (let ((length (%primitive header-ref array1 %array-length-slot)))
-		 (declare (fixnum length))
-		 (do ((index 0 (1+ index))
-		      (index1 start1 (1+ index1))
-		      (index2 start2 (1+ index2))
-		      (index3 start3 (1+ index3)))
-		     ((= index length) result-array)
-		   (declare (fixnum index index1 index2 index3))
-		   (setf (sbit data3 index3)
-			 (boole op (sbit data1 index1)
-				(sbit data2 index2))))))))))
-  result-array)
-
-(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical AND on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-and result-bit-array))
-
-(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical IOR on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-ior result-bit-array))
-
-(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical XOR on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-xor result-bit-array))
-
-(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical EQV  on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-eqv result-bit-array))
-
-(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical NAND  on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-nand result-bit-array))
-
-(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical NOR  on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-nor result-bit-array))
-
-(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ANDC1 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-andc1 result-bit-array))
-
-(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ANDC2 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-andc2 result-bit-array))
-
-(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ORC1 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-orc1 result-bit-array))
-
-(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
-  "Performs a bit-wise logical ORC2 on the elements of Bit-Array1 and Bit-Array2
-  putting the results in the Result-Bit-Array."
-  (bit-array-boole bit-array1 bit-array2 boole-orc2 result-bit-array))
+  (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 32bit-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))
+	   (do ((index vm:vector-data-offset (1+ index))
+		(end (+ vm:vector-data-offset
+			(truncate (the index
+				       (+ (length bit-array-1)
+					  vm:word-bits -1))
+				  vm:word-bits))))
+	       ((= index end) result-bit-array)
+	     (declare (optimize (speed 3))
+		      (type index index end))
+	     (setf (%raw-bits result-bit-array index)
+		   (,32bit-function (%raw-bits bit-array-1 index)
+				    (%raw-bits bit-array-2 index))))
+	   (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 32bit-logical-and)
+(def-bit-array-op bit-ior logior 32bit-logical-or)
+(def-bit-array-op bit-xor logxor 32bit-logical-xor)
+(def-bit-array-op bit-eqv logeqv 32bit-logical-eqv)
+(def-bit-array-op bit-nand lognand 32bit-logical-nand)
+(def-bit-array-op bit-nor lognor 32bit-logical-nor)
+(def-bit-array-op bit-andc1 logandc1 32bit-logical-andc1)
+(def-bit-array-op bit-andc2 logandc2 32bit-logical-andc2)
+(def-bit-array-op bit-orc1 logorc1 32bit-logical-orc1)
+(def-bit-array-op bit-orc2 logorc2 32bit-logical-orc2)
 
 (defun bit-not (bit-array &optional result-bit-array)
-  "Performs a bit-wise logical NOT in the elements of the Bit-Array putting
-  the results into the Result-Bit-Array."
-  (bit-array-boole bit-array bit-array boole-nor result-bit-array))
+  "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))
+	(do ((index vm:vector-data-offset (1+ index))
+	     (end (+ vm:vector-data-offset
+		     (truncate (the index
+				    (+ (length bit-array) vm:word-bits -1))
+			       vm:word-bits))))
+	    ((= index end) result-bit-array)
+	  (declare (type index index end)
+		   (optimize (speed 3)))
+	  (setf (%raw-bits result-bit-array index)
+		(32bit-logical-not (%raw-bits bit-array index))))
+	(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/defstruct.lisp b/code/defstruct.lisp
index b8ed70a14..4f464095c 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -7,21 +7,16 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.9 1990/08/24 18:10:38 wlott Exp $
+;;;
 ;;; Defstruct structure definition package (Mark II).
 ;;; Written by Skef Wholey and Rob MacLachlan.
 ;;;
 (in-package 'c)
 (export '(lisp::defstruct) "LISP")
 
-;;; In Spice Lisp, the default structure representation is a simple-vector with
-;;; the subtype field set to 1.  The first element is used to hold the name of
-;;; the structure.  This piece of implementation-dependency resides in the
-;;; macros defined here.
-;;;
-(proclaim '(inline structurify))
-(defun structurify (structure)
-  "Frobs a vector to turn it into a named structure.  Returns the vector."
-  (%primitive set-vector-subtype structure %g-vector-structure-subtype))
+;;; Note: STRUCTURIFY is defined in struct.lisp.  It converts a simple-vector
+;;; into a structure.
 
 
 ;;; This version of Defstruct is implemented using Defstruct, and is free of
@@ -285,11 +280,13 @@
 ;;; This is called by the accessor closures, which have a handle on the type's
 ;;; Defstruct-Description.
 ;;;
+#+new-compiler
 (proclaim '(inline typep-to-structure))
+#+new-compiler
 (defun typep-to-structure (obj info)
   (declare (type defstruct-description info) (inline member))
   (and (structurep obj)
-       (let ((name (%primitive header-ref obj 0)))
+       (let ((name (%primitive structure-ref obj 0)))
 	 (or (eq name (dd-name info))
 	     (member name (dd-included-by info) :test #'eq)))))
 
@@ -312,7 +309,7 @@
 		(unless (typep-to-structure structure info)
 		  (error "Structure for accessor ~S is not a ~S:~% ~S"
 			 (dsd-accessor dsd) (dd-name info) structure))
-		(%primitive header-ref structure (dsd-index dsd))))
+		(%primitive structure-index-ref structure (dsd-index dsd))))
       
       (unless (dsd-read-only slot)
 	(setf (fdefinition `(setf ,(dsd-accessor slot)))
@@ -326,7 +323,7 @@
 		    (error "New-Value for setter ~S is not a ~S:~% ~S."
 			   `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
 			   new-value))
-		  (%primitive header-set structure (dsd-index dsd)
+		  (%primitive structure-index-set structure (dsd-index dsd)
 			      new-value))))))
 
   (when (dd-predicate info)
@@ -348,11 +345,11 @@
 		(do ((i 1 (1+ i))
 		     (res (%primitive alloc-g-vector len nil)))
 		    ((= i len)
-		     (%primitive header-set res 0 (dd-name info))
+		     (%primitive structure-set res (dd-name info) 0)
 		     (structurify res))
 		  (declare (fixnum i))
-		  (%primitive header-set res i
-			      (%primitive header-ref structure i)))))))
+		  (%primitive structure-index-set res i
+			      (%primitive structure-index-ref structure i)))))))
   (when (dd-doc info)
     (setf (documentation (dd-name info) 'type) (dd-doc info))))
 
@@ -378,7 +375,7 @@
 	    (declare (type ,type structure))
 	    (the ,slot-type (elt structure ,index)))
 	  ,@(unless (dsd-read-only slot)
-	      `((defun (setf ,name) (structure new-value)
+	      `((defun (setf ,name) (new-value structure)
 		  (declare (type ,type structure) (type ,slot-type new-value))
 		  (setf (elt structure ,index) new-value)))))
        stuff))))
@@ -476,7 +473,7 @@
       (let ((arg (car args)))
 	(cond ((not (atom arg))
 	       (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
-	      ((memq arg '(&optional &rest &aux &key))
+	      ((member arg '(&optional &rest &aux &key) :test #'eq)
 	       (setq arg-kind arg))
 	      (t
 	       (case arg-kind
@@ -494,7 +491,8 @@
 			  :initial-element `',(dd-name defstruct))
 	       (make-list (dd-offset defstruct))))
 	  (thing (mapcar #'(lambda (slot)
-			     (if (memq slot slots-in-arglist)
+			     (if (member slot slots-in-arglist
+					 :test #'eq)
 				 (dsd-name slot)
 				 (dsd-default slot)))
 			 slots)))
@@ -567,7 +565,7 @@
   (let ((def (info type structure-info type)))
     (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
 	`(and (structurep ,object)
-	      (if (eq (%primitive header-ref ,object 0) ',type)
+	      (if (eq (%primitive structure-ref ,object 0) ',type)
 		  t
 		  (,(dd-predicate def) ,object)))
 	`(lisp::structure-typep ,object ',type))))
diff --git a/code/describe.lisp b/code/describe.lisp
index f63e49bed..9a1831a44 100644
--- a/code/describe.lisp
+++ b/code/describe.lisp
@@ -206,12 +206,12 @@
   (let ((rank (array-rank x)))
     (cond ((> rank 1)
 	   (format t "~&~S is " x)
-	   (write-string (if (%displacedp x) "a displaced" "an"))
+	   (write-string (if (%array-displaced-p x) "a displaced" "an"))
 	   (format t " array of rank ~A." rank)
 	   (format t "~%Its dimensions are ~S." (array-dimensions x)))
 	  (t
 	   (format t "~&~S is a ~:[~;displaced ~]vector of length ~D." x
-		   (%displacedp x) (length x))
+		   (and (array-header-p x) (%array-displaced-p x)) (length x))
 	   (if (array-has-fill-pointer-p x)
 	       (format t "~&It has a fill pointer, currently ~d"
 		       (fill-pointer x))
@@ -228,32 +228,30 @@
 	   ,output))))
 
 (defun describe-function (x)
-  (case (%primitive get-vector-subtype x)
-    (#.%function-entry-subtype
-     (describe-function-compiled x))
-    (#.%function-closure-subtype
+  (declare (type function x))
+  (case (get-type x)
+    (#.vm:closure-header-type
      (describe-function-lex-closure x))
+    ((#.vm:function-header-type #.vm:closure-function-header-type)
+     (describe-function-compiled x))
     (t
      (format t "~&It is an unknown type of function."))))
 
 (defun describe-function-compiled (x)
-  (let ((args (%primitive header-ref x %function-entry-arglist-slot)))
+  (let ((args (%function-header-arglist x)))
     (describe-function-arg-list
      *current-describe-object* (string= args "()") (write-string args)))
   (let ((*print-level* nil)
 	(*print-length* nil)
-	(type (%primitive header-ref x %function-entry-type-slot)))
+	(type (%function-header-type x)))
     (format t "~&Its argument types are:~%  ~S" (second type))
     (format t "~&Its result type is:~%  ~S" (third type)))
   
-  (let ((name (%primitive header-ref x %function-name-slot)))
+  (let ((name (%function-header-name x)))
     (when (symbolp name)
       (desc-doc name 'function "Function Documention:")))
   
-  (let ((info (%primitive header-ref
-			  (%primitive header-ref x
-				      %function-entry-constants-slot)
-			  %function-constants-debug-info-slot)))
+  (let ((info (di::code-debug-info (di::function-code-header x))))
     (when info
       (let ((sources (c::compiled-debug-info-source info)))
 	(format t "~&On ~A it was compiled from:"
@@ -275,14 +273,11 @@
 (defun describe-function-lex-closure (x)
   (print-for-describe x)
   (format t " is a lexical closure.~%")
+  (describe-function-compiled (%closure-function x))
   (format t "~&Its lexical environment is:")
-  (indenting-further *standard-output* 8
-    (do ((i %function-closure-variables-offset (1+ i)))
-	((= i (%primitive header-length x)))
-      (format t "~&~D: ~S"
-	      (- i %function-closure-variables-offset)
-	      (%primitive header-ref x i))))
-  (describe-function-compiled (%primitive header-ref x %function-name-slot)))
+  (indenting-further *standard-output* 8)
+  (dotimes (i (get-header-data x))
+    (format t "~&~D: ~S" i (%closure-index-ref x i))))
 
 
 (defun print-for-describe (x &optional (freshp t))
diff --git a/code/error.lisp b/code/error.lisp
index 6ded62740..4c1917ae6 100644
--- a/code/error.lisp
+++ b/code/error.lisp
@@ -530,7 +530,8 @@ The previous version is uglier, but it sets up unique run-time tags.
 ;;; hyperspace.
 ;;;
 (defmacro infinite-error-protect (form)
-  `(if (and (boundp '*error-system-initialized*) (numberp *current-error-depth*))
+  `(if (and (boundp '*error-system-initialized*)
+	    (numberp *current-error-depth*))
        (let ((*current-error-depth* (1+ *current-error-depth*)))
 	 (if (> *current-error-depth* *max-error-depth*)
 	     (error-error "Help! " *current-error-depth* " nested errors.")
@@ -974,265 +975,13 @@ The previous version sets up unique run-time tags.
    none exists.")
 
 
-
 
-;;;; Internal Error Codes.
-
-;;; *Internal-error-table* contains a vector, by error code, of functions.
-;;; This is used in %SP-INTERNAL-ERROR, and initialized MAKE-ERROR-TABLE.
-;;;
-(defvar *internal-error-table*)
-
-#+new-compiler
-;;; %SP-INTERNAL-ERROR is called by the microcode when an internal error
-;;; occurrs.  It is simply a dispatch routine which looks up a specialized
-;;; function to call in the special variable, *internal-error-table*.
-;;;
-;;; ERR-CODE -- a fixnum which identifies the specific error.
-;;; PC -- the relative offset of the NEXT macro instruction to be
-;;;        executed in the code vector of the errorful function.
-;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE.
-;;;
-(defun lisp::%sp-internal-error (err-code arg3 arg4)
-  (infinite-error-protect
-   (funcall (svref *internal-error-table* err-code)
-	    (find-caller-name)
-	    0
-	    arg3
-	    arg4)))
-
-;;; DEF-INTERNAL-ERROR defines a form which can be put into the system init
-;;; file (spinit, or vaxinit) to define the errors which the microcode may
-;;; signal.  The form looks like
-;;;
-;;; (def-internal-error err-code condition flag control-string &rest args)
-;;;  ERR-CODE -- the internal code for this error. less than or equal to
-;;;               max-internal-error which is declared in the init file.
-;;;  CONDITION -- the name of the error to signal
-;;;  FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR.  (not evaluated)
-;;;           if CORRECTABLE, %sp-internal-error may return correction values
-;;;           if SYSTEM-ERROR, the CONDITION arg is ignored.
-;;;  CONTROL-STRING -- the error message as a format control string.
-;;;  ARGS -- The args to the control string.  The 3rd & 4th args to
-;;;           %sp-internal-error are available as the variables ARG3 & ARG4.
-;;;
-;;; NOTE: system-error is never supplied, and condition is never used.  Maybe
-;;;       it will be when we signal appropriate conditions for certain
-;;;       situations.
-;;;
-
-;example
-;  (def-internal-error 6 :unbound-symbol correctable
-;    "Unbound symbol: ~s." arg3)
-
-
-(defmacro def-internal-error (number condition flag control-string &rest args)
-  (declare (ignore condition))
-  `(setf (svref *internal-error-table* ,number)
-	 #'(lambda (callers-name PC arg3 arg4)
-	     (declare (ignore ,@(unless (eq flag 'system-error) '(PC))
-			      ,@(unless (member 'arg3 args) '(arg3))
-			      ,@(unless (member 'arg4 args) '(arg4))))
-	     ,(case flag
-		((fatal) `(error 'simple-error
-				 :function-name callers-name
-				 :format-string ,control-string
-				 :format-arguments (list ,@args)))
-		((correctable) `(cerror 'simple-error
-					:function-name callers-name
-					:format-string ,control-string
-					:format-arguments (list ,@args)))))))
-
-
-(defconstant max-internal-error 100
-  "The largest internal error number for Spice Lisp.")
-
-(proclaim '(special allocation-space))
-
-
-(defun make-error-table ()
-  (setq *internal-error-table*
-	(make-array (1+ max-internal-error)
-		    :initial-element
-		    #'(lambda (&rest ignore)
-			(declare (ignore ignore))
-			(break "Undefined Error."))))
-
-  (def-internal-error 1 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'List)
-  (def-internal-error 2 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Symbol)
-  (def-internal-error 3 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Number)
-  (def-internal-error 4 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Integer)
-  (def-internal-error 5 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Ratio)
-  (def-internal-error 6 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Complex)
-  (def-internal-error 7 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Vector-like)
-  (def-internal-error 8 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'simple-vector)
-  (def-internal-error 9 :invalid-function fatal
-    "Invalid function: ~s." arg3)
-  (def-internal-error 10 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been a function or an array." arg3)
-  (def-internal-error 11 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'U-vector-like)
-  (def-internal-error 12 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'simple-bit-vector)
-  (def-internal-error 13 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3
-    'simple-string)
-  (def-internal-error 14 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'character)
-  (def-internal-error 15 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'Control-Stack-Pointer)
-  (def-internal-error 16 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'Binding-Stack-Pointer)
-  (def-internal-error 17 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'Array)
-  (def-internal-error 18 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s."
-    arg3 'Positive-Fixnum)
-  (def-internal-error 19 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'SAP-pointer)
-  (def-internal-error 20 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of tyep ~s." arg3 'system-pointer)
-  (def-internal-error 21 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'float)
-  (def-internal-error 22 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'rational)
-  (def-internal-error 23 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been a non-complex number." arg3)
-
-  (def-internal-error 25 :unbound-variable fatal
-    "Unbound variable: ~s." arg3)
-  (def-internal-error 26 :undefined-function fatal
-    "Undefined function: ~s." arg3)
-  (def-internal-error 27 :error fatal
-    "Attempt to alter NIL.")
-  (def-internal-error 28 :error fatal
-    "Attempt to alter NIL.")
-  (def-internal-error 29 :error fatal
-    "Circularity detected in chain of symbols from definition cell of symbol ~S."
-    arg3)
-
-  ;;Special because handlers won't work while allocation-space is wrong.
-  (setf (svref *internal-error-table* 24)
-	#'(lambda (callers-name ignore0 ignore1 ignore2)
-	    (declare (ignore ignore0 ignore1 ignore2))
-	    (let ((bazfaz allocation-space))
-	      (setq allocation-space 0)
-	      (error 'simple-error
-		     :function-name callers-name
-		     :format-string "Illegal allocation-space value: ~S."
-		     :format-arguments (list bazfaz)))))
-
-  (def-internal-error 30 :error fatal
-    "Illegal u-vector access type: ~s." arg3)
-  (def-internal-error 31 :error fatal
-    "Illegal vector length: ~s." arg3)
-  (def-internal-error 32 :error fatal
-    "Vector index, ~s, out of bounds." arg3)
-  (def-internal-error 33 :error fatal
-    "Illegal index: ~s." arg3)
-  (def-internal-error 34 :error fatal
-    "Illegal shrink value: ~s." arg3)
-  (def-internal-error 35 :error fatal
-    "Shrink value, ~s, is greater than current length of ~s." arg3 arg4)
-  (def-internal-error 36 :error fatal
-    "Illegal data vector, ~S, in an array." arg3)
-  (def-internal-error 37 :error fatal
-    "Too few arguments passed to two or three dimension array access miscop.")
-  (def-internal-error 38 :error fatal
-    "Too many arguments passed to two or three dimension array access miscop.")
-  (def-internal-error 39 :error fatal
-    "Illegal to allocate vector of size: ~s." arg3)
-
-  (def-internal-error 40 :error fatal
-    "Illegal byte pointer: (byte ~s ~s)." arg3 arg4)
-  (def-internal-error 41 :error fatal
-    "Illegal position, ~s, in byte spec." arg3)
-  (def-internal-error 42 :error fatal
-    "Illegal size, ~s, in byte spec." arg3)
-  (def-internal-error 43 :error fatal
-    "Illegal shift count: ~s." arg3)
-  (def-internal-error 44 :error fatal
-    "Illegal boole operation: ~s." arg3)
-
-  (def-internal-error 50 :error fatal "Wrong number of arguments: ~D." arg3)
-
-  (def-internal-error 55 :error fatal
-    "~s is not <= to ~s (Alien index out of bounds.)" arg3 arg4)
-
-  (def-internal-error 60 :error fatal
-    "Attempt to divide ~s by ~s." arg3 arg4)
-  (def-internal-error 61 :unseen-throw-tag fatal
-    "No catcher for throw tag ~s." arg3)
-  (def-internal-error 62 :error fatal
-    "Something using ~S and ~S lead to a short-float underflow." arg3 arg4)
-  (def-internal-error 63 :error fatal
-    "Something using ~S and ~S lead to a short-float overflow." arg3 arg4)
-#|
-  (def-internal-error 64 :error fatal
-    "Something using ~S and ~S lead to a single-float underflow." arg3 arg4)
-  (def-internal-error 65 :error fatal
-    "Something using ~S and ~S lead to a single-float overflow." arg3 arg4)
-|#
-  (def-internal-error 66 :error fatal
-    "Something using ~S and ~S lead to a long-float underflow." arg3 arg4)
-  (def-internal-error 67 :error fatal
-    "Something using ~S and ~S lead to a long-float overflow." arg3 arg4)
-  (def-internal-error 68 :error fatal
-    "Something using ~S caused a short-float underflow." arg3)
-  (def-internal-error 69 :error fatal
-    "Something using ~S caused a short-float overflow." arg3)
-  (def-internal-error 70 :error fatal
-    "Something using ~S caused a long-float underflow." arg3)
-  (def-internal-error 71 :error fatal
-    "Something using ~S caused a long-float overflow." arg3)
-  (def-internal-error 72 :error fatal
-    "~S is not a legal argument to log, it should be non-zero." arg3)
-  (def-internal-error 73 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'string-char)
-  (def-internal-error 74 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'short-float)
-  (def-internal-error 75 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'long-float)
-  (def-internal-error 76 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'fixnum)
-  (def-internal-error 77 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 'cons)
-  (def-internal-error 78 :error fatal
-    "Invalid exit.")
-  (def-internal-error 79 :error fatal
-    "Odd number of arguments in keyword part of argument list.")
-  (def-internal-error 80 :error fatal
-    "~S is not a known keyword argument specifier." arg3)
-  (def-internal-error 81 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3 arg4)
-  (def-internal-error 82 :wrong-type-argument fatal
-    "Wrong type argument, ~s, should have been of type ~s." arg3
-    '(or function symbol))
-  (def-internal-error 83 :error fatal
-    "~S is not = to ~S (Alien index out of bounds.)" arg3 arg4)
-  
-  )
-
-
-
 ;;; ERROR-INIT is called at init time to initialize the error system.
-;;; It initializes the internal error table, and sets a variable.
 ;;;
 (defun error-init ()
-  (make-error-table)
   (setq *error-system-initialized* t))
 
+
 #-new-compiler
 (eval-when (compile)
   (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp
index 24215c3d3..fe3c44ae8 100644
--- a/code/fd-stream.lisp
+++ b/code/fd-stream.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.5 1990/08/24 18:10:52 wlott Exp $
+;;;
 ;;; Streams for UNIX file descriptors.
 ;;;
 ;;; Written by William Lott, July 1989 - January 1990.
@@ -29,15 +31,6 @@
 
 (in-package "LISP")
 
-(defmacro byte-blt (src-string src-start dst-string dst-start dst-end)
-  "Move the bytes from src-string to dst-string."
-  `(system:%primitive byte-blt
-		      ,src-string
-		      ,src-start
-		      ,dst-string
-		      ,dst-start
-		      ,dst-end))
-
 
 ;;;; Buffer manipulation routines.
 
@@ -56,8 +49,7 @@
 (defun next-available-buffer ()
   (if *available-buffers*
       (pop *available-buffers*)
-      (system:make-alien 'alien (* bytes-per-buffer 8))))
-
+      (allocate-system-memory bytes-per-buffer)))
 
 
 ;;;; The FD-STREAM structure.
@@ -73,7 +65,7 @@
   (original nil)	      ; The original file (for :if-exists :rename)
   (delete-original nil)	      ; for :if-exists :rename-and-delete
   (element-size 1)	      ; Number of bytes per element.
-  (element-type 'string-char) ; The type of element being transfered.
+  (element-type 'base-character) ; The type of element being transfered.
   (fd -1 :type fixnum)	      ; The file descriptor
   (buffering :full)	      ; One of :none, :line, or :full
   (char-pos nil)	      ; Character position if known.
@@ -81,14 +73,12 @@
 
   ;; The input buffer.
   (unread nil)
-  (ibuf nil)
   (ibuf-sap nil)
   (ibuf-length nil)
   (ibuf-head 0 :type fixnum)
   (ibuf-tail 0 :type fixnum)
 
   ;; The output buffer.
-  (obuf nil)
   (obuf-sap nil)
   (obuf-length nil)
   (obuf-tail 0 :type fixnum)
@@ -122,7 +112,7 @@
 	 (base (car stuff))
 	 (start (cadr stuff))
 	 (end (caddr stuff))
-	 (buffer (cadddr stuff))
+	 (reuse-sap (cadddr stuff))
 	 (length (- end start)))
     (multiple-value-bind
 	(count errno)
@@ -131,13 +121,12 @@
 			 start
 			 length)
       (cond ((eql count length) ; Hot damn, it workded.
-	     (when buffer
-	       (push buffer *available-buffers*)))
+	     (when reuse-sap
+	       (push base *available-buffers*)))
 	    ((not (null count)) ; Sorta worked.
 	     (push (list base
 			 (+ start count)
-			 end
-			 buffer)
+			 end)
 		   (fd-stream-output-later stream)))
 	    ((= errno mach:ewouldblock)
 	     (error "Write would have blocked, but SERVER told us to go."))
@@ -153,10 +142,10 @@
 ;;;
 ;;;   Arange to output the string when we can write on the file descriptor.
 ;;;
-(defun output-later (stream base start end buffer)
+(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 buffer)))
+	       (list (list base start end reuse-sap)))
 	 (setf (fd-stream-handler stream)
 	       (system:add-fd-handler (fd-stream-fd stream)
 				      :output
@@ -165,14 +154,11 @@
 					  (do-output-later stream)))))
 	(t
 	 (nconc (fd-stream-output-later stream)
-		(list (list base start end buffer)))))
-  (when buffer
+		(list (list base start end reuse-sap)))))
+  (when reuse-sap
     (let ((new-buffer (next-available-buffer)))
-      (setf (fd-stream-obuf stream) new-buffer)
-      (setf (fd-stream-obuf-sap stream)
-	    (system:alien-sap new-buffer))
-      (setf (fd-stream-obuf-length stream)
-	    (/ (system:alien-size new-buffer) 8)))))
+      (setf (fd-stream-obuf-sap stream) new-buffer)
+      (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
 
 ;;; DO-OUTPUT -- internal
 ;;;
@@ -180,11 +166,11 @@
 ;;; so, just queue this one. Otherwise, try to write it. If this would block,
 ;;; queue it.
 ;;;
-(defun do-output (stream base start end buffer)
+(defun do-output (stream base start end reuse-sap)
   (if (not (null (fd-stream-output-later stream))) ; something buffered.
     (progn
-      (output-later stream base start end buffer)
-      ;; XXX check to see if any of this noise can be output
+      (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
@@ -192,9 +178,9 @@
 	  (mach:unix-write (fd-stream-fd stream) base start length)
 	(cond ((eql count length)) ; Hot damn, it worked.
 	      ((not (null count))
-	       (output-later stream base (+ start count) end buffer))
+	       (output-later stream base (+ start count) end reuse-sap))
 	      ((= errno mach:ewouldblock)
-	       (output-later stream base start end buffer))
+	       (output-later stream base start end reuse-sap))
 	      (t
 	       (error "While writing ~S: ~A"
 		      stream
@@ -207,11 +193,7 @@
 (defun flush-output-buffer (stream)
   (let ((length (fd-stream-obuf-tail stream)))
     (unless (= length 0)
-      (do-output stream
-		 (fd-stream-obuf-sap stream)
-		 0
-		 length
-		 (fd-stream-obuf stream))
+      (do-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 
 ;;; DEF-OUTPUT-ROUTINES -- internal
@@ -255,46 +237,45 @@
 				      (cdr buffering)))))))
 	  bufferings)))
 
+(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
+		      1
+		      (:none base-character)
+		      (:line base-character)
+		      (:full base-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) string-char)
-		      (:line string-char)
-		      (:full (signed-byte 8) (unsigned-byte 8) string-char))
+		      (: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))))
-  (system:%primitive 8bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (fd-stream-obuf-tail stream)
-		     byte))
+  (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)))
-  (system:%primitive 16bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (/ (fd-stream-obuf-tail stream) 2)
-		     byte))
-(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
-		      4
-		      (:none (signed-byte 32))
-		      (:full (signed-byte 32)))
-  (system:%primitive signed-32bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (/ (fd-stream-obuf-tail stream) 2)
-		     byte))
-; XXX What? no unsigned-32bit-system-set?
-(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
+  (setf (sap-ref-16 (fd-stream-obuf-sap stream)
+		    (truncate (fd-stream-obuf-tail stream) 2))
+	byte))
+
+(def-output-routines ("OUTPUT-LONG-~A-BUFFERED"
 		      4
-		      (:none (unsigned-byte 31))
-		      (:full (unsigned-byte 31)))
-  (system:%primitive signed-32bit-system-set
-		     (fd-stream-obuf-sap stream)
-		     (/ (fd-stream-obuf-tail stream) 2)
-		     byte))
+		      (:none (signed-byte 32) (unsigned-byte 32))
+		      (:full (signed-byte 32) (unsigned-byte 32)))
+  (setf (sap-ref-32 (fd-stream-obuf-sap stream)
+		    (truncate (fd-stream-obuf-tail stream) 4))
+	byte))
 
 ;;; OUTPUT-RAW-BYTES -- public
 ;;;
@@ -321,11 +302,33 @@
 		     'output-raw-bytes))
 	    ((zerop bytes)) ; Easy case
 	    ((<= bytes space)
-	     (byte-blt thing start (fd-stream-obuf-sap stream) tail newtail)
+	     (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)
-	     (byte-blt thing start (fd-stream-obuf-sap stream) 0 bytes)
+	     (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)
@@ -347,31 +350,31 @@
 	(end (or end (length thing))))
     (declare (fixnum start end))
     (if (stringp thing)
-      (let ((last-newline (and (find #\newline (the simple-string thing)
-				     :start start :end end)
-			       (position #\newline (the simple-string thing)
-					    :from-end t
-					    :start start
-					    :end end))))
+	(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)
-	  (:full
+	  ((:line :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))))))
+	   (do-output stream thing start end nil))))))
 
 ;;; PICK-OUTPUT-ROUTINE -- internal
 ;;;
@@ -414,11 +417,13 @@
 	     (setf (fd-stream-ibuf-tail stream) 0))
 	    (t
 	     (decf tail head)
-	     (byte-blt ibuf-sap head ibuf-sap 0 tail)
+	     (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)
+    #+serve-event
     (multiple-value-bind
 	(count errno)
 	(mach:unix-select (1+ fd) (ash 1 fd) 0 0 0)
@@ -436,7 +441,8 @@
 			(system:int-sap (+ (system:sap-int ibuf-sap) tail))
 			(- buflen tail))
       (cond ((null count)
-	     (if (eql errno mach:ewouldblock)
+	     (if #+serve-event (eql errno mach:ewouldblock)
+		 #-serve-event nil
 	       (progn
 		 (system:wait-until-fd-usable fd :input)
 		 (do-input stream))
@@ -477,7 +483,8 @@
        (if (fd-stream-unread ,stream)
 	 (prog1
 	     (fd-stream-unread ,stream)
-	   (setf (fd-stream-unread ,stream) nil))
+	   (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)
@@ -507,13 +514,13 @@
 	   (nconc *input-routines*
 		  (list (list ',type ',name ',size))))))
 
-;;; INPUT-STRING-CHAR -- internal
+;;; INPUT-BASE-CHARACTER -- internal
 ;;;
 ;;;   Routine to use in stream-in slot for reading string chars.
 ;;;
-(def-input-routine input-string-char
-		   (string-char 1 sap head)
-  (code-char (system:%primitive 8bit-system-ref sap head)))
+(def-input-routine input-base-character
+		   (base-character 1 sap head)
+  (code-char (sap-ref-8 sap head)))
 
 ;;; INPUT-UNSIGNED-8BIT-BYTE -- internal
 ;;;
@@ -521,7 +528,7 @@
 ;;;
 (def-input-routine input-unsigned-8bit-byte
 		   ((unsigned-byte 8) 1 sap head)
-  (system:%primitive 8bit-system-ref sap head))
+  (sap-ref-8 sap head))
 
 ;;; INPUT-SIGNED-8BIT-BYTE -- internal
 ;;;
@@ -529,10 +536,7 @@
 ;;;
 (def-input-routine input-signed-8bit-number
 		   ((signed-byte 8) 1 sap head)
-  (let ((byte (system:%primitive 8bit-system-ref sap head)))
-    (if (logand byte #x80)
-      (- byte #x100)
-      byte)))
+  (signed-sap-ref-8 sap head))
 
 ;;; INPUT-UNSIGNED-16BIT-BYTE -- internal
 ;;;
@@ -540,9 +544,7 @@
 ;;;
 (def-input-routine input-unsigned-16bit-byte
 		   ((unsigned-byte 16) 2 sap head)
-  (system:%primitive 16bit-system-ref
-		     sap
-		     (/ head 2)))
+  (sap-ref-16 sap (truncate head 2)))
 
 ;;; INPUT-SIGNED-16BIT-BYTE -- internal
 ;;;
@@ -550,9 +552,7 @@
 ;;;
 (def-input-routine input-signed-16bit-byte
 		   ((signed-byte 16) 2 sap head)
-  (system:%primitive signed-16bit-system-ref
-		     sap
-		     (/ head 2)))
+  (signed-sap-ref-16 sap (truncate head 2)))
 
 ;;; INPUT-UNSIGNED-32BIT-BYTE -- internal
 ;;;
@@ -560,9 +560,7 @@
 ;;;
 (def-input-routine input-unsigned-32bit-byte
 		   ((unsigned-byte 32) 4 sap head)
-  (system:%primitive unsigned-32bit-system-ref
-		     sap
-		     (/ head 2)))
+  (sap-ref-32 sap (truncate head 4)))
 
 ;;; INPUT-SIGNED-32BIT-BYTE -- internal
 ;;;
@@ -570,9 +568,7 @@
 ;;;
 (def-input-routine input-signed-32bit-byte
 		   ((signed-byte 32) 4 sap head)
-  (system:%primitive signed-32bit-system-ref
-		     sap
-		     (/ head 2)))
+  (signed-sap-ref-32 sap (truncate head 2)))
 
 ;;; PICK-INPUT-ROUTINE -- internal
 ;;;
@@ -593,7 +589,9 @@
 (defun string-from-sap (sap start end)
   (let* ((length (- end start))
 	 (string (make-string length)))
-    (byte-blt sap start string 0 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
@@ -605,24 +603,25 @@
   (let ((eof t))
     (values
      (or (let ((sap (fd-stream-ibuf-sap stream))
-	       (results (if (fd-stream-unread stream)
-			    (prog1
-				(list (string (fd-stream-unread stream)))
-			      (setf (fd-stream-unread stream) nil)))))
+	       (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 (system:%primitive find-character
-						  sap
-						  head
-						  tail
-						  #\Newline))
+		      (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)
@@ -650,19 +649,28 @@
 	 (elsize (fd-stream-element-size stream))
 	 (offset (* elsize start))
 	 (bytes (* elsize requested))
-	 (result (catch 'eof-input-catcher
-		   (loop
-		     (input-at-least stream 1)
-		     (let* ((head (fd-stream-ibuf-head stream))
-			    (tail (fd-stream-ibuf-tail stream))
-			    (available (- tail head))
-			    (copy (min available bytes)))
-		       (byte-blt sap head buffer offset (+ offset copy))
-		       (incf (fd-stream-ibuf-head stream) copy)
-		       (incf offset copy)
-		       (decf bytes copy))
-		     (when (zerop bytes)
-		       (return requested))))))
+	 (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)))
@@ -696,12 +704,12 @@
 	(input-size nil)
 	(output-size nil))
     
-    (when (fd-stream-obuf stream)
-      (push (fd-stream-obuf stream) *available-buffers*)
-      (setf (fd-stream-obuf stream) nil))
-    (when (fd-stream-ibuf stream)
-      (push (fd-stream-ibuf stream) *available-buffers*)
-      (setf (fd-stream-ibuf stream) nil))
+    (when (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
@@ -709,14 +717,9 @@
 	  (pick-input-routine target-type)
 	(unless routine
 	  (error "Could not find any input routine for ~S" target-type))
-	(setf (fd-stream-ibuf stream)
-	      (next-available-buffer))
-	(setf (fd-stream-ibuf-sap stream)
-	      (system:alien-sap (fd-stream-ibuf stream)))
-	(setf (fd-stream-ibuf-length stream)
-	      (/ (system:alien-size (fd-stream-ibuf stream)) 8))
-	(setf (fd-stream-ibuf-tail stream)
-	      0)
+	(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
@@ -735,18 +738,15 @@
 	  (error "Could not find any output routine for ~S buffered ~S."
 		 (fd-stream-buffering stream)
 		 target-type))
-	(setf (fd-stream-obuf stream) (next-available-buffer))
-	(setf (fd-stream-obuf-sap stream)
-	      (system:alien-sap (fd-stream-obuf stream)))
-	(setf (fd-stream-obuf-length stream)
-	      (/ (system:alien-size (fd-stream-obuf stream)) 8))
+	(setf (fd-stream-obuf-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 'string-char
+		      (pick-output-routine 'base-character
 					   (fd-stream-buffering stream)))
 		    #'ill-out)
 		(fd-stream-bout stream) routine))
@@ -767,7 +767,7 @@
     (setf (fd-stream-element-type stream)
 	  (cond ((equal input-type output-type)
 		 input-type)
-		((subtypep input-type output-type)
+		((or (null output-type) (subtypep input-type output-type))
 		 input-type)
 		((subtypep output-type input-type)
 		 output-type)
@@ -795,12 +795,13 @@
 					     0
 					     0))))))
     (:unread
-     (setf (fd-stream-unread stream) arg1))
+     (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 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.
@@ -838,18 +839,19 @@
 			  stream
 			  (mach:get-unix-error-msg err)))))))
      (mach:unix-close (fd-stream-fd stream))
-     (when (fd-stream-obuf stream)
-       (push (fd-stream-obuf stream) *available-buffers*)
-       (setf (fd-stream-obuf stream) nil))
-     (when (fd-stream-ibuf stream)
-       (push (fd-stream-ibuf stream) *available-buffers*)
-       (setf (fd-stream-ibuf stream) nil))
+     (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)
     (:force-output
      (flush-output-buffer stream))
     (:finish-output
      (flush-output-buffer stream)
+     #+serve-event
      (do ()
 	 ((null (fd-stream-output-later stream)))
        (system:serve-all-events)))
@@ -928,6 +930,8 @@
 	(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 mach:l_set))
@@ -962,7 +966,7 @@
 		       &key
 		       (input nil input-p)
 		       (output nil output-p)
-		       (element-type 'string-char)
+		       (element-type 'base-character)
 		       (buffering :full)
 		       file
 		       original
@@ -1032,13 +1036,13 @@
 (defun open (filename
 	     &key
 	     (direction :input)
-	     (element-type 'string-char)
+	     (element-type 'base-character)
 	     (if-exists nil if-exists-given)
 	     (if-does-not-exist nil if-does-not-exist-given))
   "Return a stream which reads from or writes to Filename.
   Defined keywords:
    :direction - one of :input, :output, :io, or :probe
-   :element-type - Type of object to read or write, default STRING-CHAR
+   :element-type - Type of object to read or write, default BASE-CHARACTER
    :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
diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp
index 8f08bb514..4806894f7 100644
--- a/code/fdefinition.lisp
+++ b/code/fdefinition.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.1.1.2 1990/04/20 00:36:19 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.2 1990/08/24 18:10:58 wlott Exp $
 ;;;
 ;;;    Functions that hack on the global function namespace (primarily
 ;;; concerned with SETF functions here.)
diff --git a/code/filesys.lisp b/code/filesys.lisp
index 49e97c122..0f9e00828 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.3 1990/08/24 18:11:00 wlott Exp $
+;;;
 ;;; Ugly pathname functions for Spice Lisp.
 ;;;    these functions are part of the standard Spice Lisp environment.
 ;;;
@@ -42,8 +44,12 @@
   "Set to the default pathname-defaults pathname (Got that?)")
 
 (defun filesys-init ()
-  (setq *default-pathname-defaults* 
-	(%make-pathname "Mach" nil nil nil nil nil)))
+  (setq *default-pathname-defaults*
+	(%make-pathname "Mach" nil nil nil nil nil))
+  (multiple-value-bind (won dir)
+		       (mach:unix-current-directory)
+    (when won
+      (setf (search-list "default:") (list dir)))))
 
 
 ;;; The pathname type is defined with a defstruct.
@@ -316,7 +322,7 @@
 	      ((zerop q)
 	       (incf i)
 	       (replace res res :start2 i :end2 len)
-	       (%primitive shrink-vector res (- len i)))
+	       (shrink-vector res (- len i)))
 	   (declare (simple-string res)
 		    (fixnum len i r))
 	   (multiple-value-setq (q r) (truncate q 10))
@@ -1092,8 +1098,8 @@
   (multiple-value-bind (gr dir-or-error)
 		       (mach:unix-current-directory)
     (if gr
-	dir-or-error
-	(error (mach:get-unix-error-msg dir-or-error)))))
+	(pathname (concatenate 'simple-string dir-or-error "/"))
+	(error dir-or-error))))
 
 ;;;
 ;;; Maybe this shouldn't go here...
@@ -1109,5 +1115,5 @@
 		       (mach:unix-chdir (predict-name new-val nil))
     (if gr
 	(car (setf (search-list "default:")
-		   (cdr (multiple-value-list (mach:unix-current-directory)))))
+		   (list (default-directory))))
 	(error (mach:get-unix-error-msg error)))))
diff --git a/code/format.lisp b/code/format.lisp
index 31fcc893e..24cc4e19a 100644
--- a/code/format.lisp
+++ b/code/format.lisp
@@ -948,33 +948,19 @@
       (cond ((not colon)
 	     (cond (atsign
 		    (prin1 char))
-		   ((zerop (char-bits char))
-		    (write-char char))
 		   (t
 		    (format-print-named-character char nil))))
 	    (t
 	     (format-print-named-character char t))))))
 
-(defun format-print-named-character (char longp)
-  (when (char-bit char :control) 
-    (write-string (if longp "Control-" "C-")))
-  (when (char-bit char :meta)
-    (write-string (if longp "Meta-" "M-")))
-  (when (char-bit char :super)
-    (write-string (if longp "Super-" "S-")))
-  (when (char-bit char :hyper)
-    (write-string (if longp "Hyper-" "H-")))
-  (let* ((ch (code-char (char-code char)))	;strip funny bits
-	 (name (char-name ch)))
+(defun format-print-named-character (char)
+  (let* ((name (char-name char)))
     (cond (name (write-string (string-capitalize name)))
 	  ;; Print control characters as "^"<char>
 	  ((<= 0 (the fixnum (char-code char)) 31)
 	   (write-char #\^)
 	   (write-char (code-char (+ 64 (the fixnum (char-code char))))))
-	  (t (write-char ch)))))
-	  
-
-
+	  (t (write-char char)))))
 
 ;;;; NUMERIC PRINTING
 
@@ -1227,45 +1213,54 @@
 	  (format-fixed-aux number w d k ovf pad atsign)
 	  (if (rationalp number)
 	      (format-fixed-aux
-	       (coerce number 'short-float) w d k ovf pad atsign)
+	       (coerce number 'single-float) w d k ovf pad atsign)
 	      (let ((*print-base* 10))
 		(format-write-field
 		 (princ-to-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 (number w d k ovf pad atsign)
-  (if (not (or w d))
-      (prin1 number)
-      (let ((spaceleft w))
-	(when (and w (or atsign (minusp number))) (decf spaceleft))
-	(multiple-value-bind 
-          (str len lpoint tpoint)
+  (cond
+   ((not (or w d))
+    (prin1 number)
+    nil)
+   (t
+    (let ((spaceleft w))
+      (when (and w (or atsign (minusp number))) (decf spaceleft))
+      (multiple-value-bind 
+	  (str len lpoint tpoint)
 	  (flonum-to-string (abs number) spaceleft d k)
-	  ;;if caller specifically requested no fraction digits, suppress the
+	;;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 (and d (zerop d)) (setq tpoint nil))
-	  (when w 
-	    (decf spaceleft len)
-	    ;;optional leading zero
-	    (when lpoint
-	      (if (or (> spaceleft 0) tpoint) ;force at least one digit
-		  (decf spaceleft)
-		  (setq lpoint nil)))
-	    ;;optional trailing zero
-	    (when tpoint
-	      (if (> spaceleft 0)
-		  (decf spaceleft)
-		  (setq tpoint nil))))
-	  (cond ((and w (< spaceleft 0) ovf)
-		 ;;field width overflow
-		 (dotimes (i w) (write-char ovf)))
-		(t (when w (dotimes (i spaceleft) (write-char pad)))
-		   (if (minusp number)
-		       (write-char #\-)
-		       (if atsign (write-char #\+)))
-		   (when lpoint (write-char #\0))
-		   (write-string str)
-		   (when tpoint (write-char #\0))))))))
+	  (when tpoint
+	    (if (> spaceleft 0)
+		(decf spaceleft)
+		(setq tpoint nil))))
+	(cond ((and w (< spaceleft 0) ovf)
+	       ;;field width overflow
+	       (dotimes (i w) (write-char ovf))
+	       t)
+	      (t
+	       (when w (dotimes (i spaceleft) (write-char pad)))
+	       (if (minusp number)
+		   (write-char #\-)
+		   (if atsign (write-char #\+)))
+	       (when lpoint (write-char #\0))
+	       (write-string str)
+	       (when tpoint (write-char #\0))
+	       nil)))))))
 
 
 ;;;; Exponential-format floating point  ~E
@@ -1281,7 +1276,7 @@
 	  (format-exp-aux number w d e k ovf pad marker atsign)
 	  (if (rationalp number)
 	      (format-exp-aux
-	       (coerce number 'short-float) w d e k ovf pad marker atsign)
+	       (coerce number 'single-float) w d e k ovf pad marker atsign)
 	      (let ((*print-base* 10))
 		(format-write-field
 		 (princ-to-string number) w 1 0 #\space t)))))))
@@ -1289,11 +1284,11 @@
 
 (defun format-exponent-marker (number)
   (if (typep number *read-default-float-format*)
-      #\E
+      #\e
       (typecase number
-	(short-float #\S)
-;	(single-float #\F)
-	(double-float #\D)
+	(single-float #\f)
+	(double-float #\d)
+	(short-float #\s)
 	(long-float #\L))))
 
 
@@ -1356,7 +1351,7 @@
   (when colon
     (format-error "Colon flag not allowed"))
   (with-format-parameters parms
-    ((w nil) (d nil) (e nil) (k nil) (ovf #\*) (pad #\space) (marker nil))
+    ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (marker nil))
     (let ((number (pop-format-arg)))
       ;;The Excelsior edition does not say what to do if
       ;;the argument is not a float.  Here, we adopt the
@@ -1365,7 +1360,7 @@
 	  (format-general-aux number w d e k ovf pad marker atsign)
 	  (if (rationalp number)
 	      (format-general-aux
-	       (coerce number 'short-float) w d e k ovf pad marker atsign)
+	       (coerce number 'single-float) w d e k ovf pad marker atsign)
 	      (let ((*print-base* 10))
 		(format-write-field
 		 (princ-to-string number) w 1 0 #\space t)))))))
@@ -1389,10 +1384,13 @@
 	   (ww (if w (- w ee) nil))
 	   (dd (- d n)))
       (cond ((<= 0 dd d)
-	     (format-fixed-aux number ww dd nil ovf pad atsign)
-	     (dotimes (i ee) (write-char #\space)))
-	    (t (format-exp-aux 
-		 number w d e (or k 1) ovf pad marker atsign))))))
+	     (let ((char (if (format-fixed-aux number ww dd nil ovf pad
+					       atsign)
+			     ovf
+			     #\space)))
+	       (dotimes (i ee) (write-char char))))
+	    (t
+	     (format-exp-aux number w d e (or k 1) ovf pad marker atsign))))))
 
 
 ;;; Dollars floating-point format  ~$
@@ -1400,7 +1398,7 @@
 (defun format-dollars (colon atsign parms)
   (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
     (let ((number (pop-format-arg)))
-      (if (rationalp number) (setq number (coerce number 'short-float)))
+      (if (rationalp number) (setq number (coerce number 'single-float)))
       (if (floatp number)
 	  (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
 		 (signlen (length signstr)))
@@ -1416,39 +1414,6 @@
 	  (let ((*print-base* 10))
 	    (format-write-field (princ-to-string number) w 1 0 #\space t))))))
 
-
-;;;; Some stuff for Compiler, MACLISP interaction.
-
-;;; The following crock simulates some Common Lisp functions in the
-;;; cross-compiler's MACLISP environment for the benefit of the hairy
-;;; dispatch-table initialization macro. The internal representation
-;;; of character objects in the compiler is known to this code.  
-
-#|
-(eval-when (compile-maclisp)
-
-  (setq char-code-limit 256)
-
-  (defun char-downcase (char)
-    (let ((ch (cadr char)))
-      (if (lessp 64 ch 91) (list '**character** (+ ch 32)) char)))
-
-  (defun char-upcase (char)
-    (let ((ch (cadr char)))
-      (if (lessp 96 ch 123) (list '**character** (- ch 32)) char)))
-
-  (defun char= (a b)
-    (= (cadr a) (cadr b)))
-
-  (defun char< (a b)
-    (< (cadr a) (cadr b)))
-
-  (defun char-code (char)
-    (cadr char))
-
-  (defun code-char (code)
-    (list '**character** code)))
-|#
 
 ;;;; INITIALIZATION
 
diff --git a/code/gc.lisp b/code/gc.lisp
index 9622aaf35..575c5b873 100644
--- a/code/gc.lisp
+++ b/code/gc.lisp
@@ -8,9 +8,12 @@
 ;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.4 1990/08/24 18:11:14 wlott Exp $
+;;; 
 ;;; Garbage collection and allocation related code.
 ;;;
 ;;; Written by Christopher Hoover, Rob MacLachlan, Dave McDonald, et al.
+;;; New code for MIPS port by Christopher Hoover.
 ;;; 
 
 (in-package "EXTENSIONS")
@@ -21,91 +24,90 @@
 (in-package "LISP")
 (export '(room))
 
-
 
-;;;; Room.
+;;;; DYNAMIC-USAGE and friends.
+
+(proclaim '(special *read-only-space-free-pointer*
+		    *static-space-free-pointer*))
+
+(macrolet ((frob (lisp-fun c-var-name)
+	     `(progn
+		(def-c-variable ,c-var-name (unsigned-byte 32))
+		(defun ,lisp-fun ()
+		  (system:alien-access ,(intern (string-upcase c-var-name)))))))
+  (frob read-only-space-start "read_only_space")
+  (frob static-space-start "static_space")
+  (frob dynamic-0-space-start "dynamic_0_space")
+  (frob dynamic-1-space-start "dynamic_1_space")
+  (frob control-stack-start "control_stack")
+  (frob binding-stack-start "binding_stack")
+  (frob current-dynamic-space-start "current_dynamic_space"))
 
-(defvar alloctable-address (int-sap %fixnum-alloctable-address)
-  "A system area pointer that addresses the the alloctable.")
+(defun dynamic-usage ()
+  (- (system:sap-int (c::dynamic-space-free-pointer))
+     (current-dynamic-space-start)))
 
-(defun alloc-ref (index)
-  (logior (%primitive 16bit-system-ref alloctable-address (1+ index))
-	  (ash (logand %type-space-mask
-		       (%primitive 16bit-system-ref alloctable-address index))
-	       16)))
+(defun static-space-usage ()
+  (- (* lisp::*static-space-free-pointer* vm:word-bytes)
+     (static-space-start)))
 
-(defun space-usage (type)
-  (let ((base (ash type %alloc-ref-type-shift)))
-    (values (alloc-ref base)
-	    (alloc-ref (+ base 8))
-	    (alloc-ref (+ base 12)))))
+(defun read-only-space-usage ()
+  (- (* lisp::*read-only-space-free-pointer* vm:word-bytes)
+     (read-only-space-start)))
 
-(defconstant type-space-names
-  '#("Bignum" "Ratio" "Complex" "Short-Float" "Short-Float" "Long-Float"
-     "String" "Bit-Vector" "Integer-Vector" "Code-Vector" "General-Vector"
-     "Array" "Function" "Symbol" "List"))
+(defun control-stack-usage ()
+  (- (system:sap-int (c::control-stack-pointer-sap)) (control-stack-start)))
+
+(defun binding-stack-usage ()
+  (- (system:sap-int (c::binding-stack-pointer-sap)) (binding-stack-start)))
 
-(defun room-header ()
-  (fresh-line)
-  (princ "       Type        |  Dynamic  |   Static  | Read-Only |   Total")
-  (terpri)
-  (princ "-------------------|-----------|-----------|-----------|-----------")
-  (terpri))
-
-(defun room-summary (dynamic static read-only)
-  (princ "-------------------|-----------|-----------|-----------|-----------")
-  (format t "~% Totals:           |~10:D |~10:D |~10:D =~10:D~%" 
-	  dynamic static read-only (+ static dynamic read-only)))
-
-(defun describe-one-type (type dynamic static read-only)
-  (declare (fixnum type dynamic static read-only))
-  (format t "~18A |~10:D |~10:D |~10:D |~10:D~%"
-	  (elt (the simple-vector type-space-names)
-	       (the fixnum (- type (the fixnum %first-pointer-type))))
-	  dynamic static read-only (the fixnum (+ static dynamic read-only))))
-
-(defun room (&optional (x t) (object nil argp))
-  "Displays information about storage allocation.
-  If X is true then information is displayed broken down by types.
-  If Object is supplied then just display information for objects of
-  that type."
-  (when x
-    (let ((type (%primitive get-type object)))
-      (when (or (> type %last-pointer-type)
-		(< type %first-pointer-type))
-	(error "Objects of type ~S have no allocated storage."
-	       (type-of object)))
-      (room-header)
-      (cond
-       (argp
-	(multiple-value-bind (dyn stat ro)
-			     (space-usage type)
-	  (describe-one-type type dyn stat ro)))
-       (t
-        (let ((cum-dyn 0)
-	      (cum-stat 0)
-	      (cum-ro 0))
-	  (do ((type %first-pointer-type (1+ type)))
-	      ((= type (1+ %last-pointer-type)))
-	    (if (not (or (eq type %short-+-float-type)
-			 (eq type %short---float-type)))
-		(multiple-value-bind (dyn stat ro)
-				     (space-usage type)
-		  (describe-one-type type dyn stat ro)
-		  (incf cum-dyn dyn) (incf cum-stat stat) (incf cum-ro ro))))
-	  (room-summary cum-dyn cum-stat cum-ro)))))))
+
+(defun current-dynamic-space ()
+  (let ((start (current-dynamic-space-start)))
+    (cond ((= start (dynamic-0-space-start))
+	   0)
+	  ((= start (dynamic-1-space-start))
+	   1)
+	  (t
+	   (error "Oh no.  The current dynamic space is missing!")))))
 
 
-;;;; DYNAMIC-USAGE.
+;;;; Room.
 
-;;; 
-;;; DYNAMIC-USAGE -- Interface
-;;;
-;;; Return the number of bytes of dynamic storage allocated.
-;;;
-(defun dynamic-usage ()
-  "Returns the number of bytes of dynamic storage currently allocated."
-  (system:%primitive dynamic-space-in-use))
+(defun room-maximal-info ()
+  (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
+  (format t "Dynamic Space Usage:    ~10:D bytes.~%" (dynamic-usage))
+  (format t "Read-Only Space Usage:  ~10:D bytes.~%" (read-only-space-usage))
+  (format t "Static Space Usage:     ~10:D bytes.~%" (static-space-usage))
+  (format t "Control Stack Usage:    ~10:D bytes.~%" (control-stack-usage))
+  (format t "Binding Stack Usage:    ~10:D bytes.~%" (binding-stack-usage)))
+
+(defun room-minimal-info ()
+  (format t "Dynamic Space Usage:    ~10:D bytes.~%" (dynamic-usage)))
+
+(defun room-intermediate-info ()
+  (format t "Dynamic Space Usage:   ~10:D bytes.~%" (dynamic-usage))
+  (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
+  (format t "Static Space Usage:    ~10:D bytes.~%" (static-space-usage)))
+
+(defun room (&optional (verbosity :default))
+  "Prints to *STANDARD-OUTPUT* information about the state of internal
+  storage and its management.  The optional argument controls the
+  verbosity of ROOM.  If it is T, ROOM prints out a maximal amount of
+  information.  If it is NIL, ROOM prints out a minimal amount of
+  information.  If it is :DEFAULT or it is not supplied, ROOM prints out
+  an intermediate amount of information."
+  (fresh-line)
+  (case verbosity
+    ((t)
+     (room-maximal-info))
+    ((nil)
+     (room-minimal-info))
+    (:default
+     (room-intermediate-info))
+    (t
+     (error "No way man!  The optional argument to ROOM must be T, NIL, ~
+     or :DEFAULT.~%What do you think you are doing?"))))
 
 
 ;;;; GET-BYTES-CONSED.
@@ -130,7 +132,7 @@
 	   (incf *total-bytes-consed* (- bytes *last-bytes-in-use*))
 	   (setq *last-bytes-in-use* bytes))))
   *total-bytes-consed*)
-    
+
 
 ;;;; Variables and Constants.
 
@@ -153,7 +155,6 @@
 (defvar *gc-trigger* default-bytes-consed-between-gcs)
 
 
-
 ;;;
 ;;; The following specials are used to control when garbage collection
 ;;; occurs.
@@ -249,251 +250,19 @@
   threshold.  The function should notify the user that the system has
   finished GC'ing.")
 
-
-;;;; Stack grovelling:
-
-;;; VECTOR-ALLOC-END  --  Internal
-;;;
-;;;    Return a pointer to past the end of the memory allocated for a
-;;; vector-like object.
-;;;
-(defun vector-alloc-end (vec)
-  (%primitive pointer+
-	      vec
-	      (* (%primitive vector-word-length vec) %word-size)))
-
-
-(defvar *gc-debug* nil)
-
-;;; PRINT-RAW-ADDR  --  Interface
-;;;
-;;;    Print the full address of an arbitary object.
-;;;
-(defun print-raw-addr (x &optional (stream *standard-output*))
-  (let ((fix (%primitive make-fixnum x)))
-    (format stream "~4,'0X~4,'0X "
-	    (logior (ash (%primitive get-type x) 11)
-		    (ash (%primitive get-space x) 9)
-		    (ash fix -16))
-	    (logand fix #xFFFF))))
-
-
-;;; GC-GROVEL-STACK  --  Internal
-;;;
-;;;    Locate all raw pointers on stack stack, and clobber them with something
-;;; that won't cause GC to gag.  We return a list of lists of the form:
-;;;    (object offset stack-location*),
-;;; 
-;;; where Object is some valid vector-like object pointer and Offset is an
-;;; offset to be added to Object.  The result of this addition should be stored
-;;; into each Stack-Location after GC completes.  We clobber the stack
-;;; locations with Offset for no particular reason (might aid debugging.)
-;;;
-;;; There are three major steps in the algorithm:
-;;;
-;;;  1] Find all the distinct vector-like pointers on the stack, building a
-;;;     list of all the locations that each pointer is stored in.  We do this
-;;;     using two hash-tables: the one for code pointers is separate, since
-;;;     they must be special-cased.
-;;;
-;;;     Note that we do our scan downward from the current CONT, and thus don't
-;;;     scan our own frame.  We don't want to modify the frame for the running
-;;;     function, as this is apt to cause problems.  It isn't necessary to
-;;;     grovel the current frame because we return before GC happens.
-;;;
-;;;  2] Sort all of the vector-like pointers (other than code vectors), and
-;;;     scan through this list finding raw pointers based on the assumption
-;;;     that we will always see the true pointer to the vector header before
-;;;     any raw pointers into that vector.  This exploits our GC invariant that
-;;;     when an indexing temp is in use, the true object pointer must be live
-;;;     on the stack or in a register.  [By now, any register indexing temp
-;;;     will have been saved on the stack.]
-;;;
-;;;     During this scan, we also note any true vector pointers that point to a
-;;;     function object.
-;;;
-;;;     Whenever we locate a raw vector pointer, we create a fixup for the
-;;;     locations holding that pointer and then clobber the locations.
-;;;
-;;;  3] Iterate over all code pointers, clobbering the locations and
-;;;     making fixups for those pointers that point inside some function object
-;;;     that appears on the stack.  This exploits our GC invariant that a
-;;;     *valid* code pointer only appears on the stack when some containing
-;;;     function object also appears on the stack.  Note that *invalid* code
-;;;     pointers may appear in the stack garbage unaccompanied by any function
-;;;     object.  Such isolated code pointers are set to 0.  (Code pointers in
-;;;     the heap must always point to the code vector header, and are always
-;;;     considered valid.)
-;;;
-;;;     This different invariant for code pointers allows us to throw around
-;;;     raw code pointers without clearing them when they are no longer needed.
-;;;
-(defun gc-grovel-stack ()
-  (let ((vec-table (make-hash-table :test #'eq))
-	(code-table (make-hash-table :test #'eq))
-	(base (%primitive make-immediate-type 0 %control-stack-type))
-	(fixups ()))
-    ;;
-    ;; Find all vector-like objects on the stack, putting code vectors in a
-    ;; separate table. (step 1)
-    (do ((sp (%primitive pointer+ (%primitive current-fp)
-			 (- %stack-increment))
-	     (%primitive pointer+ sp (- %stack-increment))))
-	((%primitive pointer< sp base))
-      (let* ((el (%primitive read-control-stack sp))
-	     (el-type (%primitive get-type el)))
-	
-	(when (and *gc-debug* (simple-vector-p el))
-	  (let ((hdr (%primitive read-control-stack el)))
-	    (unless (and (fixnump hdr) (> hdr 0)
-			 (<= (length el) #xFFFF)
-			 (<= (%primitive get-vector-subtype el)
-			     3))
-	      (format t "Suspicious G-vector ")
-	      (print-raw-addr el)
-	      (format t "at ")
-	      (print-raw-addr sp)
-	      (terpri))))
-
-	(when (and (< (%primitive get-space el) %static-space)
-		   (<= %string-type el-type %function-type))
-	  (push sp (gethash el
-			    (if (eq el-type %code-type)
-				code-table
-				vec-table))))))
-
-    (let ((vecs ())
-	  (functions ()))
-      (maphash #'(lambda (k v)
-		   (declare (ignore v))
-		   (push k vecs))
-	       vec-table)
-
-      (setq vecs
-	    (sort vecs
-		  #'(lambda (x y)
-		      (%primitive pointer< x y))))
-
-      ;;
-      ;; Iterate over non-code vector-like pointers in order (step 2.)
-      (loop
-	(unless vecs (return))
-	(let* ((base (pop vecs))
-	       (end (vector-alloc-end base)))
-	  
-	  (when (and (= (%primitive get-type base) %function-type)
-		     (<= %function-entry-subtype
-			 (%primitive get-vector-subtype base)
-			 %function-constants-subtype))
-	    (push base functions))
-
-	  (loop
-	    (unless vecs (return))
-	    (let ((next (first vecs)))
-	      (unless (%primitive pointer< next end) (return))
-	      (pop vecs)
-	      
-	      (let ((offset (%primitive pointer- next base))
-		    (sps (gethash next vec-table)))
-		(dolist (sp sps)
-		  (%primitive write-control-stack sp offset))
-		(push (list* base offset sps) fixups))))))
-
-      ;;
-      ;; Iterate over all code pointers (step 3.)
-      (maphash #'(lambda (code-ptr sps)
-		   (dolist (fun functions
-				(dolist (sp sps)
-				  (%primitive write-control-stack sp 0)))
-		     (let* ((base (%primitive header-ref fun
-					      %function-code-slot))
-			    (end (vector-alloc-end base)))
-		       (when (and (not (%primitive pointer< code-ptr base))
-				  (%primitive pointer< code-ptr end))
-			 (let ((offset (%primitive pointer- code-ptr base)))
-			   (dolist (sp sps)
-			     (%primitive write-control-stack sp offset))
-			   (push (list* base offset sps) fixups))
-			 (return)))))
-	       code-table)
-
-      (when *gc-debug*
-	(dolist (f fixups)
-	  (terpri)
-	  (print-raw-addr (first f))
-	  (format t "~X " (second f))
-	  (dolist (sp (cddr f))
-	    (print-raw-addr sp)))
-	(terpri))
-
-      fixups)))
-
-
-;;; GC-FIXUP-STACK  --  Internal
-;;;
-;;;    Given a list of GC fixups as returned by GC-GROVEL-STACK, fix up all the
-;;; raw pointers on the stack.
-;;;
-(defun gc-fixup-stack (fixups)
-  (dolist (fixup fixups)
-    (let ((new (%primitive pointer+ (first fixup) (second fixup))))
-      (dolist (sp (cddr fixup))
-	(%primitive write-control-stack sp new)))))
-
 
 ;;;; Internal GC
 
-;;; %GC  --  Internal
-;;;
-;;; %GC is the real garbage collector.  What we do:
-;;;  -- Call GC-GROVEL-STACK to locate any raw pointers on the stack.
-;;;  -- Invoke the COLLECT-GARBAGE miscop, adding the amount of garbage
-;;;     collected to *total-bytes-consed*.
-;;;  -- Invalidate & revalidate the old spaces to free up their memory.
-;;;  -- Call GC-FIXUP-STACK to restore raw pointers on the stack.
-;;;
-;;; *** Warning: the stack *including the current frame* is in a somewhat
-;;; altered state until after GC-FIXUP-STACK is called.  Don't change a single
-;;; character from the start of this function until after call to
-;;; GC-FIXUP-STACK unless you really know what you are doing.
-;;;
-;;; It is important that we not do anything that creates raw pointers between
-;;; the time we call GC-GROVEL-STACK and the time we invoke COLLECT-GARBAGE.
-;;; In particular, this means no function calls.  All raw pointers on the stack
-;;; have been trashed, so we cannot use any raw pointers until they have been
-;;; regenerated.  In particular, we cannot return from this function, since the
-;;; return PC is a raw pointer.
-;;;
-;;; We also can't expect the value of any variables allocated between the
-;;; grovel and fixup to persist after the fixup, since the value that variable
-;;; held at grovel time may have been a pointer that needed to be fixed.
-;;;
+(def-c-routine ("collect_garbage" collect-garbage) (int))
+
 (defun %gc ()
-  (let* ((oldspace-base (ash (%primitive newspace-bit) 25))
-	 (old-bytes (system:%primitive dynamic-space-in-use))
-	 (result nil)
-	 (fixups (gc-grovel-stack)))
-    (%primitive clear-registers)
-    (setq result (%primitive collect-garbage))
-    (let ((new-bytes (system:%primitive dynamic-space-in-use)))
+  (let ((old-usage (dynamic-usage)))
+    (collect-garbage)
+    (let ((new-bytes (dynamic-usage)))
       (when *last-bytes-in-use*
-	(incf *total-bytes-consed* (- old-bytes *last-bytes-in-use*))
-	(setq *last-bytes-in-use* new-bytes)))
-    (gc-fixup-stack fixups)
-    (do* ((i %first-pointer-type (1+ i))
-	  (this-space (logior oldspace-base (ash i 27))
-		      (logior oldspace-base (ash i 27)))
-	  (losing-gr nil))
-	 ((= i (1+ %last-pointer-type))
-	  (when losing-gr
-	    (system:gr-error "While reclaiming VM" losing-gr)))
-      (let ((gr (mach:vm_deallocate *task-self* this-space
-				    (- #x2000000 8192))))
-	(unless (eql gr mach:kern-success) (setq losing-gr gr)))
-      (let ((gr (mach:vm_allocate *task-self* this-space
-				  (- #x2000000 8192) nil)))
-	(unless (eql gr mach:kern-success) (setq losing-gr gr))))
-    result))
+	(incf *total-bytes-consed* (- old-usage *last-bytes-in-use*))
+	(setq *last-bytes-in-use* new-bytes)))))
+
 
 ;;;
 ;;; *INTERNAL-GC*
@@ -546,32 +315,23 @@
 		   (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
 	  (return-from sub-gc nil))
 	(setf *gc-inhibit* nil) ; Reset *GC-INHIBIT*
-	(multiple-value-bind
-	    (winp old-mask)
-	    (mach:unix-sigsetmask lockout-interrupts)
-	  (unwind-protect
-	      (progn
-		(unless winp (warn "Could not set sigmask!"))
-		(let ((*standard-output* *terminal-io*))
-		  (when verbose-p
-		    (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
-		  (dolist (hook *before-gc-hooks*)
-		    (carefully-funcall hook))
-		  (funcall *internal-gc*)
-		  (let* ((post-gc-dyn-usage (dynamic-usage))
-			 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
-		    (setf *need-to-collect-garbage* nil)
-		    (setf *gc-trigger*
-			  (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
-		    (dolist (hook *after-gc-hooks*)
-		      (carefully-funcall hook))
-		    (when verbose-p
-		      (carefully-funcall *gc-notify-after*
-					 post-gc-dyn-usage bytes-freed
-					 *gc-trigger*)))))
-	    (when winp
-	      (unless (values (mach:unix-sigsetmask old-mask))
-		(warn "Could not restore sigmask!"))))))))
+	(let ((*standard-output* *terminal-io*))
+	  (when verbose-p
+	    (carefully-funcall *gc-notify-before* pre-gc-dyn-usage))
+	  (dolist (hook *before-gc-hooks*)
+	    (carefully-funcall hook))
+	  (funcall *internal-gc*)
+	  (let* ((post-gc-dyn-usage (dynamic-usage))
+		 (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
+	    (setf *need-to-collect-garbage* nil)
+	    (setf *gc-trigger*
+		  (+ post-gc-dyn-usage *bytes-consed-between-gcs*))
+	    (dolist (hook *after-gc-hooks*)
+	      (carefully-funcall hook))
+	    (when verbose-p
+	      (carefully-funcall *gc-notify-after*
+				 post-gc-dyn-usage bytes-freed
+				 *gc-trigger*)))))))
   nil)
 
 ;;;
@@ -581,7 +341,7 @@
 ;;; should occur.  The argument, object, is the newly allocated object
 ;;; which must be returned to the caller.
 ;;; 
-(defun maybe-gc (object)
+(defun maybe-gc (&optional object)
   (sub-gc *gc-verbose* nil)
   object)
 
diff --git a/code/lispinit.lisp b/code/lispinit.lisp
index eaebaea58..6b1a18a99 100644
--- a/code/lispinit.lisp
+++ b/code/lispinit.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.10 1990/08/24 18:11:26 wlott Exp $
+;;;
 ;;; Initialization and low-level interrupt support for the Spice Lisp system.
 ;;; Written by Skef Wholey and Rob MacLachlan.
 ;;;
@@ -37,49 +39,53 @@
 	  default-interrupt))
 
 (in-package "EXTENSIONS")
-(export '(quit *prompt* print-herald save-lisp gc-on gc-off
-	       *before-save-initializations* *after-save-initializations*
-	       *editor-lisp-p* *clx-server-displays*))
+(export '(quit *prompt* save-lisp gc-on gc-off *clx-server-displays*))
 
 (in-package "LISP")
 
-;;; These go here so that we can refer to them in top-level forms.
-
-(defvar *before-save-initializations* ()
-  "This is a list of functions which are called before creating a saved core
-  image.  These functions are executed in the child process which has no ports,
-  so they cannot do anything that tries to talk to the outside world.")
-
-(defvar *after-save-initializations* ()
-  "This is a list of functions which are called when a saved core image starts
-  up.  The system itself should be initialized at this point, but applications
-  might not be.")
-
 ;;; Make the error system enable interrupts.
 
-(defconstant most-positive-fixnum 134217727
+(defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
   "The fixnum closest in value to positive infinity.")
 
-(defconstant most-negative-fixnum -134217728
+(defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
   "The fixnum closest in value to negative infinity.")
 
 
 ;;; Random information:
 
 (defvar compiler-version "???")
-(defvar *lisp-implementation-version* "3.0(?)")
+(defvar *lisp-implementation-version* "4.0(?)")
 
-(defvar *in-the-compiler* ()
+(defvar *in-the-compiler* nil
   "Bound to T while running code inside the compiler.  Macros may test this to
   see where they are being expanded.")
 
-(defparameter %fasl-code-format 6)
+(defparameter %fasl-code-format #.vm:target-fasl-code-format)
 
 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
 (proclaim '(special *gc-inhibit* *already-maybe-gcing*
 		    *need-to-collect-garbage* *gc-verbose*
 		    *before-gc-hooks* *after-gc-hooks*
 		    c::*type-system-initialized*))
+
+
+;;;; Random magic specials.
+
+
+;;; These are filled in by Genesis.
+
+(defvar *the-undefined-function*)
+(defvar *current-catch-block*)
+(defvar *current-unwind-block*)
+(defvar *free-interrupt-context-index*)
+
+
+;;;
+
+(defvar %sp-interrupts-inhibited nil)
+
+
 
 ;;;; Global ports:
  
@@ -92,293 +98,6 @@
 (defvar *nameserverport* ()
   "Port to the name server.")
 
-
-;;; Software interrupt stuff.
-
-(defvar *in-server* NIL
-  "*In-server* is set to T when the SIGMSG interrupt has been enabled
-  in Server.")
-
-(defvar server-unique-object (cons 1 2))
-
-(defconstant lockout-interrupts (logior (mach:sigmask :sigint)
-					(mach:sigmask :sigquit)
-					(mach:sigmask :sigfpe)
-					(mach:sigmask :sigsys)
-					(mach:sigmask :sigpipe)
-					(mach:sigmask :sigalrm)
-					(mach:sigmask :sigurg)
-					(mach:sigmask :sigstop)
-					(mach:sigmask :sigtstp)
-					(mach:sigmask :sigcont)
-					(mach:sigmask :sigchld)
-					(mach:sigmask :sigttin)
-					(mach:sigmask :sigttou)
-					(mach:sigmask :sigio)
-					(mach:sigmask :sigxcpu)
-					(mach:sigmask :sigxfsz)
-					(mach:sigmask :sigvtalrm)
-					(mach:sigmask :sigprof)
-					(mach:sigmask :sigwinch)
-					(mach:sigmask :sigmsg)
-					(mach:sigmask :sigemsg)))
-
-(defconstant interrupt-stack-size 4096
-  "Size of stack for Unix interrupts.")
-
-(defvar software-interrupt-stack NIL
-  "Address of the stack used by Mach to send signals to Lisp.")
-
-(defvar %sp-interrupts-inhibited nil
-  "True if emergency message interrupts should be inhibited, false otherwise.")
-
-(defvar *software-interrupt-vector*
-  (make-array mach::maximum-interrupts)
-  "A vector that associates Lisp functions with Unix interrupts.")
-
-(defun enable-interrupt (interrupt function &optional character)
-  "Enable one Unix interrupt and associate a Lisp function with it.
-  Interrupt should be the number of the interrupt to enable.  Function
-  should be a funcallable object that will be called with three
-  arguments: the signal code, a subcode, and the context of the
-  interrupt.  The optional character should be an ascii character or
-  an integer that causes the interrupt from the keyboard.  This argument
-  is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored
-  for any others.  Returns the old function associated with the interrupt
-  and the character that generates it if the interrupt is one of SIGINT,
-  SIGQUIT, SIGTSTP and character was specified."
-  (unless (< 0 interrupt mach::maximum-interrupts)
-    (error "Interrupt number ~D is not between 1 and ~D."
-	   mach::maximum-interrupts))
-  (let ((old-fun (svref *software-interrupt-vector* interrupt))
-	(old-char ()))
-    (when (and character
-	       (or (eq interrupt mach:sigint)
-		   (eq interrupt mach:sigquit)
-		   (eq interrupt mach:sigtstp)))
-      (when (characterp character)
-	(setq character (char-code character)))
-      (when (mach:unix-isatty 0)
-	(if (or (eq interrupt mach:sigint)
-		(eq interrupt mach:sigquit))
-	    (mach:with-trap-arg-block mach:tchars tc
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:TIOCGETC
-				   (alien-value-sap mach:tchars))
-		(if (null val)
-		    (error "Failed to get tchars information, unix error ~S."
-			   (mach:get-unix-error-msg err))))
-	      (cond ((eq interrupt mach:sigint)
-		     (setq old-char
-			   (alien-access (mach::tchars-intrc (alien-value tc))))
-		     (setf (alien-access (mach::tchars-intrc (alien-value tc)))
-			   character))
-		    (T
-		     (setq old-char
-			   (alien-access (mach::tchars-quitc (alien-value tc))))
-		     (setf (alien-access (mach::tchars-quitc (alien-value tc)))
-			   character)))
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:tiocsetc
-				   (alien-value-sap mach:tchars))
-		(if (null val)
-		    (error "Failed to set tchars information, unix error ~S."
-			   (mach:get-unix-error-msg err)))))
-	    (mach:with-trap-arg-block mach:ltchars tc
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:TIOCGLTC
-				   (alien-value-sap mach:ltchars))
-		(if (null val)
-		    (error "Failed to get ltchars information, unix error ~S."
-			   (mach:get-unix-error-msg err))))
-	      (setq old-char
-		    (alien-access (mach::ltchars-suspc (alien-value tc))))
-	      (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
-		    character)
-	      (multiple-value-bind
-		  (val err)
-		  (mach:unix-ioctl 0 mach:TIOCSLTC
-				   (alien-value-sap mach:ltchars))
-		(if (null val)
-		    (error "Failed to set ltchars information, unix error ~S."
-			   (mach:get-unix-error-msg err))))))))
-    (setf (svref *software-interrupt-vector* interrupt) function)
-    (if (null function)
-	(mach:unix-sigvec interrupt mach:sig_dfl 0 0)
-	(let ((diha (+ (ash clc::romp-data-base 16)
-		       clc::software-interrupt-offset)))
-	  (mach:unix-sigvec interrupt diha lockout-interrupts 1)))
-    (if old-char
-	(values old-fun old-char)
-	old-fun)))
-
-(defun ignore-interrupt (interrupt)
-  "The Unix interrupt handling mechanism is set up so that interrupt is
-  ignored."
-  (unless (< 0 interrupt mach::maximum-interrupts)
-    (error "Interrupt number ~D is not between 1 and 31."))
-  (let ((old-fun (svref *software-interrupt-vector* interrupt)))
-    (mach:unix-sigvec interrupt mach:sig_ign 0 0)
-    (setf (svref *software-interrupt-vector* interrupt) NIL)
-    old-fun))
-
-(defun default-interrupt (interrupt)
-  "The Unix interrupt handling mechanism is set up to do the default action
-  under mach.  Lisp will not get control of the interrupt."
-  (unless (< 0 interrupt mach::maximum-interrupts)
-    (error "Interrupt number ~D is not between 1 and 31."))
-  (let ((old-fun (svref *software-interrupt-vector* interrupt)))
-    (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
-    (setf (svref *software-interrupt-vector* interrupt) NIL)
-    old-fun))
-
-
-;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix
-;;; signal arrives.  The three arguments correspond to the information
-;;; passed to a normal Unix signal handler, i.e.:
-;;;	signal -- the Unix signal number.
-;;;	code -- a code for those signals which can be caused by more
-;;;		than one kind of event.  This code specifies the sub-event.
-;;;	scp -- a pointer to the context of the signal.
-
-;;; Because of the way %sp-software-interrupt-handler returns, it doesn't
-;;; unwind the binding stack properly.  The only variable affected by this
-;;; is software-interrupt-stack, so it must be handled specially.
-
-(defun %sp-software-interrupt-handler (signal code scp stack)
-  (declare (optimize (speed 3) (safety 0)))
-  (if (and %sp-interrupts-inhibited
-	   (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv))))
-      (progn
-	(let ((iin %sp-interrupts-inhibited))
-	  (setq %sp-interrupts-inhibited
-		(nconc (if (consp iin) iin)
-		       (list `(,signal ,code ,scp))))
-	  (mach:unix-sigsetmask 0)))
-      (let* ((old-stack software-interrupt-stack)
-	     (new-stack ())
-	     (%sp-interrupts-inhibited T))
-	(unwind-protect
-	    (progn
-	      (when *in-server*
-		(mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0))
-	      (multiple-value-bind (gr addr)
-				   (mach:vm_allocate *task-self* 0
-						     interrupt-stack-size t)
-		(gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler)
-		(setq software-interrupt-stack
-		      (int-sap (+ addr interrupt-stack-size))))
-	      (setq new-stack software-interrupt-stack)
-	      (mach:unix-sigstack new-stack 0)
-	      (mach:unix-sigsetmask 0)
-	      (funcall (svref *software-interrupt-vector* signal)
-		       signal code scp)
-	      (mach:unix-sigsetmask lockout-interrupts))
-	  (mach:vm_deallocate *task-self*
-			      (- (sap-int new-stack)
-				 interrupt-stack-size)
-			      interrupt-stack-size)
-	  (setq software-interrupt-stack old-stack)
-	  (mach:unix-sigstack old-stack 0)
-	  (when *in-server*
-	    (let ((diha (+ (ash clc::romp-data-base 16)
-			   clc::software-interrupt-offset)))
-	      (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1)))
-	  (mach:unix-sigsetmask 0))))
-  (%primitive break-return stack))
-
-
-(defun ih-sigint (signal code scp)
-  (declare (ignore signal code scp))
-  (without-hemlock
-   (with-interrupts
-    (break "Software Interrupt" t))))
-
-(defun ih-sigquit (signal code scp)
-  (declare (ignore signal code scp))
-  (throw 'top-level-catcher nil))
-
-(defun ih-sigtstp (signal code scp)
-  (declare (ignore signal code scp))
-  (without-hemlock
-;   (reset-keyboard 0)
-   (mach:unix-kill (mach:unix-getpid) mach:sigstop)))
-
-(defun ih-sigill (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (error "Illegal instruction encountered at IAR ~X."
-	   (alien-access (mach::sigcontext-iar (alien-value context))))))
-
-(defun ih-sigbus (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (with-interrupts
-     (error "Bus error encountered at IAR ~X."
-	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
-
-(defun ih-sigsegv (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (with-interrupts
-     (error "Segment violation encountered at IAR ~X."
-	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
-
-(defun ih-sigfpe (signal code scp)
-  (declare (ignore signal code))
-  (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
-					  'mach:sigcontext)
-			mach:sigcontext T))
-    (with-interrupts
-     (error "Floating point exception encountered at IAR ~X."
-	    (alien-access (mach::sigcontext-iar (alien-value context)))))))
-
-;;; When we're in server then throw back to server.  If we're not
-;;; in server then just ignore the sigmsg interrupt.  We can't handle
-;;; it and we should never get it anyway.  But of course we do -- it's
-;;; dealing with interrupts and there funny at best.
-(defun ih-sigmsg (signal code scp)
-  (declare (ignore signal code scp))
-  (mach:unix-sigsetmask (mach:sigmask :sigmsg))
-  (default-interrupt mach:sigmsg)
-  (when *in-server*
-    (setq *in-server* nil)
-    (throw 'server-catch server-unique-object)))
-
-(defun ih-sigemsg (signal code scp)
-  (declare (ignore signal code scp))
-  (service-emergency-message-interrupt))
-
-(defun init-mach-signals ()
-  (declare (optimize (speed 3) (safety 0)))
-  (multiple-value-bind (gr addr)
-		       (mach:vm_allocate *task-self* 0 interrupt-stack-size t)
-    (gr-error 'mach:vm_allocate gr 'enable-interrupt)
-    (setq software-interrupt-stack
-	  (int-sap (+ addr interrupt-stack-size))))
-  (let ((iha (get 'clc::interrupt-handler '%loaded-address))
-	(diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset)))
-    (%primitive pointer-system-set diha 0 iha))
-  (mach:unix-sigstack software-interrupt-stack 0)
-  (enable-interrupt mach:sigint #'ih-sigint)
-  (enable-interrupt mach:sigquit #'ih-sigquit)
-  (enable-interrupt mach:sigtstp #'ih-sigtstp)
-  (enable-interrupt mach:sigill #'ih-sigill)
-  (enable-interrupt mach:sigbus #'ih-sigbus)
-  (enable-interrupt mach:sigsegv #'ih-sigsegv)
-  (enable-interrupt mach:sigemsg #'ih-sigemsg)
-  (enable-interrupt mach:sigfpe #'ih-sigfpe)
-;  (reset-keyboard 0)
-  )
 
 
 ;;;; Reply port allocation.
@@ -386,6 +105,9 @@
 ;;;    We maintain a global stack of reply ports which is shared among
 ;;; all matchmaker interfaces, and could be used by other people as well.
 ;;;
+
+#| More stuff that will probably be drastically different.
+
 ;;;    The stack is represented by a vector, and a pointer to the first
 ;;; free port.  The stack grows upward.  There is always at least one
 ;;; NIL entry in the stack after the last allocated port.
@@ -458,9 +180,11 @@
 	(gr-call mach:port_deallocate *task-self* port)
 	(setf (svref stack i)
 	      (gr-call* mach:port_allocate *task-self*))))))
+|#
 
 
 ;;;; Server stuff:
+#|
 ;;;
 ;;;    There is a fair amount of stuff to support Matchmaker RPC servers
 ;;; and asynchonous message service.  RPC message service needs to be
@@ -594,6 +318,9 @@
 ;;;
 (defsetf object-set-operation %set-object-set-operation
   "Sets the handler function for an object set operation.")
+|#
+
+
 
 ;;;; Emergency Message Handling:
 ;;;
@@ -604,6 +331,8 @@
 ;;; Instead, we use MessagesWaiting to find the ports with emergency
 ;;; messages.
 
+#| still more noise that will be different.
+
 (defalien waiting-ports nil (long-words 128))
 
 ;;; Service-Emergency-Message-Interrupt  --  Internal
@@ -739,6 +468,9 @@
 
 (pushnew 'clear-port-tables *before-save-initializations*)
 
+|#
+
+
 
 ;;; %Initial-Function is called when a cold system starts up.  First we zoom
 ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
@@ -753,7 +485,7 @@
 (eval-when (compile)
   (defmacro print-and-call (name)
     `(progn
-       (%primitive print ',name)
+       (%primitive print ,(symbol-name name))
        (,name))))
 
 (defun %initial-function ()
@@ -772,7 +504,7 @@
   (print-and-call c::globaldb-init)
 
   ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
-  (print-and-call subtypep-init)
+  (print-and-call type-init)
 
   (setq *lisp-initialization-functions*
 	(nreverse *lisp-initialization-functions*))
@@ -781,9 +513,14 @@
     (funcall fun))
   (makunbound '*lisp-initialization-functions*)	; So it gets GC'ed.
 
+  ;; Only do this after top level forms have run, 'cause thats where
+  ;; deftypes are.
+  (setq c::*type-system-initialized* t)
+
   (print-and-call os-init)
   (print-and-call filesys-init)
   (print-and-call conditions::error-init)
+  (print-and-call kernel::signal-init)
 
   (print-and-call reader-init)
   (print-and-call backq-init)
@@ -793,11 +530,16 @@
   (setq *readtable* (copy-readtable std-lisp-readtable))
 
   (print-and-call stream-init)
+  (print-and-call loader-init)
+  #+nil
   (print-and-call random-init)
   (print-and-call format-init)
   (print-and-call package-init)
+  #+nil
   (print-and-call pprint-init)
 
+  (%primitive print "Done initializing.")
+
   (setq *already-maybe-gcing* nil)
   (terpri)
   (princ "CMU Common Lisp kernel core image ")
@@ -820,16 +562,17 @@
 (defvar *task-notify* NIL)
 
 (defun reinit ()
+  (%primitive print "In REINIT.")
   (without-interrupts
    (setq *already-maybe-gcing* t)
-   (os-init)
-   (stream-reinit)
+   (print-and-call os-init)
+   (print-and-call kernel::signal-init)
+   (print-and-call stream-reinit)
    (setq *already-maybe-gcing* nil))
-  (setq *task-notify* (mach:mach-task_notify))
+  #+nil
   (mach:port_enable (mach:mach-task_self) *task-notify*)
-  (add-port-object *task-notify* nil *kernel-messages*)
-  (init-mach-signals))
-
+  #+nil
+  (add-port-object *task-notify* nil *kernel-messages*))
 
 ;;; 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
@@ -837,7 +580,8 @@
 
 (defun os-init ()
   (setq *task-self* (mach:mach-task_self))
-  (setq *task-data* (mach:mach-task_data)))
+  (setq *task-data* (mach:mach-task_data))
+  (setq *task-notify* (mach:mach-task_notify)))
 
 
 ;;; Setup-path-search-list returns a list of the directories that are
@@ -864,107 +608,17 @@
 
 ;;;; Miscellaneous external functions:
 
-(defun print-herald ()
-  (write-string "CMU Common Lisp ")
-  (write-line (lisp-implementation-version))
-  (write-string "Hemlock ") (write-string *hemlock-version*)
-  (write-string ", Compiler ") (write-line compiler-version)
-  (write-line "Send bug reports and questions to Gripe.")
-  (values))
-
-(defvar *editor-lisp-p* nil
-  "This is true if and only if the lisp was started with the -edit switch.")
-
-(defun save-lisp (core-file-name &key
-				 (purify t)
-				 (root-structures ())
-				 (init-function
-				  #'(lambda ()
-				      (throw 'top-level-catcher nil)))
-				 (load-init-file t)
-				 (enable-gc t)
-				 (print-herald t)
-				 (process-command-line t))
-  "Saves a Spice Lisp core image in the file of the specified name.  The
-  following keywords are defined:
-  
-  :purify
-      If true, do a purifying GC which moves all dynamically allocated
-  objects into static space so that they stay pure.  This takes somewhat
-  longer than the normal GC which is otherwise done, but GC's will done
-  less often and take less time in the resulting core file.
-
-  :root-structures
-      This should be a list of the main entry points in any newly loaded
-  systems.  This need not be supplied, but locality will be better if it
-  is.  This is meaningless if :purify is Nil.
-  
-  :init-function
-      This is a function which is called when the created core file is
-  resumed.  The default function simply aborts to the top level
-  read-eval-print loop.  If the function returns it will be the value
-  of Save-Lisp.
-  
-  :load-init-file
-      If true, then look for an init.lisp or init.fasl file when the core
-  file is resumed.
-  
-  :print-herald
-      If true, print out the lisp system herald when starting.
-
-  :enable-gc
-      If true, turn GC on if it was off."
-  
-  (if purify
-      (purify :root-structures root-structures)
-      (gc))
-  (unless (save core-file-name)
-    (setf (search-list "default:") (list (default-directory)))
-    (setf (search-list "path:") (setup-path-search-list))
-    (when process-command-line (ext::process-command-strings))
-    (setf *editor-lisp-p* nil)
-    (macrolet ((find-switch (name)
-		 `(find ,name *command-line-switches*
-			:key #'cmd-switch-name
-			:test #'(lambda (x y)
-				  (declare (simple-string x y))
-				  (string-equal x y)))))
-      (when (and process-command-line (find-switch "edit"))
-	(setf *editor-lisp-p* t))
-      (when (and load-init-file
-		 (not (and process-command-line (find-switch "noinit"))))
-	(let* ((cl-switch (find-switch "init"))
-	       (name (or (and cl-switch
-			      (or (cmd-switch-value cl-switch)
-				  (car (cmd-switch-words cl-switch))
-				  "init"))
-			 "init")))
-	  (load (merge-pathnames name (user-homedir-pathname))
-		:if-does-not-exist nil))))
-    (when enable-gc
-      (gc-on))
-    (when print-herald
-      (print-herald))
-    (when process-command-line
-      (ext::invoke-switch-demons *command-line-switches*
-				 *command-switch-demons*))
-    (funcall init-function)))
-
-
 ;;; Quit gets us out, one way or another.
 
 (defun quit (&optional recklessly-p)
   "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
   non-Nil."
-;  (reset-keyboard 0)
-  (dolist (x (if (boundp 'extensions::temporary-foreign-files)
-		 extensions::temporary-foreign-files))
-    (mach:unix-unlink x))
   (if recklessly-p
       (mach:unix-exit 0)
       (throw '%end-of-the-world nil)))
 
 
+#| might be something different.
 
 (defalien sleep-msg mach:msg (record-size 'mach:msg))
 (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
@@ -990,6 +644,8 @@
 		 (gr-error 'mach:receive gr)))))))
   nil)
 
+|#
+
 
 ;;;; TOP-LEVEL loop.
 
diff --git a/code/list.lisp b/code/list.lisp
index 11e987f5e..1be15d459 100644
--- a/code/list.lisp
+++ b/code/list.lisp
@@ -126,13 +126,14 @@
        (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 (%primitive nthcdr n list)))
+  (car (nthcdr n list)))
 
 (defun first (list)
   "Returns the 1st object in a list or NIL if the list is empty."
@@ -170,11 +171,15 @@
 
 (defun nthcdr (n list)
   "Performs the cdr function n times on a list."
-  (%primitive nthcdr n list))
+  (do ((i n (1- i))
+       (result list (cdr result)))
+      ((not (plusp i)) result)))
 
 (defun last (list)
   "Returns the last cons (not the last element!) of a list."
-  (%primitive last list))
+  (do ((list list (cdr list))
+       (result nil list))
+      ((null list) result)))
 
 (defun list (&rest args)
   "Returns constructs and returns a list of its arguments."
@@ -793,8 +798,6 @@
        ((endp alist))
      (if (car alist)
 	 (if ,test-guy (return (car alist))))))
-) ;eval-when
-
 
 (defun assoc (item alist &key key test test-not)
   "Returns the cons in alist whose car is equal (by a given test or EQL) to
@@ -893,11 +896,11 @@
 
 (defun memq (item list)
   "Returns tail of list beginning with first element eq to item"
-  (memq item list))
+  (member item list :test #'eq))
 
 (defun assq (item alist)
   "Return the first pair of alist where item EQ the key of pair"
-  (assq item alist))
+  (assoc item alist :test #'eq))
 
 (defun delq (item list &optional (n 0 np))
   (declare (fixnum n))
diff --git a/code/load.lisp b/code/load.lisp
index 8b20c5df9..69a1d6f4c 100644
--- a/code/load.lisp
+++ b/code/load.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.5 1990/08/24 18:11:40 wlott Exp $
+;;;
 ;;; Loader for Spice Lisp.
 ;;; Written by Skef Wholey and Rob MacLachlan.
 ;;;
@@ -338,13 +340,13 @@
 (defun check-header (file)
   (let ((byte (read-byte file NIL '*eof*)))
     (cond ((eq byte '*eof*) ())
-	  ((eq byte (char-int #\F))
+	  ((eq byte (char-code #\F))
 	   (do ((byte (read-byte file) (read-byte file))
 		(count 1 (1+ count)))
 	       ((= byte 255) t)
 	     (declare (fixnum byte))
 	     (if (and (< count 9)
-		      (not (eql byte (char-int (schar "FASL FILE" count)))))
+		      (not (eql byte (char-code (schar "FASL FILE" count)))))
 		 (error "Bad FASL file format."))))
 	  (t (error "Bad FASL file format.")))))
 
@@ -398,8 +400,7 @@
 	       (tn (probe-file pn)))
 	  (cond
 	   (tn
-	    (if (or (string-equal (pathname-type tn) "nfasl")
-		    (string-equal (pathname-type tn) "fasl"))
+	    (if (string-equal (pathname-type tn) #.vm:target-fasl-file-type)
 		(with-open-file (file tn
 				      :direction :input
 				      :element-type '(unsigned-byte 8))
@@ -417,7 +418,8 @@
 	   (t
 	    (let* ((srcn (make-pathname :type "lisp" :defaults pn))
 		   (src (probe-file srcn))
-		   (objn (make-pathname :type "nfasl" :defaults pn))
+		   (objn (make-pathname :type #.vm:target-fasl-file-type
+					:defaults pn))
 		   (obj (probe-file objn)))
 	      (cond
 	       (obj
@@ -465,10 +467,10 @@
 (define-fop (fop-empty-list 4) ())
 (define-fop (fop-truth 5) t)
 (define-fop (fop-misc-trap 66)
-	    (%primitive make-immediate-type 0 lisp::%trap-type))
+	    (%primitive make-other-immediate-type 0 vm:unbound-marker-type))
 
 (define-fop (fop-character 68)
-  (int-char (read-arg 3)))
+  (code-char (read-arg 3)))
 (define-fop (fop-short-character 69)
   (code-char (read-arg 1)))
 
@@ -563,22 +565,23 @@
 
 (define-fop (fop-ratio 70)
   (let ((den (pop-stack)))
-    (%primitive make-ratio (pop-stack) den)))
+    (%make-ratio (pop-stack) den)))
 
 (define-fop (fop-complex 71)
   (let ((im (pop-stack)))
-    (%primitive make-complex (pop-stack) im)))
+    (%make-complex (pop-stack) im)))
 
 (define-fop (fop-float 45)
   (let* ((n (read-arg 1))
 	 (exponent (load-s-integer (ceiling n 8)))
 	 (m (read-arg 1))
 	 (mantissa (load-s-integer (ceiling m 8)))
-	 (number (cond ((or (> n 9) (> m 32))
-			(coerce mantissa 'long-float))
-		       ((> m 21)
-			(coerce mantissa 'single-float))
-		       (T (coerce mantissa 'short-float)))))
+	 (number (if (or (not (<= vm:single-float-normal-exponent-min
+				  (+ exponent vm:single-float-bias)
+				  vm:single-float-normal-exponent-max))
+			 (> m (1+ vm:single-float-digits)))
+		     (coerce mantissa 'double-float)
+		     (coerce mantissa 'single-float))))
     (multiple-value-bind (f ex s) (decode-float number)
       (declare (ignore ex))
       (* s (scale-float f exponent)))))
@@ -645,14 +648,13 @@
 (define-fop (fop-array 83)
   (let* ((rank (read-arg 4))
 	 (vec (pop-stack))
-	 (size (+ rank %array-first-dim-slot))
 	 (length (length vec))
-	 (res (%primitive alloc-array rank)))
+	 (res (%primitive make-array-header vm:simple-array-type rank)))
     (declare (simple-array vec))
     (set-array-header res vec length length 0
-		      (do ((i (1- size) (1- i))
+		      (do ((i rank (1- i))
 			   (dimensions () (cons (pop-stack) dimensions)))
-			  ((< i %array-first-dim-slot) dimensions))
+			  ((zerop i) dimensions))
 		      nil)
     res))
 
@@ -668,12 +670,21 @@
   (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)))
+	   (type (case size
+		   (1 vm:simple-bit-vector-type)
+		   (2 vm:simple-array-unsigned-byte-2-type)
+		   (4 vm:simple-array-unsigned-byte-4-type)
+		   (8 vm:simple-array-unsigned-byte-8-type)
+		   (16 vm:simple-array-unsigned-byte-16-type)
+		   (32 vm:simple-array-unsigned-byte-32-type)
+		   (t (error "Losing i-vector element size: ~S"))))
+	   (bits (* len size))
+	   (res (%primitive allocate-vector type len
+			    (the index (ceiling bits vm:word-bits)))))
+      (declare (type (unsigned-byte 8) type)
+	       (type index len))
       (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))
+      (read-n-bytes *fasl-file* res 0 (ceiling bits vm:byte-bits))
       res)))
 
 
@@ -762,28 +773,23 @@
 
 
 ;;; Load-Code loads a code object.  NItems objects are popped off the stack for
-;;; the boxed storage section, then Size bytes of code are read in.  This must
-;;; be done WITHOUT-GCING, since GC only recognizes code object references that
-;;; appear in a function object.  If a GC happened before we stored the code
-;;; object, the code would disappear.
+;;; the boxed storage section, then Size bytes of code are read in.
 ;;;
 (defmacro load-code (nitems size)
-  `(without-gcing
-     (let ((box-num ,nitems)
-	   (code-length ,size))
-       (declare (fixnum box-num code-length))
-       (let ((function (%primitive alloc-function box-num)))
-	 (%primitive set-vector-subtype function %function-constants-subtype)
-	 (do ((index (1- box-num) (1- index)))
-	     ((minusp index))
-	   (declare (fixnum index))
-	   (%primitive header-set function index (pop-stack)))
-	 (let ((code (%primitive alloc-code code-length)))
-	   (read-n-bytes *fasl-file* code 0 code-length)
-	   (%primitive header-set function %function-code-slot code))
-	 (when *load-print-stuff*
-	   (format t "~&; ~S~%" function))
-	 function))))
+  `(let ((box-num ,nitems)
+	 (code-length ,size))
+     (declare (fixnum box-num code-length))
+     (let ((code (%primitive c::allocate-code-object box-num code-length)))
+       (%primitive c::set-code-debug-info code (pop-stack))
+       (do ((index (1- box-num) (1- index)))
+	   ((minusp index))
+	 (declare (fixnum index))
+	 (%primitive c::code-constant-set code index (pop-stack)))
+       (system:without-gcing
+	 (let ((inst (truly-the system-area-pointer
+				(%primitive c::code-instructions code))))
+	   (read-n-bytes *fasl-file* inst 0 code-length)))
+       code)))
 
 (define-fop (fop-code 58)
   (if (eql *current-code-format* %fasl-code-format)
@@ -812,197 +818,102 @@
 (clone-fop (fop-alter-code 140 nil) (fop-byte-alter-code 141)
   (let ((value (pop-stack))
 	(code (pop-stack))
-	(index (clone-arg)))
-    (%primitive header-set code index value)))
-
+	(index (- (clone-arg) vm:code-constants-offset)))
+    (declare (type index index))
+    (%primitive c::code-constant-set code index value)
+    (undefined-value)))
 
-;;; Kind of like Load-Code, except that we set the Code and Constants
-;;; slots from the Constants object that is our first stack argument.  The
-;;; subtype is set to the second stack argument.
-;;;
 (define-fop (fop-function-entry 142)
-  (let* ((box-num (read-arg 1))
-	 (function (%primitive alloc-function box-num)))
-    ;;
-    ;; Pop boxed things, storing them in the allocated entry object.
-    (do ((index (1- box-num) (1- index)))
-	((minusp index))
-      (%primitive header-set function index (pop-stack)))
-    ;;
-    ;; Set the subtype of the entry object.
-    (%primitive set-vector-subtype function (pop-stack))
-    ;;
-    ;; Set code and constants slots in the entry.
-    (let* ((constants (pop-stack))
-	   (code (%primitive header-ref constants %function-code-slot)))
-      (%primitive header-set function %function-code-slot code)
-      (%primitive header-set function %function-entry-constants-slot
-		  constants))
-
-    function))
-
-
-
-(define-fop (fop-user-miscop-fixup 134)
-  (let* ((miscop-name (pop-stack))
-	 (function-object (pop-stack))
-	 (code (%primitive header-ref function-object %function-code-slot))
-	 (offset (read-arg 4))
-	 (loaded-addr (get miscop-name '%loaded-address)))
-    (unless loaded-addr
-      (error "Miscop ~A is undefined." miscop-name))
-    
-    (let ((hi-addr (logior (ash clc::type-assembler-code
-				clc::type-shift-16)
-			   (logand (ash loaded-addr -16) #xFFFF))))
-      (setf (aref code (+ offset 1)) (logand hi-addr #xFF))
-      (setf (aref code (+ offset 2))
-	    (logand (ash loaded-addr -8) #xFF))
-      (setf (aref code (+ offset 3))
-	    (logand loaded-addr #xFF)))
-
-    function-object))
+  (let ((type (pop-stack))
+	(arglist (pop-stack))
+	(name (pop-stack))
+	(code-object (pop-stack))
+	(offset (read-arg 4)))
+    (declare (type index offset))
+    (unless (zerop (logand offset vm:lowtag-mask))
+      (error "Unaligned function object, offset = #x~X." offset))
+    (let ((fun (%primitive c::compute-function code-object offset)))
+      (%primitive c::set-function-self fun fun)
+      (%primitive c::set-function-next fun
+		  (%primitive c::code-entry-points code-object))
+      (%primitive c::set-code-entry-points code-object fun)
+      (%primitive c::set-function-name fun name)
+      (%primitive c::set-function-arglist fun arglist)
+      (%primitive c::set-function-type fun type)
+      fun)))
 
 
-;;;; Loading assembler routines:
-;;;
+;;;; Linkage fixups.
 
-;;; Allocate-Assembler-Code  --  Internal
-;;;
-;;;    Allocate some stuff out of assembler code space.
-;;;
-(defun allocate-assembler-code (bytes)
-  (let* ((idx (ash %assembler-code-type %alloc-ref-type-shift))
-	 (free (alloc-ref idx))
-	 (new (+ free bytes)))
-    (prog1
-      (%primitive make-immediate-type free %assembler-code-type)
-      (%primitive 16bit-system-set alloctable-address idx (ash new -16))
-      (%primitive 16bit-system-set alloctable-address (1+ idx)
-		  (logand new #xFFFF)))))
-
-(define-fop (fop-assembler-routine 130)
-  (let* ((code-length (read-arg 4))
-	 (buffer (make-array code-length :element-type '(unsigned-byte 8)))
-	 (code (allocate-assembler-code code-length)))
-    (declare (fixnum code-length))
-    (read-n-bytes *fasl-file* buffer 0 code-length)
-    (%primitive byte-blt buffer 0 code 0 code-length)
-    code))
-
-;;; A list of the miscop definitions which have been loaded but not
-;;; resolved.  Each element is a cons (name . code-ptr).
-;;;
-(defvar *miscop-definitions* ())
+;;; These two variables are initially filled in by Genesis.
 
+(defvar *initial-assembler-routines*)
+(defvar *initial-foreign-symbols*)
 
-;;; Recall that the format of a reference is (How Label Location),
-;;; where How is one of JI, BI, BA, or L, Label is the label's name, and
-;;; Location is the location of the reference.  These things are stored on
-;;; the list *external-references* as (Name . References), where Name is
-;;; the name of the referencing routine, and References is a list of references
-;;; in the above format.
-;;;
-(defvar *external-references* ())
-(defvar *user-defined-miscops* ())
-
-(define-fop (fop-fixup-miscop-routine 131 nil)
-  (let* ((external-references (pop-stack))
-	 (external-labels (pop-stack))
-	 (name (pop-stack))
-	 (code (pop-stack))
-	 (start (%primitive make-immediate-type code %+-fixnum-type)))
-    (dolist (lab external-labels)
-      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
-    (push (cons name external-references) *external-references*)
-    (push (cons name code) *miscop-definitions*)))
-
-(define-fop (fop-fixup-user-miscop-routine 133 nil)
-  (let* ((external-references (pop-stack))
-	 (external-labels (pop-stack))
-	 (name (pop-stack))
-	 (code (pop-stack))
-	 (start (%primitive make-immediate-type code %+-fixnum-type)))
-    (dolist (lab external-labels)
-      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
-    (push (cons name external-references) *external-references*)
-    (pushnew name *user-defined-miscops*)
-    (setf (get name 'user-miscop) t)))
-
-(define-fop (fop-fixup-assembler-routine 132 nil)
-  (let* ((external-references (pop-stack))
-	 (external-labels (pop-stack))
-	 (name (pop-stack))
-	 (code (pop-stack))
-	 (start (%primitive make-immediate-type code %+-fixnum-type)))
-    (dolist (lab external-labels)
-      (setf (get (car lab) '%loaded-address) (+ (ash (cdr lab) 1) start)))
-    (push (cons name external-references) *external-references*)))
-
-;;; Resolving all the assembler routines' references.
+(defvar *assembler-routines* (make-hash-table :test #'eq))
+(defvar *foreign-symbols* (make-hash-table :test #'equal))
 
-;;; Patch-Instruction  --  Internal
-;;;
-;;;    Used to patch an assembler code object.  Hi-var and lo-var are
-;;; bound to the values of the high and low halfwords in the instruction.
-;;; The values may by changed by setting the variables.
-;;;
-(defmacro patch-instruction ((hi-var lo-var code offset) &body body)
-  `(let ((,hi-var (%primitive 16bit-system-ref ,code ,offset))
-	 (,lo-var (%primitive 16bit-system-ref ,code (1+ ,offset))))
-     (multiple-value-prog1
-      (progn ,@body)
-      (%primitive 16bit-system-set ,code ,offset ,hi-var)
-      (%primitive 16bit-system-set ,code (1+ ,offset) ,lo-var))))
-
-;;; Resolve-Loaded-Assembler-References  --  Public
-;;;
-;;;    Fix up the recorded external references and define the miscops.
-;;;
-(defun resolve-loaded-assembler-references ()
-  "This function resolves external label references in loaded assembler
-  routines.  It should be called after assembler files have been loaded.
-  Miscop definitions do not take effect until this function is called."
-  (dolist (reflist *external-references*)
-    (let* ((code-byte-offset (get (car reflist) '%loaded-address))
-	   (code-halfword-offset (ash code-byte-offset -1))
-	   (address (%primitive make-immediate-type code-byte-offset
-				%assembler-code-type)))
-      (dolist (refs (cdr reflist))
-	(let ((how (car refs))
-	      (label (get (cadr refs) '%loaded-address))
-	      (location (caddr refs)))
-	  (unless label
-	    (error "~A references ~A, which has not been defined.~%"
-		   (car reflist) (cadr refs)))
-	  (let ((offset (- (- (ash label -1) code-halfword-offset) location)))
-	    (ecase how
-	      (clc::ji
-	       (unless (<= #x-80 offset #x7F)
-		 (error "Offset #X~X out of JI range for ~A to reference ~A.~%"
-			offset (car reflist) (cadr refs)))
-	       (patch-instruction (hi lo address location)
-		 (setf (ldb (byte 8 0) hi) offset)))
-	      (clc::bi
-	       (unless (<= #x-80000 offset #x7FFFF)
-		 (error "Offset #X~X out of BI range for ~A to reference ~A.~%"
-			offset (car reflist) (cadr refs)))
-	       (patch-instruction (hi lo address location)
-		 (setf (ldb (byte 4 0) hi) (ash offset -16))
-		 (setq lo (logand offset #xFFFF))))
-	      (clc::ba (error "I can't resolve a BA reference yet.~%"))
-	      (clc::l (error "I can't resolve an L reference yet.~%"))))))))
-  (setq *external-references* ())
-
-  (dolist (mo *miscop-definitions*)
-    (let* ((name (intern (symbol-name (car mo)) (find-package "COMPILER")))
-	   (index (get name 'clc::transfer-vector-index)))
-      (if index
-	  (%primitive write-control-stack
-		      (%primitive make-immediate-type (ash index 2)
-				  %assembler-code-type)
-		      (cdr mo))
-	  (pushnew name *user-defined-miscops*))))
-  (setq *miscop-definitions* ()))
+(defun loader-init ()
+  (dolist (routine *initial-assembler-routines*)
+    (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
+  (dolist (symbol *initial-foreign-symbols*)
+    (setf (gethash (car symbol) *foreign-symbols*) (cdr symbol)))
+  (makunbound '*initial-assembler-routines*)
+  (makunbound '*initial-foreign-symbols*))
 
+
+(define-fop (fop-foreign-fixup 143)
+  (let* ((code-object (pop-stack))
+	 (offset (read-arg 4))
+	 (len (read-arg 1))
+	 (sym (make-string len)))
+    (read-n-bytes *fasl-file* sym 0 len)
+    (multiple-value-bind
+	(value found)
+	(gethash sym *foreign-symbols* 0)
+      (unless found
+	(error "Unknown foreign symbol: ~S" sym))
+      (fixup-code-object code-object offset value))
+    code-object))
+
+(define-fop (fop-assembler-code 144)
+  (error "Cannot load assembler code."))
+
+(define-fop (fop-assembler-routine 145)
+  (error "Cannot load assembler code."))
+
+(define-fop (fop-assembler-fixup 146)
+  (let ((routine (pop-stack))
+	(code-object (pop-stack))
+	(offset (read-arg 4)))
+    (multiple-value-bind
+	(value found)
+	(gethash routine *assembler-routines*)
+      (unless found
+	(error "Undefined assembler routine: ~S" routine))
+      (fixup-code-object code-object offset value)
+      code-object)))
+
+(defun fixup-code-object (code offset fixup)
+  ;; Currently, the only kind of fixup we can have is a lui followed by an
+  ;; addi.
+  (multiple-value-bind
+      (word-offset rem)
+      (truncate offset vm:word-bytes)
+    (unless (zerop rem)
+      (error "Unaligned instruction?  offset=#x~X." offset))
+    (system:without-gcing
+     (let* ((sap (truly-the system-area-pointer
+			    (%primitive c::code-instructions code)))
+	    (half-word-offset (* word-offset 2))
+	    (new-val (+ fixup
+			(ash (sap-ref-16 sap half-word-offset) 16)
+			(signed-sap-ref-16 sap (+ half-word-offset 2))))
+	    (low (logand new-val (1- (ash 1 16))))
+	    (high (+ (ash new-val -16)
+		     (if (logbitp 15 low) 1 0))))
+       (setf (sap-ref-16 sap half-word-offset) high)
+       (setf (sap-ref-16 sap (+ half-word-offset 2)) low)))))
+
+
 (proclaim '(notinline read-byte))
diff --git a/code/machdef.lisp b/code/machdef.lisp
index 2d3471e46..eb06c475a 100644
--- a/code/machdef.lisp
+++ b/code/machdef.lisp
@@ -10,9 +10,21 @@
 ;;; 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))
+
+(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-type c-string (pointer simple-base-string))
+
 (defrecord Msg
   (Reserved1 (unsigned-byte 8) 8)
   (Reserved2 (unsigned-byte 8) 8)
@@ -29,41 +41,30 @@
   (seconds (unsigned-byte 32) (long-words 1))
   (useconds (signed-byte 32) (long-words 1)))
 
-(defalien timeval timeval (record-size 'timeval))
-
 (defrecord timezone
   (minuteswest (signed-byte 32) (long-words 1))
   (dsttime (signed-byte 32) (long-words 1)))
 
-(defalien timezone timezone (record-size 'timezone))
+#+new-compiler
+(def-c-array int-array unsigned-long 32)
+
+#+new-compiler
+(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))
 
 (eval-when (compile load eval)
-(defrecord int1
-  (int (signed-byte 32) (long-words 1)))
-
-(defalien int1 int1 (record-size 'int1))
-
-(defrecord int2
-  (int (signed-byte 32) (long-words 1)))
-
-(defalien int2 int2 (record-size 'int2))
-
-(defrecord int3
-  (int (signed-byte 32) (long-words 1)))
-
-(defalien int3 int3 (record-size 'int3))
-
-(defrecord sigcontext
-  (onstack (unsigned-byte 32) (long-words 1))
-  (mask (unsigned-byte 32) (long-words 1))
-  (sctx-fpa (unsgined-byte 32) (long-words 1))
-  (sp (unsigned-byte 32) (long-words 1))
-  (fp (unsigned-byte 32) (long-words 1))
-  (ap (unsigned-byte 32) (long-words 1))
-  (iar (unsigned-byte 32) (long-words 1))
-  (icscs (unsigned-byte 32) (long-words 1)))
-(defalien sigcontext sigcontext (record-size 'sigcontext))
-
 
 (defrecord tchars
   (intrc (signed-byte 8) (bytes 1))
@@ -72,7 +73,6 @@
   (stopc (signed-byte 8) (bytes 1))
   (eofc (signed-byte 8) (bytes 1))
   (brkc (signed-byte 8) (bytes 1)))
-(defalien tchars tchars (record-size 'tchars))
 
 (defrecord ltchars
   (suspc (signed-byte 8) (bytes 1))
@@ -81,7 +81,6 @@
   (flushc (signed-byte 8) (bytes 1))
   (werasc (signed-byte 8) (bytes 1))
   (lnextc (signed-byte 8) (bytes 1)))
-(defalien ltchars ltchars (record-size 'ltchars))
 
 ); eval-when (compile load eval)
 
@@ -90,16 +89,20 @@
 (eval-when (compile)
   (setq lisp::*bootstrap-defmacro* t))
 
-(defmacro sigmask (signal)
-  "Returns a mask given a signal." 
-  `(ash 1 (1- ,(unix-signal-number signal))))
+(defmacro with-trap-arg-block (type var &body forms)
+  `(with-stack-alien (,var ,type (record-size ',type))
+     ,@forms))
+
+;;; SIGMASK -- Public
+;;;
+#-new-compiler
+(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)))
 
-(defmacro with-trap-arg-block (arg-var alien-var &body forms)
-  `(progn (unless *free-trap-arg-blocks* (alloc-trap-arg-block))
-	  (let ((*free-trap-arg-blocks* (cdr *free-trap-arg-blocks*))
-		(,arg-var (car *free-trap-arg-blocks*)))
-	    (alien-bind ((,alien-var ,arg-var ,arg-var T))
-			,@forms))))
 #-new-compiler
 (eval-when (compile)
   (setq lisp::*bootstrap-defmacro* nil))
diff --git a/code/macros.lisp b/code/macros.lisp
index d59606850..b38bfc4df 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -7,13 +7,15 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.10 1990/08/24 18:11:50 wlott Exp $
+;;;
 ;;; This file contains the macros that are part of the standard
 ;;; Spice Lisp environment.
 ;;;
 ;;; Written by Scott Fahlman and Rob MacLachlan.
 ;;; Modified by Bill Chiles to adhere to
 ;;;
-(in-package 'lisp)
+(in-package "LISP")
 (export '(defvar defparameter defconstant when unless loop setf
 	  defsetf define-setf-method psetf shiftf rotatef push pushnew pop
 	  incf decf remf case typecase with-open-file
@@ -133,8 +135,12 @@
 ;;;
 (defun c::%%defmacro (name definition doc)
   (clear-info function where-from name)
-  (setf (info function macro-function name) definition)
-  (setf (info function kind name) :macro)
+  #+new-compiler
+  (setf (macro-function name) definition)
+  #-new-compiler
+  (progn
+    (setf (info function macro-function name) definition)
+    (setf (info function kind name) :macro))
   (setf (documentation name 'function) doc)
   name)
 
@@ -177,6 +183,11 @@
 
 (defparameter deftype-error-string "Type ~S cannot be used with ~S args.")
 
+#-new-compiler
+(defvar *bootstrap-deftype* :both)
+
+(compiler-let ((*bootstrap-defmacro* :both))
+
 (defmacro deftype (name arglist &body body)
   "Syntax like DEFMACRO, but defines a new type."
   (unless (symbolp name)
@@ -186,19 +197,37 @@
     (multiple-value-bind (body local-decs doc)
 			 (parse-defmacro arglist whole body name
 					 :default-default ''*
-					 :error-string 'deftype-error-string
-					 )
-      `(eval-when (compile load eval)
-	 (%deftype ',name
-		   #'(lambda (,whole) ,@local-decs (block ,name ,body))
-		   ,@(when doc `(,doc)))))))
+					 :error-string 'deftype-error-string)
+      (let ((guts `(%deftype ',name
+			     #'(lambda (,whole)
+				 ,@local-decs
+				 (block ,name ,body))
+			     ,@(when doc `(,doc)))))
+	#-new-compiler
+	(unless (member :new-compiler *features*)
+	  (setf guts
+		`(let ((*bootstrap-deftype* ,*bootstrap-deftype*))
+		   ,guts)))
+	`(eval-when (compile load eval)
+	   ,guts)))))
+
+); compile-let
 ;;;
 (defun %deftype (name expander &optional doc)
-  (setf (info type kind name) :defined)
-  (setf (info type expander name) expander)
+  #-new-compiler
+  (unless (or (eq *bootstrap-deftype* t)
+	      (member :new-compiler *features*))
+    (setf (get name 'deftype-expander)
+	  expander))
+  (when #-new-compiler *bootstrap-deftype* #+new-compiler t
+    (setf (info type kind name) :defined)
+    (setf (info type expander name) expander))
   (when doc
     (setf (documentation name 'type) doc))
-  (c::%note-type-defined name)
+  ;; ### 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)
 
 
@@ -507,9 +536,9 @@
 	  ;; ### Bootstrap hack...
 	  ;; Ignore any DEFSETF info for structure accessors.
 	  ((info function accessor-for (car form))
-	   (get-setf-method-inverse form `(funcall #'(setf ,(car form)))))
+	   (get-setf-method-inverse form `(funcall #'(setf ,(car form))) t))
 	  ((setq temp (info setf inverse (car form)))
-	   (get-setf-method-inverse form `(,temp)))
+	   (get-setf-method-inverse form `(,temp) nil))
 	  ((setq temp (info setf expander (car form)))
 	   (funcall temp form environment))
 	  (t
@@ -517,11 +546,11 @@
 				(macroexpand-1 form environment)
 	     (if win
 		 (foo-get-setf-method res environment)
-		 (get-setf-method-inverse
-		  form
-		  `(funcall #'(setf ,(car form))))))))))
+		 (get-setf-method-inverse form
+					  `(funcall #'(setf ,(car form)))
+					  t)))))))
 
-(defun get-setf-method-inverse (form inverse)
+(defun get-setf-method-inverse (form inverse setf-function)
   (let ((new-var (gensym))
 	(vars nil)
 	(vals nil))
@@ -530,7 +559,9 @@
       (push x vals))
     (setq vals (nreverse vals))
     (values vars vals (list new-var)
-	    `(,@inverse ,@vars ,new-var)
+	    (if setf-function
+		`(,@inverse ,new-var ,@vars)
+		`(,@inverse ,@vars ,new-var))
 	    `(,(car form) ,@vars))))
 
 
@@ -612,9 +643,11 @@
 			       new-access-form)))))
 	      ,@(if doc
 		    `((eval-when (load eval)
-			(%put ',access-fn '%setf-documentation ',doc)))
-		    `((eval-when (load eval)             ;SKH 4/17/84
-			(remprop ',access-fn '%setf-documentation))))
+			(setf (info setf documentation ',access-fn) ',doc)))
+		    `((eval-when (load eval)
+			(or (clear-info setf documentation ',access-fn)
+			    (setf (info setf documentation ',access-fn)
+				  nil)))))
 	      ',access-fn)))
 	(t (error "Ill-formed DEFSETF for ~S." access-fn))))
 
@@ -630,7 +663,7 @@
 	   (cond ((atom (car args))
 		  `(setq ,(car args) ,(cadr args)))
 		 ((info function accessor-for (caar args))
-		  `(funcall #'(setf ,(caar args)) ,@(cdar args) ,(cadr args)))
+		  `(funcall #'(setf ,(caar args)) ,(cadr args) ,@(cdar args)))
 		 ((setq temp (info setf inverse (caar args)))
 		  `(,temp ,@(cdar args) ,(cadr args)))
 		 (t (multiple-value-bind (dummies vals newval setter getter)
@@ -927,11 +960,14 @@
 
 (defsetf elt %setelt)
 (defsetf aref %aset)
+(defsetf row-major-aref %set-row-major-aref)
 (defsetf svref %svset)
 (defsetf char %charset)
 (defsetf bit %bitset)
 (defsetf schar %scharset)
 (defsetf sbit %sbitset)
+(defsetf %array-dimension %set-array-dimension)
+(defsetf %raw-bits %set-raw-bits)
 (defsetf symbol-value set)
 (defsetf symbol-function %sp-set-definition)
 (defsetf symbol-plist %sp-set-plist)
@@ -940,6 +976,15 @@
 (defsetf fill-pointer %set-fill-pointer)
 (defsetf search-list %set-search-list)
 
+(defsetf sap-ref-8 %set-sap-ref-8)
+(defsetf signed-sap-ref-8 %set-sap-ref-8)
+(defsetf sap-ref-16 %set-sap-ref-16)
+(defsetf signed-sap-ref-16 %set-sap-ref-16)
+(defsetf sap-ref-32 %set-sap-ref-32)
+(defsetf signed-sap-ref-32 %set-sap-ref-32)
+(defsetf sap-ref-sap %set-sap-ref-sap)
+(defsetf sap-ref-single %set-sap-ref-single)
+(defsetf sap-ref-double %set-sap-ref-double)
 
 (define-setf-method getf (place prop &optional default &environment env)
   (multiple-value-bind (temps values stores set get)
@@ -1021,21 +1066,35 @@
 		     `(apply (function ,(car getter)) ,@(cdr getter)))))))
 
 
+;;; Special-case a BYTE bytespec so that the compiler can recognize it.
+;;;
 (define-setf-method ldb (bytespec place &environment env)
   "The first argument is a byte specifier.  The second is any place form
   acceptable to SETF.  Replaces the specified byte of the number in this
   place with bits from the low-order end of the new value."
   (multiple-value-bind (dummies vals newval setter getter)
 		       (foo-get-setf-method place env)
-    (let ((btemp (gensym))
-	  (gnuval (gensym)))
-      (values (cons btemp dummies)
-	      (cons bytespec vals)
-	      (list gnuval)
-	      `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
-		 ,setter
-		 ,gnuval)
-	      `(ldb ,btemp ,getter)))))
+    (if (and (consp bytespec) (eq (car bytespec) 'byte))
+	(let ((n-size (gensym))
+	      (n-pos (gensym))
+	      (n-new (gensym)))
+	  (values (list* n-size n-pos dummies)
+		  (list* (second bytespec) (third bytespec) vals)
+		  (list n-new)
+		  `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
+					     ,getter)))
+		     ,setter
+		     ,n-new)
+		  `(ldb (byte ,n-size ,n-pos) ,getter)))
+	(let ((btemp (gensym))
+	      (gnuval (gensym)))
+	  (values (cons btemp dummies)
+		  (cons bytespec vals)
+		  (list gnuval)
+		  `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
+		     ,setter
+		     ,gnuval)
+		  `(ldb ,btemp ,getter))))))
 
 
 (define-setf-method mask-field (bytespec place &environment env)
@@ -1055,23 +1114,6 @@
 	      `(mask-field ,btemp ,getter)))))
 
 
-(define-setf-method char-bit (place bit-name &environment env)
-  "The first argument is any place form acceptable to SETF.  Replaces the
-  specified bit of the character in this place with the new value."
-  (multiple-value-bind (dummies vals newval setter getter)
-		       (foo-get-setf-method place env)
-    (let ((btemp (gensym))
-	  (gnuval (gensym)))
-      (values `(,@dummies ,btemp)
-	      `(,@vals ,bit-name)
-	      (list gnuval)
-	      `(let ((,(car newval)
-		      (set-char-bit ,getter ,btemp ,gnuval)))
-		 ,setter
-		 ,gnuval)
-	      `(char-bit ,getter ,btemp)))))
-
-
 (define-setf-method the (type place &environment env)
   (multiple-value-bind (dummies vals newval setter getter)
 		       (foo-get-setf-method place env)
diff --git a/code/misc.lisp b/code/misc.lisp
index f6b13dffd..80e7d8680 100644
--- a/code/misc.lisp
+++ b/code/misc.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/misc.lisp,v 1.3 1990/08/24 18:11:59 wlott Exp $
+;;;
 ;;; Assorted miscellaneous functions for Spice Lisp.
 ;;;
 ;;; Written and maintained mostly by Skef Wholey and Rob MacLachlan.
@@ -53,7 +55,7 @@
 		 (info random-documentation stuff name))))))
   string)
 
-(defvar *features* '(:common :cmu :mach :ibm-rt-pc :new-compiler)
+(defvar *features* '(:common :cmu :mach :decstation-3100 :pmax :new-compiler)
   "Holds a list of symbols that describe features provided by the
    implementation.")
 
@@ -82,19 +84,11 @@
 
 (defun machine-type ()
   "Returns a string describing the type of the local machine."
-  "IBM RT PC")
+  "DECstation 3100")
 
 (defun machine-version ()
   "Returns a string describing the version of the local machine."
-  (let ((version (system:%primitive 16bit-system-ref
-				    (int-sap
-				     (+ (ash clc::romp-data-base 16)
-					clc::floating-point-hardware-available))
-				    1)))
-    (if (or (not (= (logand version clc::float-mc68881) 0))
-	    (not (= (logand version clc::float-afpa) 0)))
-	"IBM RT PC/APC"
-	"IBM RT PC")))
+  "DECstation 3100")
 
 (defun machine-instance ()
   "Returns a string giving the name of the local machine."
@@ -110,11 +104,11 @@
 
 (defun short-site-name ()
   "Returns a string with the abbreviated site name."
-  "CMU-CSD")
+  "CMU-SCS")
 
 (defun long-site-name ()
   "Returns a string with the long form of the site name."
-  "Carnegie-Mellon University Computer Science Department")
+  "Carnegie-Mellon University School of Computer Science")
 
 
 
diff --git a/code/pred.lisp b/code/pred.lisp
index 50593f9fb..a4e387903 100644
--- a/code/pred.lisp
+++ b/code/pred.lisp
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
+;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the Spice Lisp project at
@@ -7,15 +7,21 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; Predicate functions for Spice Lisp.
-;;; The type predicates are implementation-specific.  A different version
-;;;   of this file will be required for implementations with different
-;;;   data representations.
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.7 1990/08/24 18:12:12 wlott Exp $
 ;;;
-;;; Written and currently maintained by Scott Fahlman.
-;;; Based on an earlier version by Joe Ginder.
+;;; Predicate functions for CMU Common Lisp.
 ;;;
-(in-package 'lisp)
+;;; Written by William Lott.
+;;;
+
+(in-package "EXTENSIONS")
+(export '(structurep fixnump bignump bitp ratiop realp weak-pointer-p))
+
+(in-package "SYSTEM")
+(export '(system-area-pointer system-area-pointer-p))
+
+(in-package "LISP" :use "KERNEL")
+
 (export '(typep null symbolp atom consp listp numberp integerp rationalp
 	  floatp complexp characterp stringp bit-vector-p vectorp
 	  simple-vector-p simple-string-p simple-bit-vector-p arrayp
@@ -25,487 +31,292 @@
 	  array atom bignum bit bit-vector character common
 	  compiled-function complex cons double-float
 	  fixnum float function integer keyword list long-float nil
-	  null number ratio rational sequence short-float signed-byte
+	  null number ratio rational real sequence short-float signed-byte
 	  simple-array simple-bit-vector simple-string simple-vector
 	  single-float standard-char string string-char symbol t
 	  unsigned-byte vector structure satisfies))
 
-(in-package "EXTENSIONS")
-(export '(structurep fixnump bignump bitp ratiop))
-(in-package "LISP")
-
-
-;;; Data type predicates.
-
-;;; Translation from type keywords to specific predicates.  Assumes that
-;;; the following are named structures and need no special type hackery:
-;;; PATHNAME, STREAM, READTABLE, PACKAGE, HASHTABLE, RANDOM-STATE.
-
-(defparameter type-pred-alist
-  '((keyword . keywordp)
-    (common . commonp)
-    (null . null)
-    (cons . consp)
-    (list . listp)
-    (symbol . symbolp)
-    (array . arrayp)
-    (vector . vectorp)
-    (bit-vector . bit-vector-p)
-    (string . stringp)
-    (sequence . sequencep)
-    (simple-array . simple-array-p)
-    (c::structure-vector . simple-vector-p)
-    (simple-vector . simple-vector-p)
-    (simple-string . simple-string-p)
-    (simple-bit-vector . simple-bit-vector-p)
-    (function . functionp)
-    (compiled-function . compiled-function-p)
-    (character . characterp)
-    (number . numberp)
-    (rational . rationalp)
-    (float . floatp)
-    (string-char . %string-char-p)
-    (integer . integerp)
-    (ratio . ratiop)
-    (short-float . short-float-p)
-    (standard-char . %standard-char-p)
-    (fixnum . fixnump)
-    (complex . complexp)
-;    (single-float . single-float-p)
-    (single-float . short-float-p)
-    (bignum . bignump)
-    (double-float . double-float-p)
-    (bit . bitp)
-    (long-float . long-float-p)
-    (structure . structurep)
-    (atom . atom)))
 
 
-;;;; TYPE-OF and auxiliary functions.
+;;;; Primitive predicates.  These must be supported by the compiler.
+
+(eval-when (compile eval)
+  (defparameter primitive-predicates
+    '(array-header-p
+      arrayp
+      atom
+      base-char-p
+      bignump
+      bit-vector-p
+      characterp
+      consp
+      compiled-function-p
+      complexp
+      double-float-p
+      fixnump
+      floatp
+      functionp
+      integerp
+      listp
+      not
+      null
+      numberp
+      rationalp
+      ratiop
+      realp
+      simple-array-p
+      simple-bit-vector-p
+      simple-string-p
+      simple-vector-p
+      single-float-p
+      stringp
+      symbolp
+      system-area-pointer-p
+      weak-pointer-p
+      vectorp
+      c::unsigned-byte-32-p
+      c::signed-byte-32-p
+      c::simple-array-unsigned-byte-2-p
+      c::simple-array-unsigned-byte-4-p
+      c::simple-array-unsigned-byte-8-p
+      c::simple-array-unsigned-byte-16-p
+      c::simple-array-unsigned-byte-32-p
+      c::simple-array-single-float-p
+      c::simple-array-double-float-p
+      )))
+
+(macrolet
+    ((frob ()
+       `(progn
+	  ,@(mapcar #'(lambda (pred)
+			`(defun ,pred (object)
+			   ,(format nil
+				    "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
+				     and NIL otherwise."
+				    (find (schar (string pred) 0) "AEIOUaeiou")
+				    (string pred))
+			   (,pred object)))
+		    primitive-predicates))))
+  (frob))
 
+
+;;;; TYPE-OF -- public.
+;;;
+;;; Return the specifier for the type of object.  This is not simply
+;;; (type-specifier (ctype-of object)) because ctype-of has different goals
+;;; than type-of.
+;;; 
 (defun type-of (object)
-  "Returns the type of OBJECT as a type-specifier.
-  Since objects may be of more than one type, the choice is somewhat
-  arbitrary and may be implementation-dependent."
-  (if (null object) 'symbol
-      (case (%primitive get-type object)
-	(#.%+-fixnum-type 'fixnum)
-	(#.%bignum-type 'bignum)
-	(#.%ratio-type 'ratio)
-	((#.%short-+-float-type #.%short---float-type) 'short-float)
-	(#.%long-float-type 'long-float)
-	(#.%complex-type 'complex)
-	(#.%string-type `(simple-string ,(%primitive vector-length object)))
-	(#.%bit-vector-type
-	 `(simple-bit-vector ,(%primitive vector-length object)))
-	(#.%integer-vector-type (type-of-i-vector object))
-	(#.%general-vector-type (type-of-g-vector object))
-	(#.%array-type (type-of-array object))
-	(#.%function-type 'function)
-	(#.%symbol-type 'symbol)
-	(#.%list-type 'cons)
-	(#.%string-char-type 'string-char)
-	(#.%bitsy-char-type 'character)
-	(#.%--fixnum-type 'fixnum)
-	(t 'random))))
-
-;;; %String-Char-P is called by typep when the type specification
-;;; is string-char.  The CL string-char-p does not do the right thing.
-(defun %string-char-p (x)
-  (and (characterp x)
-       (< (the fixnum (char-int x)) char-code-limit)))
-
-;;; Create the list-style description of a G-vector.
+  "Return the type of OBJECT."
+  (typecase object
+    (null 'null)
+    (cons 'cons)
+    (character
+     (typecase object
+       (standard-char 'standard-char)
+       (base-character 'base-character)
+       (t 'character)))
+    (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 (typep object 'keyword)
+		'keyword
+		'symbol))
+    (structure
+     (%primitive c::structure-ref object 0))
+    (array
+     (type-specifier (ctype-of object)))
+    (function
+     (type-specifier (ctype-of object)))
+    (t
+     (warn "Can't figure out the type of ~S" object)
+     t)))
 
-(defun type-of-g-vector (object)
-  (if (structurep object)
-      (%primitive header-ref object
-		  %g-vector-structure-name-slot)
-      `(simple-vector ,(%primitive vector-length object))))
-
-;;; I-Vector-Element-Type  --  Internal
-;;;
-;;;    Return a type specifier for the element type of an I-Vector.
+
+;;;; SUBTYPEP -- public.
 ;;;
-(defun i-vector-element-type (object)
-  (let ((ac (%primitive get-vector-access-code object)))
-    (if (< 0 ac 6)
-	(svref '#((mod 2) (mod 4) (mod 16) (mod 256) (mod 65536)
-		  (mod 4294967296))
-	       ac)
-	(error "Invalid I-Vector access code: ~S" ac))))
-	
-;;; Create the list-style description of an I-vector.
-	
-(defun type-of-i-vector (object)
-  `(simple-array ,(i-vector-element-type object)
-		 ,(%primitive vector-length object)))
-
-
-;;; Create the list-style description of an array.
+;;; Just parse the type specifiers and call csubtype.
+;;; 
+(defun subtypep (type1 type2)
+  "Return two values indicating the relationship between type1 and type2:
+  T and T: type1 definatly is a subtype of type2.
+  NIL and T: type1 definatly is not a subtype of type2.
+  NIL and NIL: who knows?"
+  (csubtypep (specifier-type type1) (specifier-type type2)))
 
-(defun type-of-array (object)
-  (with-array-data ((data-vector object) (start) (end))
-    (declare (ignore start end))
-    (let ((rank (- (the fixnum (%primitive header-length object))
-		   %array-first-dim-slot))
-	  (length (%primitive header-ref object %array-length-slot)))
-      (declare (fixnum rank length))
-      (if (= rank 1)
-	  (typecase data-vector
-	    (simple-bit-vector `(bit-vector ,length))
-	    (simple-string `(string ,length))
-	    (simple-vector `(vector t ,length))
-	    (t `(vector ,(i-vector-element-type data-vector) ,length)))
-	  `(array
-	    ,(typecase data-vector
-	       (simple-bit-vector '(mod 2))
-	       (simple-string 'string-char)
-	       (simple-vector 't)
-	       (t (i-vector-element-type data-vector)))
-	    ,(array-dimensions object))))))
 
-;;;; TYPEP and auxiliary functions.
-
-(defun %typep (object type)
-  (let ((type (type-expand type))
-	temp)
-    (cond ((symbolp type)
-	   (cond ((or (eq type t) (eq type '*)) t)
-		 ((eq type 'nil) nil)
-		 ((setq temp (assq type type-pred-alist))
-		  (funcall (cdr temp) object))
-		 (t (structure-typep object type))))
-	  ((listp type) 
-	   ;; This handles list-style type specifiers.
-	   (case (car type)
-	     (vector (and (vectorp object)
-			  (vector-eltype object (cadr type))
-			  (test-length object (caddr type))))
-	     (simple-vector (and (simple-vector-p object)
-				 (test-length object (cadr type))))
-	     (string (and (stringp object)
-			  (test-length object (cadr type))))
-	     (simple-string (and (simple-string-p object)
-				 (test-length object (cadr type))))
-	     (bit-vector (and (bit-vector-p object)
-			      (test-length object (cadr type))))
-	     (simple-bit-vector (and (simple-bit-vector-p object)
-				     (test-length object (cadr type))))
-	     (array (array-typep object type))
-	     (simple-array (and (not (array-header-p object))
-				(array-typep object type)))
-	     (satisfies (funcall (cadr type) object))
-	     (member (member object (cdr type)))
-	     (not (not (typep object (cadr type))))
-	     (or (dolist (x (cdr type) nil)
-		   (if (typep object x) (return t))))
-	     (and (dolist (x (cdr type) t)
-		    (if (not (typep object x)) (return nil))))
-	     (integer (and (integerp object) (test-limits object type)))
-	     (rational (and (rationalp object) (test-limits object type)))
-	     (float (and (floatp object) (test-limits object type)))
-	     (short-float (and (short-float-p object)
-			       (test-limits object type)))
-	     (single-float (and (single-float-p object)
-				(test-limits object type)))
-	     (double-float (and (double-float-p object)
-				(test-limits object type)))
-	     (long-float (and (long-float-p object)
-			      (test-limits object type)))
-	     (mod (and (integerp object)
-		       (>= object 0)
-		       (< object (cadr type))))
-	     (signed-byte
-	      (and (integerp object)
-		   (let ((n (cadr type)))
-		     (or (not n) (eq n '*)
-			 (> n (integer-length object))))))
-	     (unsigned-byte
-	      (and (integerp object)
-		   (not (minusp object))
-		   (let ((n (cadr type)))
-		     (or (not n) (eq n '*)
-			 (>= n (integer-length object))))))
-	     (complex (and (numberp object)
-			   (or (not (cdr type))
-			       (typep (realpart object) (cadr type)))))
-	     (t (error "~S -- Illegal type specifier to TYPEP."  type))))
-	  (t (error "~S -- Illegal type specifier to TYPEP."  type)))))
-
-(defun typep (obj type)
-  "Returns T if OBJECT is of the specified TYPE, otherwise NIL."
-  (declare (notinline %typep))
-  (%typep obj type))
-
-
-;;; Given that the object is a vector of some sort, and that we've already
-;;; verified that it matches CAR of TYPE, see if the rest of the type
-;;; specifier wins.  Mild hack: Eltype Nil means either type not supplied
-;;; or was Nil.  Any vector can hold objects of type Nil, since there aren't
-;;; any, so (vector nil) is the same as (vector *).
+;;;; TYPEP -- public.
 ;;;
-(defun vector-eltype (object eltype)
-  (let ((data (if (array-header-p object)
-		  (with-array-data ((data object) (start) (end))
-		    (declare (ignore start end))
-		    data)
-		  object))
-	(eltype (type-expand eltype)))
-    (case eltype
-      ((t) (simple-vector-p data))
-      (string-char (simple-string-p data))
-      (bit (simple-bit-vector-p data))
-      ((* nil) t)
-      (t
-       (subtypep eltype
-		 (cond ((simple-vector-p data) t)
-		       ((simple-string-p data) 'string-char)
-		       ((simple-bit-vector-p data) 'bit)
-		       (t
-			(i-vector-element-type data))))))))
-
-
-;;; Test sequence for specified length.
-
-(defun test-length (object length)
-  (or (null length)
-      (eq length '*)
-      (= length (length object))))
-
-
-;;; See if object satisfies the specifier for an array.
-
-(defun array-typep (object type)
-  (and (arrayp object)
-       (vector-eltype object (cadr type))
-       (if (cddr type)
-	   (let ((dims (third type)))
-	     (cond ((eq dims '*) t)
-		   ((numberp dims)
-		    (and (vectorp object)
-			 (= (the fixnum (length (the vector object)))
-			    (the fixnum dims))))
-		   (t
-		    (dotimes (i (array-rank object) (null dims))
-		      (when (null dims) (return nil))
-		      (let ((dim (pop dims)))
-			(unless (or (eq dim '*)
-				    (= dim (array-dimension object i)))
-			  (return nil)))))))
-	   t)))
-
-
-;;; Test whether a number falls within the specified limits.
-
-(defun test-limits (object type)
-  (let ((low (cadr type))
-	(high (caddr type)))
-    (and (cond ((null low) t)
-	       ((eq low '*) t)
-	       ((numberp low) (>= object low))
-	       ((and (consp low) (numberp (car low)))
-		(> object (car low)))
-	       (t nil))
-	 (cond ((null high) t)
-	       ((eq high '*) t)
-	       ((numberp high) (<= object high))
-	       ((and (consp high) (numberp (car high)))
-		(< object (car high)))
-	       (t nil)))))
+;;; Just call %typep
+;;; 
+(defun typep (object type)
+  "Return T iff OBJECT is of type TYPE."
+  (declare (type (or list symbol) type))
+  (%typep object type))
+
+;;; %TYPEP -- internal.
+;;;
+;;; The actual typep engine.  The compiler only generates calls to this
+;;; function when it can't figure out anything more intelligent to do.
+;;; 
+(defun %typep (object specifier)
+  (declare (type (or list symbol ctype) specifier))
+  (let ((type (if (ctype-p specifier)
+		  specifier
+		  (specifier-type specifier))))
+    (etypecase type
+      (named-type
+       (ecase (named-type-name type)
+	 ((* t)
+	  t)
+	 ((nil)
+	  nil)
+	 (character (characterp object))
+	 (base-character (base-char-p object))
+	 (standard-char (and (characterp object) (standard-char-p object)))
+	 (extended-character
+	  (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))
+	 (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)
+		      (let ((re (realpart object))
+			    (im (imagpart object)))
+			(and (bound-test (min re im))
+			     (bound-test (max re im))))))
+		(: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)))
+      (union-type
+       (dolist (type (union-type-types type))
+	 (when (%typep object type)
+	   (return t))))
+      (unknown-type
+       (let ((orig-spec (unknown-type-specifier type)))
+	 (if (eq type specifier)
+	     ;; The type was unknown at compile time.  Therefore, we should
+	     ;; try again at runtime, 'cause it might be known now.
+	     (%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))
+		  (unless (%typep object spec)
+		    (return nil)))))
+	   (not
+	    (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
+	      (error "Invalid type specifier: ~S" hairy-spec))
+	    (not (%typep object (cadr hairy-spec))))
+	   (satisfies
+	    (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
+	      (error "Invalid type specifier: ~S" hairy-spec))
+	    (if (funcall (cadr hairy-spec) object) t)))))
+      (function-type
+       (error "Function types are not a legal argument to TYPEP:~%  ~S"
+	      specifier)))))
 
 
 ;;; Structure-Typep  --  Internal
 ;;;
-;;; This is called by Typep if the type-specifier is a symbol and is not one of
-;;; the built-in Lisp types.  If it's a structure, see if it's that type, or if
-;;; it includes that type.
+;;; This is called by %typep when it tries to match against a structure type,
+;;; and typep of types that are known to be structure types at compile time
+;;; are converted to this.
 ;;;
 (defun structure-typep (object type)
   (declare (optimize speed))
-  (let ((type (type-expand type)))
-    (if (symbolp type)
-	(let ((info (info type defined-structure-info type)))
-	  (if info
-	      (and (structurep object)
-		   (let ((obj-name (%primitive header-ref object 0)))
-		     (or (eq obj-name type)
-			 (if (memq obj-name (c::dd-included-by info))
-			     t nil))))
-	      (error "~S is an unknown type specifier." type)))
-	(error "~S is an unknown type specifier." type))))
+  (let ((info (info type defined-structure-info type)))
+    (if info
+	(and (structurep object)
+	     (let ((obj-name (%primitive structure-ref object 0)))
+	       (or (eq obj-name type)
+		   (if (member obj-name (c::dd-included-by info)
+			       :test #'eq)
+		       t nil))))
+	(error "~S is an unknown structure type specifier." type))))
 
 
-;;;; Assorted mumble-P type predicates.
-
-(defun commonp (object)
-  "Returns T if object is a legal Common-Lisp type, NIL if object is any
-  sort of implementation-dependent or internal type."
-  (or (structurep object)
-      (let ((type-spec (type-of object)))
-	(if (listp type-spec) (setq type-spec (car type-spec)))
-	(when (memq type-spec
-		    '(character fixnum short-float single-float double-float
-				long-float vector string simple-vector
-				simple-string bignum ratio complex
-				compiled-function array symbol cons))
-	  T))))
-
-(defun bit-vector-p (object)
-  "Returns T if the object is a bit vector, else returns NIL."
-  (bit-vector-p object))
-
-;;; The following definitions are trivial because the compiler open-codes
-;;; all of these.
-
-(defun null (object)
-  "Returns T if the object is NIL, else returns NIL."
-  (null object))
+;;;; Equality predicates.
 
-(defun not (object)
-  "Returns T if the object is NIL, else returns NIL."
-  (null object))
-
-(defun symbolp (object)
-  "Returns T if the object is a symbol, else returns NIL."
-  (symbolp object))
-
-(defun atom (object)
-  "Returns T if the object is not a cons, else returns NIL.
-  Note that (ATOM NIL) => T."
-  (atom object))
-
-(defun consp (object)
-  "Returns T if the object is a cons cell, else returns NIL.
-  Note that (CONSP NIL) => NIL."
-  (consp object))
-
-(defun listp (object)
-  "Returns T if the object is a cons cell or NIL, else returns NIL."
-  (listp object))
-
-(defun numberp (object)
-  "Returns T if the object is any kind of number."
-  (numberp object))
-
-(defun integerp (object)
-  "Returns T if the object is an integer (fixnum or bignum), else 
-  returns NIL."
-  (integerp object))
-
-(defun rationalp (object)
-  "Returns T if the object is an integer or a ratio, else returns NIL."
-  (rationalp object))
-
-(defun floatp (object)
-  "Returns T if the object is a floating-point number, else returns NIL."
-  (floatp object))
-
-(defun complexp (object)
-  "Returns T if the object is a complex number, else returns NIL."
-  (complexp object))
-
-(defun %standard-char-p (x)
-  (and (characterp x) (standard-char-p x)))
-
-(defun characterp (object)
-  "Returns T if the object is a character, else returns NIL."
-  (characterp object))
-
-(defun stringp (object)
-  "Returns T if the object is a string, else returns NIL."
-  (stringp object))
-
-(defun simple-string-p (object)
-  "Returns T if the object is a simple string, else returns NIL."
-  (simple-string-p object))
-
-(defun vectorp (object)
-  "Returns T if the object is any kind of vector, else returns NIL."
-  (vectorp object))
-
-(defun simple-array-p (object)
-  "Returns T if the object is a simple array, else returns NIL."
-  (and (arrayp object) (not (array-header-p object))))
-
-(defun simple-vector-p (object)
-  "Returns T if the object is a simple vector, else returns NIL."
-  (simple-vector-p object))
-
-(defun simple-bit-vector-p (object)
-  "Returns T if the object is a simple bit vector, else returns NIL."
-  (simple-bit-vector-p object))
-
-(defun arrayp (object)
-  "Returns T if the argument is any kind of array, else returns NIL."
-  (arrayp object))
-
-(defun functionp (object)
-  "Returns T if the object is a function, suitable for use by FUNCALL
-  or APPLY, else returns NIL."
-  (functionp object))
-
-(defun compiled-function-p (object)
-  "Returns T if the object is a compiled function object, else returns NIL."
-  (compiled-function-p object))
-
-;;; ### Dummy definition until we figure out what to really do...
-(defun clos::funcallable-instance-p (object)
-  (declare (ignore object))
-  nil)
-
-(defun sequencep (object)
-  "Returns T if object is a sequence, NIL otherwise."
-  (typep object 'sequence))
-
-
-;;; The following are not defined at user level, but are necessary for
-;;; internal use by TYPEP.
-
-(defun structurep (object)
-  (structurep object))
-
-(defun fixnump (object)
-  (fixnump object))
-
-(defun bignump (object)
-  (bignump object))
-
-(defun bitp (object)
-  (typep object 'bit))
-
-(defun short-float-p (object)
-  (typep object 'short-float))
-
-(defun single-float-p (object)
-  (typep object 'single-float))
-
-(defun double-float-p (object)
-  (typep object 'double-float))
-
-(defun long-float-p (object)
-  (typep object 'long-float))
-
-(defun ratiop (object)
-  (ratiop object))
-
-;;; Some silly internal things for tenser array hacking:
-
-(defun array-header-p (object)
-  (array-header-p object))
-
-;;;; Equality Predicates.
+;;; EQ -- public.
+;;;
+;;; Real simple, 'cause the compiler takes care of it.
+;;; 
 
-(defun eq (x y)
-  "Returns T if X and Y are the same object, else returns NIL."
-  (eq x y))
+(defun eq (obj1 obj2)
+  "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
+  (eq obj1 obj2))
 
-(defun eql (x y)
-  "Returns T if X and Y are EQ, or if they are numbers of the same
-  type and precisely equal value, or if they are characters and
-  are CHAR=, else returns NIL."
-  (eql x y))
 
+;;; EQUAL -- public.
+;;;
 (defun equal (x y)
   "Returns T if X and Y are EQL or if they are structured components
   whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
@@ -537,8 +348,7 @@
 			  (declare (fixnum i))
 			  (if (not (equal (svref x-el i) (svref y-el i)))
 			      (return-from equal nil))))
-		      (unless (or (eql x-el y-el)
-				  (equal x-el y-el))
+		      (unless (equal x-el y-el)
 			(return nil)))))))
 	((bit-vector-p x)
 	 (and (bit-vector-p y)
@@ -553,7 +363,8 @@
 		    (return nil)))))
 	(t nil)))
 
-
+;;; EQUALP -- public.
+;;; 
 (defun equalp (x y)
   "Just like EQUAL, but more liberal in several respects.
   Numbers may be of different types, as long as the values are identical
@@ -569,9 +380,8 @@
 	      (equalp (cdr x) (cdr y))))
 	((vectorp x)
 	 (let ((length (length x)))
-	   (declare (fixnum length))
 	   (and (vectorp y)
-		(= length (the fixnum (length y)))
+		(= length (length y))
 		(dotimes (i length t)
 		  (let ((x-el (aref x i))
 			(y-el (aref y i)))
@@ -579,27 +389,14 @@
 				(equalp x-el y-el))
 		      (return nil)))))))
 	((arrayp x)
-	 (let ((rank (array-rank x))
-	       (len (%primitive header-ref x %array-length-slot)))
-	   (declare (fixnum rank len))
-	   (and (arrayp y)
-		(= (the fixnum (array-rank y)) rank)
-		(dotimes (i rank t)
-		  (unless (= (the fixnum (array-dimension x i))
-			     (the fixnum (array-dimension y i)))
-		    (return nil)))
-		(with-array-data ((x-vec x) (x-start) (end))
-		  (declare (ignore end))
-		  (with-array-data ((y-vec y) (y-start) (end))
-		    (declare (ignore end))
-		    (do ((i x-start (1+ i))
-			 (j y-start (1+ j))
-			 (count len (1- count)))
-			((zerop count) t)
-		      (declare (fixnum i j count))
-		      (let ((x-el (aref x-vec i))
-			    (y-el (aref y-vec j)))
-			(unless (or (eql x-el y-el)
-				    (equalp x-el y-el))
-			  (return nil)))))))))
+	 (and (arrayp y)
+	      (= (array-rank x) (array-rank y))
+	      (dotimes (axis (array-rank x) t)
+		(unless (= (array-dimension x axis)
+			   (array-dimension y axis))
+		  (return nil)))
+	      (dotimes (index (array-total-size x) t)
+		(unless (equalp (row-major-aref x index)
+				(row-major-aref y index))
+		  (return nil)))))
 	(t nil)))
diff --git a/code/print.lisp b/code/print.lisp
index efaf7d7c1..a86927029 100644
--- a/code/print.lisp
+++ b/code/print.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.9 1990/08/24 18:12:20 wlott Exp $
+;;;
 ;;; CMU Common Lisp printer.
 ;;;
 ;;; Written by Neal Feinberg, Bill Maddox, Steven Handerson, and Skef Wholey.
@@ -22,7 +24,7 @@
 
 (defvar *print-escape* T
   "Flag which indicates that slashification is on.  See the manual")
-(defvar *print-pretty* T
+(defvar *print-pretty* nil
   "Flag which indicates that pretty printing is to be used")
 (defvar *print-base* 10.
   "The output base for integers and rationals.")
@@ -224,50 +226,48 @@
 	   (>= currlevel (the fixnum *print-level*)))
       (write-char #\# stream)
       (typecase object
-	    (symbol
-	     (if *print-escape*
-		 (output-symbol object stream)
-		 (case *print-case*
-		   (:upcase (write-string (symbol-name object) stream))
-		   (:downcase
-		    (let ((name (symbol-name object)))
-		      (declare (simple-string name))
-		      (dotimes (i (length name))
-			(write-char (char-downcase (char name i)) stream))))
-		   (:capitalize
-		    (write-string (string-capitalize (symbol-name object))
-				  stream)))))
-	    ;; If a list, go through element by element, being careful
-	    ;; about not running over the printlength
-	    (list
-	     (output-list object stream (1+ currlevel)))
-	    (string
-	     (if *print-escape*
-		 (quote-string object stream)
-		 (write-string object stream)))
-	    (integer
-	     (output-integer object stream))
-	    (float
-	     (output-float object stream))
-	    (ratio
-	     (output-ratio object stream))
-	    (complex
-	     (output-complex object stream))
-	    (structure
-	     (output-structure object stream currlevel))
-	    (character
-	     (output-character object stream))
-	    (vector
-	     #+new-compiler
-	     (if (eql (%primitive get-type object) system:%code-type)
-		 (output-random object stream)
-		 (output-vector object stream))
-	     #-new-compiler
-	     (output-vector object stream))
-	    (array
-	     (output-array object stream (1+ currlevel))) 
-	    (t (output-random object stream)))))
-
+	(symbol
+	 (if *print-escape*
+	     (output-symbol object stream)
+	     (case *print-case*
+	       (:upcase (write-string (symbol-name object) stream))
+	       (:downcase
+		(let ((name (symbol-name object)))
+		  (declare (simple-string name))
+		  (dotimes (i (length name))
+		    (write-char (char-downcase (char name i)) stream))))
+	       (:capitalize
+		(write-string (string-capitalize (symbol-name object))
+			      stream)))))
+	;; If a list, go through element by element, being careful
+	;; about not running over the printlength
+	(list
+	 (output-list object stream (1+ currlevel)))
+	(string
+	 (if *print-escape*
+	     (quote-string object stream)
+	     (write-string object stream)))
+	(integer
+	 (output-integer object stream))
+	(float
+	 (output-float object stream))
+	(ratio
+	 (output-ratio object stream))
+	(complex
+	 (output-complex object stream))
+	(structure
+	 (output-structure object stream currlevel))
+	(character
+	 (output-character object stream))
+	(vector
+	 (output-vector object stream))
+	(array
+	 (output-array object stream (1+ currlevel)))
+	(system-area-pointer
+	 (output-sap object stream))
+	(weak-pointer
+	 (output-weak-pointer object stream))
+	(t (output-random object stream)))))
 
 
 ;;;; Symbol Printing Subfunctions
@@ -428,9 +428,9 @@
       (return (not (test sign)))
 
      OTHER ; Not potential number, see if funny chars...
-      (return (not (null (%primitive find-character-with-attribute
-				     name (1- index) len
-				     attributes funny-attribute))))
+      (return (not (null (%sp-find-character-with-attribute
+			  name (1- index) len
+			  attributes funny-attribute))))
      START
       (when (digitp)
 	(if (test letter)
@@ -778,10 +778,10 @@
 	(sub-output-integer quotient stream))
     ;; Then as each recursive call unwinds, turn the digit (in remainder) 
     ;; into a character and output the character.
-    (write-char (int-char (if (and (> remainder 9.)
-				   (> *print-base* 10.))
-			      (+ (char-int #\A) (- remainder 10.))
-			      (+ (char-int #\0) remainder)))
+    (write-char (code-char (if (and (> remainder 9.)
+				    (> *print-base* 10.))
+			       (+ (char-code #\A) (- remainder 10.))
+			       (+ (char-code #\0) remainder)))
 		stream)))
 
 
@@ -812,38 +812,53 @@
 
 ;;; Written by Steven Handerson
 ;;;  (based on Skef's idea)
-
-;;; BIGNUM-FIXNUM-DIVIDE-INPLACE wants the divisor to be of integer-length 19
-;;; or less.  1- the ideal power of the base for a divisor.
 ;;;
-(defparameter *fixnum-power--1*
-  '#(NIL NIL 17 10 8 7 6 5 5 4 4 4 4 4 3 3 3 3 3 3 3 3 3 3 3 3 3 2 2 2 2 2 2 2 2
-	 2))
-
-;;; The base raised to the ideal power.
+;;; Rewritten to remove assumptions about the length of fixnums for the
+;;; MIPS port by William Lott.
+;;; 
+
+;;; *BASE-POWER* holds the number that we keep dividing into the bignum for
+;;; each *print-base*.  We want this number as close to *most-positive-fixnum*
+;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)).
+;;; 
+(defparameter *base-power* (make-array 36))
+
+;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that
+;;; fit in the corresponding *base-power*.
+;;; 
+(defparameter *fixnum-power--1* (make-array 36))
+
+;;; PRINT-BIGNUM -- internal.
 ;;;
-(defparameter *base-power*
-  '#(NIL NIL 262144 177147 262144 390625 279936 117649 262144 59049 100000
-	 161051 248832 371293 38416 50625 65536 83521 104976 130321 160000
-	 194481 234256 279841 331776 390625 456976 19683 21952 24389 27000
-	 29791 32768 35937 39304 42875))
-
+;;; Print the bignum to the stream.  We first generate the correct value for
+;;; *base-power* and *fixnum-power--1* if we have not already.  Then we call
+;;; bignum-print-aux to do the printing.
+;;; 
 (defun print-bignum (big stream)
+  (unless (aref *base-power* *print-base*)
+    (do ((power-1 -1 (1+ power-1))
+	 (new-divisor *print-base* (* new-divisor *print-base*))
+	 (divisor 1 new-divisor))
+	((not (fixnump new-divisor))
+	 (setf (aref *base-power* *print-base*) divisor)
+	 (setf (aref *fixnum-power--1* *print-base*) power-1))))
   (bignum-print-aux (cond ((minusp big)
 			   (write-char #\- stream)
 			   (- big))
-			  (t (copy-xnum big)))
+			  (t big))
+		    (aref *base-power* *print-base*)
+		    (aref *fixnum-power--1* *print-base*)
 		    stream)
   big)
 
-(defun bignum-print-aux (big stream)
-  (multiple-value-bind (newbig fix)
-		       (bignum-fixnum-divide-inplace
-			big (aref *base-power* *print-base*))
+;;; BIGNUM-PRINT-AUX -- internal.
+;;;
+(defun bignum-print-aux (big divisor power-1 stream)
+  (multiple-value-bind (newbig fix) (truncate big divisor)
     (if (fixnump newbig)
 	(sub-output-integer newbig stream)
-	(bignum-print-aux newbig stream))
-    (do ((zeros (aref *fixnum-power--1* *print-base*) (1- zeros))
+	(bignum-print-aux newbig divisor power-1 stream))
+    (do ((zeros power-1 (1- zeros))
 	 (base-power *print-base* (* base-power *print-base*)))
 	((> base-power fix)
 	 (dotimes (i zeros) (write-char #\0 stream))
@@ -851,7 +866,6 @@
 
 
 
-;;;; Floating Point printing
 ;;;
 ;;;  Written by Bill Maddox
 ;;;
@@ -929,7 +943,8 @@
 (defvar *digits* "0123456789")
 
 (defvar *digit-string*
-  (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t))
+  (make-array 50 :element-type 'base-character :fill-pointer 0 :adjustable t
+	      :initial-element #\?)) ; ### Hack around make-array bug.
 
 (defun flonum-to-string (x &optional width fdigits scale fmin)
   (cond ((zerop x)
@@ -940,15 +955,12 @@
 	       (values s (length s) t (zerop fdigits) 0))
 	     (values "." 1 t t 0)))
 	(t
-	  (setf (fill-pointer *digit-string*) 0)
-	  (multiple-value-bind (sig exp)
-			       (integer-decode-float x)
-	    (if (typep x 'short-float)
-		;;20 and 53 are the number of bits of information in the
-		;;significand, less sign, of a short float and a long float
-		;;respectively.
-		(float-string sig exp 20 width fdigits scale fmin)
-		(float-string sig exp 53 width fdigits scale fmin))))))
+	 (setf (fill-pointer *digit-string*) 0)
+	 (multiple-value-bind (sig exp)
+			      (integer-decode-float x)
+	   (float-string sig exp (float-digits x) width fdigits scale
+			 fmin)))))
+
 
 (defun float-string (fraction exponent precision width fdigits scale fmin)
   (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
@@ -1062,40 +1074,34 @@
     (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
 
 
-(defconstant short-log10-of-2 0.30103s0)
-
 ;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
 ;;; new floating point number Z in the range (0.1, 1.0] and and exponent
 ;;; E such that Z * 10^E is (approximately) equal to the original number.
 ;;; There may be some loss of precision due the floating point representation.
 
-
-;;;
 (defun scale-exponent (x)
-  (if (typep x 'short-float)
-      (scale-expt-aux x 0.0s0 1.0s0 1.0s1 1.0s-1 short-log10-of-2)
-      (scale-expt-aux x 0.0l0 1.0l0 %long-float-ten
-		      %long-float-one-tenth long-log10-of-2)))
-
-
-(defun scale-expt-aux (x zero one ten one-tenth log10-of-2)
-  (multiple-value-bind (sig exponent)
-		       (decode-float x)
-    (declare (ignore sig))
-    (if (= x zero)
-	(values zero 1)
-	(let* ((ex (round (* exponent log10-of-2)))
-	       (x (if (minusp ex)		;For the end ranges.
-		      (* x ten (expt ten (- -1 ex)))
-		      (/ x ten (expt ten (1- ex))))))
-	  (do ((d ten (* d ten))
-	       (y x (/ x d))
-	       (ex ex (1+ ex)))
-	      ((< y one)
-	       (do ((m ten (* m ten))
-		    (z y (* z m))
-		    (ex ex (1- ex)))
-		   ((>= z one-tenth) (values z ex)))))))))
+  (let ((zero (float 0 x))
+	(one (float 1 x))
+	(ten (float 10 x))
+	(one-tenth (float 1/10 x))
+	(log10-of-2 (float (log 2l0 10) x)))
+    (multiple-value-bind (sig exponent)
+			 (decode-float x)
+      (declare (ignore sig))
+      (if (= x zero)
+	  (values zero 1)
+	  (let* ((ex (round (* exponent log10-of-2)))
+		 (x (if (minusp ex)		;For the end ranges.
+			(* x ten (expt ten (- -1 ex)))
+			(/ x ten (expt ten (1- ex))))))
+	    (do ((d ten (* d ten))
+		 (y x (/ x d))
+		 (ex ex (1+ ex)))
+		((< y one)
+		 (do ((m ten (* m ten))
+		      (z y (* z m))
+		      (ex ex (1- ex)))
+		     ((>= z one-tenth) (values z ex))))))))))
 
 
 ;;;; Entry point for the float printer.
@@ -1104,65 +1110,70 @@
 ;;; etc.  The argument is printed free-format, in either exponential or 
 ;;; non-exponential notation, depending on its magnitude.
 ;;;
-;;; NOTE:  When a number is to be printed in exponential format, it is scaled
-;;; in floating point.  Since precision may be lost in this process, the
+;;; NOTE: When a number is to be printed in exponential format, it is scaled in
+;;; floating point.  Since precision may be lost in this process, the
 ;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost.  The
 ;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
 ;;; integers of similar magnitude to that of the number being printed.  For
-;;; large exponents, the bignums really get out of hand.  When we switch to
-;;; IEEE format for long floats, this will significantly restrict the magnitude
-;;; of the largest allowable float.  This combined with microcoded bignum
-;;; arithmetic might make it attractive to handle exponential notation with
-;;; the same accuracy as non-exponential notation, using the method described
-;;; in the Steele and White paper.
+;;; large exponents, the bignums really get out of hand.  If bignum arithmetic
+;;; becomes reasonably fast and the exponent range is not too large, then it
+;;; might become attractive to handle exponential notation with the same
+;;; accuracy as non-exponential notation, using the method described in the
+;;; Steele and White paper.
 
-(defun output-float (x stream)
-  (if (typep x 'short-float)
-      (output-float-aux x stream 1.0s-3 1.0s7)
-      (output-float-aux x stream %long-float1l-3 %long-float1l7)))
 
+;;; PRINT-FLOAT-EXPONENT  --  Internal
+;;;
+;;;    Print the appropriate exponent marker for X and the specified exponent.
+;;;
+(defun print-float-exponent (x exp stream)
+  (declare (float x) (integer exp) (stream stream))
+  (let ((*print-radix* nil)
+	(plusp (plusp exp)))
+    (if (typep x *read-default-float-format*)
+	(unless (eql exp 0)
+	  (format stream "e~:[~;+~]~D" plusp exp))
+	(format stream "~A~:[~;+~]~D" 
+		(etypecase x
+		  (single-float #\f)
+		  (double-float #\d)
+		  (short-float #\s)
+		  (long-float #\L))
+		plusp exp))))
 
+(defun output-float (x stream)
+  (let ((x (cond ((minusp (float-sign x))
+		  (write-char #\- stream)
+		  (- x))
+		 (t
+		  x))))
+    (cond ((zerop x)
+	   (write-string "0.0" stream)
+	   (print-float-exponent x 0 stream))
+	  (t
+	   (output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))
+;;;  
 (defun output-float-aux (x stream e-min e-max)
-  (cond ((zerop x)
-	 (write-string "0.0" stream)
-	 (if (and (not (typep x *read-default-float-format*))
-		  (not (and (eq *read-default-float-format* 'single-float)
-			    (typep x 'short-float))))
-	     (write-string (if (typep x 'short-float) "s0" "L0") stream)))
-	(t (when (minusp x) 
-	     (write-char #\- stream)
-	     (setq x (- x)))
-	   (if (and (>= x e-min) (< x e-max))
-	       ;;free format
-	       (multiple-value-bind (str len lpoint tpoint)
-				    (flonum-to-string x)
-		 (declare (ignore len))
-		 (when lpoint (write-char #\0 stream))
-		 (write-string str stream)
-		 (when tpoint (write-char #\0 stream))
-		 (if (and (not (typep x *read-default-float-format*))
-			  (not (and (eq *read-default-float-format*
-					'single-float)
-				    (typep x 'short-float))))
-		     (write-string (if (typep x 'short-float) "s0" "L0")
-				   stream)))
-	       ;;exponential format 
-	       (multiple-value-bind (f ex)
-				    (scale-exponent x)
-		 (multiple-value-bind (str len lpoint tpoint)
-				      (flonum-to-string f nil nil 1)
-		   (declare (ignore len))
-		   (when lpoint (write-char #\0 stream))
-		   (write-string str stream)
-		   (when tpoint (write-char #\0 stream))
-		   (write-char (if (typep x *read-default-float-format*)
-				   #\E
-				   (if (typep x 'short-float) #\S #\L))
-			       stream)
-		   ;;must subtract 1 from exponent here, due to
-		   ;;the scale factor of 1 in call to FLONUM-TO-STRING
-		   (unless (minusp (1- ex)) (write-char #\+ stream))
-		   (output-integer (1- ex) stream)))))))
+  (if (and (>= x e-min) (< x e-max))
+      ;;free format
+      (multiple-value-bind (str len lpoint tpoint)
+			   (flonum-to-string x)
+	(declare (ignore len))
+	(when lpoint (write-char #\0 stream))
+	(write-string str stream)
+	(when tpoint (write-char #\0 stream))
+	(print-float-exponent x 0 stream))
+      ;;exponential format 
+      (multiple-value-bind (f ex)
+			   (scale-exponent x)
+	(multiple-value-bind (str len lpoint tpoint)
+			     (flonum-to-string f nil nil 1)
+	  (declare (ignore len))
+	  (when lpoint (write-char #\0 stream))
+	  (write-string str stream)
+	  (when tpoint (write-char #\0 stream))
+	  ;; subtract out scale factor of 1 passed to flonum-to-string
+	  (print-float-exponent x (1- ex) stream)))))
 
 
 ;;;; Output Character
@@ -1171,9 +1182,11 @@
 ;;; character must be slashified when being output.
 ;;;
 (defmacro funny-character-char-p (char)
-  `(and (not (zerop (char-bits ,char)))
-	(not (zerop (logand (aref character-attributes (char-code ,char))
-			    funny-attribute)))))
+;  (and (not (zerop (char-bits ,char)))
+;	(not (zerop (logand (aref character-attributes (char-code ,char))
+;			    funny-attribute))))
+  `(not (zerop (logand (aref character-attributes (char-code ,char))
+		       funny-attribute))))
 
 ;;; OUTPUT-CHARACTER  --  Internal
 ;;;
@@ -1183,23 +1196,15 @@
 ;;; itself to the stream.
 ;;;
 (defun output-character (char stream)
-  (let ((base (make-char char)))
-    (if *print-escape*
-	(let ((name (char-name base)))
-	  (write-string "#\\" stream)
-	  (macrolet ((frob (key string)
-		       `(when (char-bit char ,key)
-			  (write-string ,string stream))))
-	    (frob :control "CONTROL-")
-	    (frob :meta "META-")
-	    (frob :super "SUPER-")
-	    (frob :hyper "HYPER-"))
-	  (cond (name (write-string name stream))
-		(t 
-		 (when (funny-character-char-p char)
-		   (write-char #\\ stream))
-		 (write-char base stream))))
-	(write-char base stream))))
+  (if *print-escape*
+      (let ((name (char-name char)))
+	(write-string "#\\" stream)
+	(cond (name (write-string name stream))
+	      (t
+	       (when (funny-character-char-p char)
+		 (write-char #\\ stream))
+	       (write-char char stream))))
+      (write-char char stream)))
 
 
 
@@ -1211,35 +1216,9 @@
 ;;; below.
 
 (defun output-function-object (subr stream)
-  (let ((name (%primitive header-ref subr %function-name-slot)))
-    (case (%primitive get-vector-subtype subr)
-      (#.%function-entry-subtype
-       (if (stringp name)
-	   (format stream "Internal Function ~S" name)
-	   (format stream "Function ~S" name)))
-      (#.%function-closure-subtype
-       (if (eval:interpreted-function-p subr)
-	   (multiple-value-bind
-	       (def ignore name)
-	       (eval:interpreted-function-lambda-expression subr)
-	     (declare (ignore ignore))
-	     (let ((*print-level* 3))
-	       (format stream "Interpreted Function ~S" (or name def))))
-	   (format stream "Closure ~S"
-		   (%primitive header-ref name %function-name-slot))))
-      (#.%function-closure-entry-subtype
-       (format stream "Closure Entry ~S" name))
-      (#.%function-constants-subtype
-       (format stream "Function Constants ~S" name))
-      (#.%function-value-cell-subtype
-       (assert (= %function-value-cell-value-slot %function-name-slot))
-       (format stream "Indirect Value Cell ~S" name))
-      #|
-      (#.%function-funcallable-instance-subtype
-       (format stream "Funcallable Instance ~S" name))
-      |#
-      (t (error "Unknown function subtype.")))))
-
+  (let ((name (%primitive c::function-name subr)))
+    (write-string "Function " stream)
+    (prin1 name stream)))
 
 ;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below.  
 ;;; It outputs the numerical value of the low 28 bits of 
@@ -1258,9 +1237,58 @@
 
 (defun output-random (object stream)
   (write-string "#<" stream)
-  (if (compiled-function-p object)
-      (output-function-object object stream)
-      (let ((type (%primitive get-type object)))
-	(write-string "Pointer into Hell, level " stream)
-	(sub-output-integer type stream)))
+  (let ((lowtag (get-lowtag object)))
+    (case lowtag
+      ((#.vm:other-pointer-type #.vm:function-pointer-type)
+       (let ((type (get-type object)))
+	 (case type
+	   (#.vm:code-header-type
+	    (write-string "Code Object" stream))
+	   ((#.vm:function-header-type #.vm:closure-function-header-type)
+	    (output-function-object object stream))
+	   (#.vm:return-pc-header-type
+	    (write-string "Return PC Object" stream))
+	   (#.vm:closure-header-type
+	    (write-string "Closure Over " stream)
+	    (output-function-object (%primitive c::closure-function object)
+				    stream))
+	   (#.vm:value-cell-header-type
+	    (write-string "Value Cell" stream))
+	   (#.vm:unbound-marker-type
+	    (write-string "Unbound Marker" stream))
+	   (t
+	    (write-string "Unknown Object, type=" stream)
+	    (let ((*print-base* 16) (*print-radix* t))
+	      (output-integer type stream))))))
+      (#.vm:structure-pointer-type
+       (write-string "Structure?"))
+      (#.vm:list-pointer-type
+       (write-string "List?"))
+      (t
+       (write-string "Unknown Immediate Object, lowtag=" stream)
+       (let ((*print-base* 2) (*print-radix* t))
+	 (output-integer lowtag stream))
+       (write-string ", type=" stream)
+       (let ((*print-base* 16) (*print-radix* t))
+	 (output-integer (get-type object) stream)))))
   (finish-random object stream))
+
+
+(defun output-sap (sap stream)
+  (declare (type system-area-pointer sap))
+  (write-string "#<System-Area pointer: " stream)
+  (let ((*print-base* 16) (*print-radix* t))
+    (output-integer (sap-int sap) stream))
+  (write-char #\> stream))
+
+(defun output-weak-pointer (weak-pointer stream)
+  (declare (type weak-pointer weak-pointer))
+  (multiple-value-bind
+      (value validp)
+      (weak-pointer-value weak-pointer)
+    (cond (validp
+	   (write-string "#<Weak Pointer: " stream)
+	   (write value :stream stream)
+	   (write-char #\> stream))
+	  (t
+	   (write-string "#<Broken Weak Pointer>")))))
diff --git a/code/purify.lisp b/code/purify.lisp
index c41786d68..34912dc99 100644
--- a/code/purify.lisp
+++ b/code/purify.lisp
@@ -23,6 +23,22 @@
 ;;;
 (in-package 'lisp)
 
+
+(def-c-routine ("purify" %purify) (int)
+  (roots unsigned-long))
+
+(defun purify (&key root-structures)
+  (write-string "[Doing purification: ")
+  (force-output)
+  (without-gcing
+   (%purify (di::get-lisp-obj-address root-structures)))
+  (write-line "Done.]")
+  (force-output)
+  nil)
+
+
+#|
+
 (defun purify (&key root-structures)
   (declare (special lisp-environment-list))
   (setq lisp-environment-list NIL)
@@ -534,3 +550,5 @@
     (if (save file)
 	(quit)
 	(funcall root-function))))
+
+|#
diff --git a/code/reader.lisp b/code/reader.lisp
index 717b6c4f8..e2bd37606 100644
--- a/code/reader.lisp
+++ b/code/reader.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.3 1990/08/24 18:12:38 wlott Exp $
+;;;
 ;;; Spice Lisp Reader 
 ;;; Written by David Dill
 ;;; Package system interface by Lee Schumacher.
@@ -108,20 +110,20 @@
 (defmacro get-cat-entry (char rt)
   ;;only give this side-effect-free args.
   `(elt (the simple-vector (character-attribute-table ,rt))
-	(char-int ,char)))
+	(char-code ,char)))
 
 (defun set-cat-entry (char newvalue &optional (rt *readtable*))
   (setf (elt (the simple-vector (character-attribute-table rt))
-	     (char-int char))
+	     (char-code char))
 	newvalue))
 
 (defmacro get-cmt-entry (char rt)
   `(elt (the simple-vector (character-macro-table ,rt))
-	(char-int ,char)))
+	(char-code ,char)))
 
 (defun set-cmt-entry (char newvalue &optional (rt *readtable*))
   (setf (elt (the simple-vector (character-macro-table rt))
-	     (char-int char))
+	     (char-code char))
 	newvalue))
 
 (defun make-character-attribute-table ()
@@ -172,7 +174,7 @@
 (defvar secondary-attribute-table ())
 
 (defun set-secondary-attribute (char attribute)
-  (setf (elt (the simple-vector secondary-attribute-table) (char-int char))
+  (setf (elt (the simple-vector secondary-attribute-table) (char-code char))
 	attribute))
 
 
@@ -186,9 +188,9 @@
   (set-secondary-attribute #\+ #.constituent-sign)
   (set-secondary-attribute #\- #.constituent-sign)
   (set-secondary-attribute #\/ #.constituent-slash)  
-  (do ((i (char-int #\0) (1+ i)))
-      ((> i (char-int #\9)))
-    (set-secondary-attribute (int-char i) #.constituent-digit))
+  (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)
@@ -202,7 +204,7 @@
 
 (defmacro get-secondary-attribute (char)
   `(elt (the simple-vector secondary-attribute-table)
-	(char-int ,char)))
+	(char-code ,char)))
 
 
 
@@ -283,7 +285,7 @@
   (prepare-for-fast-read-char stream
     (do ((attribute-table (character-attribute-table *readtable*))
 	 (char (fast-read-char t) (fast-read-char t)))
-      ((/= (the fixnum (svref attribute-table (char-int char))) #.whitespace)
+      ((/= (the fixnum (svref attribute-table (char-code char))) #.whitespace)
        (done-with-fast-read-char)
        char))))
 
@@ -318,7 +320,7 @@
     (do ((ichar 0 (1+ ichar))
 	 (char))
 	((= ichar #O200))
-      (setq char (int-char ichar))
+      (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)))))
@@ -597,7 +599,7 @@
 ;;; return the character class for a char
 ;;;
 (defmacro char-class (char attable)
-  `(let ((att (svref ,attable (char-int ,char))))
+  `(let ((att (svref ,attable (char-code ,char))))
      (declare (fixnum att))
      (if (<= att #.terminating-macro)
 	 #.delimiter
@@ -607,7 +609,7 @@
 ;;; number
 ;;;
 (defmacro char-class2 (char attable)
-  `(let ((att (svref ,attable (char-int ,char))))
+  `(let ((att (svref ,attable (char-code ,char))))
      (declare (fixnum att))
      (if (<= att #.terminating-macro)
 	 #.delimiter
@@ -621,7 +623,7 @@
 ;;; floating number (assume that it is a digit if it could be)
 ;;;
 (defmacro char-class3 (char attable)
-  `(let ((att (svref ,attable (char-int ,char))))
+  `(let ((att (svref ,attable (char-code ,char))))
      (declare (fixnum att))
      (if possibly-rational
 	 (setq possibly-rational
@@ -1085,24 +1087,10 @@
 	  ;;should never happen:	
 	  (t (error "Internal error in floating point reader.")))))
 
+
 (defun make-float-aux (number divisor float-format)
-  (let ((fgcd (gcd number divisor)))
-    (when (/= fgcd 1)
-      (setq number (truncate number fgcd))
-      (setq divisor (truncate divisor fgcd))))
-  (when (= divisor 1)
-    (return-from make-float-aux (coerce number float-format)))
-  (let ((float-digits (case float-format
-			((short-float single-float) 37)
-			((double-float long-float) 307)
-			(t 307)))
-	(digits (round (integer-length number) (log 10 2))))
-    (cond ((<= digits float-digits)
-	   (/ (coerce number float-format)
-	      (coerce divisor float-format)))
-	  (T (let ((adj-amount (expt 10 (- digits float-digits))))
-	       (/ (coerce (round number adj-amount) float-format)
-		  (coerce (round divisor adj-amount) float-format)))))))
+  (coerce (/ number divisor) float-format))
+
 
 (defun make-ratio ()
   ;;assume read-buffer contains a legal ratio.  Build the number from
@@ -1168,7 +1156,7 @@
 		     :test #'char= :key #'car)))
     (if dpair
 	(setf (elt (the simple-vector (cdr dpair))
-		   (char-int sub-char))
+		   (char-code sub-char))
 	      function)
 	(error "~S is not a dispatch char." disp-char))))
 
@@ -1181,7 +1169,7 @@
 		     :test #'char= :key #'car)))
     (if dpair
 	(elt (the simple-vector (cdr dpair))
-	     (char-int sub-char))
+	     (char-code sub-char))
 	(error "~S is not a dispatch char." disp-char))))
 
 (defun read-dispatch-char (stream char)
@@ -1205,7 +1193,7 @@
 		       :test #'char= :key #'car)))
       (if dpair
 	  (funcall (elt (the simple-vector (cdr dpair))
-			(char-int sub-char))
+			(char-code sub-char))
 		   stream sub-char (if numargp numarg nil))
 	  (error "No dispatch table for dispatch char.")))))
 
diff --git a/code/save.lisp b/code/save.lisp
index 9b9f0568d..29b81f2b4 100644
--- a/code/save.lisp
+++ b/code/save.lisp
@@ -8,7 +8,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.1.1.5 1990/07/26 19:12:33 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.2 1990/08/24 18:13:22 wlott Exp $
 ;;;
 ;;; Dump the current lisp image into a core file.  All the real work is done
 ;;; be C.
diff --git a/code/seq.lisp b/code/seq.lisp
index 10f16043e..07a3895b1 100644
--- a/code/seq.lisp
+++ b/code/seq.lisp
@@ -48,7 +48,7 @@
   "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
   `(make-sequence-of-type (type-of ,sequence) ,length))
 
-(defmacro type-specifier (type)
+(defmacro type-specifier-atom (type)
   "Returns the broad class of which TYPE is a specific subclass."
   `(if (atom ,type) ,type (car ,type)))
 
@@ -59,10 +59,11 @@
 (defun make-sequence-of-type (type length)
   "Returns a sequence of the given TYPE and LENGTH."
   (declare (fixnum length))
-  (case (type-specifier type)
+  (case (type-specifier-atom type)
     (list (make-list length))
     ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
-    ((string simple-string) (make-string length))
+    ((string simple-string base-string simple-base-string)
+     (make-string length))
     (simple-vector (make-array length))
     ((array simple-array vector)
      (if (listp type)
@@ -101,19 +102,15 @@
 
 (defun length (sequence)
   "Returns an integer that is the length of SEQUENCE."
-  (%primitive length sequence))
-
-(defun list-length* (sequence)
-  (do ((count 0 (1+ count)))
-      ((atom sequence) count)
-    (declare (fixnum count))
-    (setq sequence (cdr sequence))))
+  (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 (type-expand type)))
+  (let ((type (kernel::type-expand type)))
     (cond ((subtypep type 'list)
 	   (make-list length :initial-element initial-element))
 	  ((subtypep type 'string)
@@ -532,10 +529,10 @@
   "Returns a new sequence of all the argument sequences concatenated together
    which shares no structure with the original argument sequences of the
    specified OUTPUT-TYPE-SPEC."
-  (case (type-specifier output-type-spec)
+  (case (type-specifier-atom output-type-spec)
     (list (apply #'concat-to-list* sequences))
     ((simple-vector simple-string vector string array simple-array
-		    bit-vector simple-bit-vector)
+		    bit-vector simple-bit-vector base-string simple-base-string)
      (apply #'concat-to-simple* output-type-spec sequences))
     (t (error "~S: invalid output type specification." output-type-spec))))
 
@@ -608,11 +605,11 @@
    result is a sequence such that element i is the result of applying FUNCTION
    to element i of each of the argument sequences."
   (let ((sequences (cons first-sequence more-sequences)))
-    (case (type-specifier output-type-spec)
+    (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)
+		    bit-vector simple-bit-vector base-string simple-base-string)
        (map-to-simple output-type-spec function sequences))
       (t (error "~S: invalid output type specifier." output-type-spec)))))
 
@@ -749,9 +746,10 @@
     (eval `#',object))
    ((numberp object)
     (case output-type-spec
-      (short-float (%primitive float-short object))
-      ((single-float float) (%primitive float-single object))
-      ((double-float long-float) (%primitive float-long object))
+      ((short-float single-float float)
+       (%single-float object))
+      ((double-float long-float)
+       (%double-float object))
       (complex
        (complex object))
       (t
@@ -759,43 +757,46 @@
    (t
     (typecase object
       (list
-       (case (type-specifier output-type-spec)
-	 ((simple-string string) (list-to-string* object))
+       (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 output-type-spec)
+       (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 output-type-spec)
+       (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 output-type-spec)
+       (case (type-specifier-atom output-type-spec)
 	 (list (vector-to-list* object))
-	 ((simple-string string) (vector-to-string* 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 output-type-spec)
+       (case (type-specifier-atom output-type-spec)
 	 (list (vector-to-list* object))
-	 (simple-string (string-to-simple-string* 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 output-type-spec)
+       (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))
@@ -803,9 +804,10 @@
 	  (vector-to-vector* object output-type-spec))
 	 (t (error "Can't coerce ~S to type ~S." object output-type-spec))))
       (vector
-       (case (type-specifier output-type-spec)
+       (case (type-specifier-atom output-type-spec)
 	 (list (vector-to-list* object))
-	 ((simple-string string) (vector-to-string* 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))
@@ -818,10 +820,10 @@
 (macrolet ((frob (name result access src-type &optional typep)
 		 `(defun ,name (object ,@(if typep '(type) ()))
 		    (do* ((index 0 (1+ index))
-			  (length (,(case src-type
-				      (:list 'list-length*)
-				      (:vector 'length))
-				   object))
+			  (length (length (the ,(case src-type
+						  (:list 'list)
+						  (:vector 'vector))
+					       object)))
 			  (result ,result))
 			 ((= index length) result)
 		      (declare (fixnum length index))
@@ -861,8 +863,7 @@
       object
       (with-array-data ((data object)
 			(start)
-			(end (%primitive header-ref object
-					 %array-fill-pointer-slot)))
+			(end (length object)))
 	(declare (simple-string data))
 	(subseq data start end))))
 
@@ -871,8 +872,7 @@
       object
       (with-array-data ((data object)
 			(start)
-			(end (%primitive header-ref object
-					 %array-fill-pointer-slot)))
+			(end (length object)))
 	(declare (simple-bit-vector data))
 	(subseq data start end))))
 
diff --git a/code/serve-event.lisp b/code/serve-event.lisp
index c6ac2df64..c7ab73168 100644
--- a/code/serve-event.lisp
+++ b/code/serve-event.lisp
@@ -32,6 +32,8 @@
   "*In-server* is set to T when the SIGMSG interrupt has been enabled
   in Server.")
 
+#|
+
 (defvar server-unique-object (cons 1 2)
   "Object thrown by the message interrupt handler.")
 
@@ -78,6 +80,7 @@
 	    (unless (eql gr mach:kern-success)
 	      (gr-error 'server gr)))))))
   mach:kern-success)
+|#
 
 
 ;;;; File descriptor IO noise.
@@ -279,6 +282,7 @@
   seconds) and then return, otherwise it will wait until something happens.
   Server returns T if something happened and NIL otherwise."
   ;; First, check any X displays for any pending events.
+  #+nil
   (dolist (d/h *display-event-handlers*)
     (let ((d (car d/h)))
       (when (xlib::event-listen d)
@@ -292,7 +296,8 @@
       (value readable writeable)
       (wait-for-event timeout)
     ;; Now see what it was (if anything)
-    (cond ((eq value server-unique-object)
+    (cond #+nil
+	  ((eq value server-unique-object)
 	   ;; The interrupt handler fired.
 	   (grab-message-loop)
 	   t)
@@ -349,19 +354,17 @@
 	  (unwind-protect
 	      (progn
 		;; Block message interrupts.
-		(multiple-value-bind
-		    (noise mask)
-		    (mach:unix-sigsetmask (mach:sigmask :sigmsg))
-		  (declare (ignore noise))
-		  (setf old-mask mask))
+		(setf old-mask (mach:unix-sigblock (mach:sigmask :sigmsg)))
 		;; Check for any pending messages, because we are only signaled
 		;; for newly arived messages. This must be done after the
 		;; unix-sigsetmask.
+		#+nil
 		(when (grab-message-loop)
 		  (return-from wait-for-event t))
 		;; Indicate that we are in the server.
 		(let ((*in-server* t))
 		  ;; Establish the interrupt handlers.
+		  #+nil
 		  (enable-interrupt mach:sigmsg #'ih-sigmsg)
 		  ;; Enable all interrupts.
 		  (mach:unix-sigsetmask 0)
@@ -369,8 +372,8 @@
 		  (mach:unix-select count read-mask write-mask except-mask
 				    timeout-sec timeout-usec)))
 	    ;; Restore interrupt handler state.
-	    (mach:unix-sigsetmask (mach:sigmask :sigmsg))
+	    #+nil
+	    (mach:unix-sigblock (mach:sigmask :sigmsg))
+	    #+nil
 	    (default-interrupt mach:sigmsg)
 	    (mach:unix-sigsetmask old-mask)))))))
-
-
diff --git a/code/stream.lisp b/code/stream.lisp
index a59b83484..d2c821dc3 100644
--- a/code/stream.lisp
+++ b/code/stream.lisp
@@ -7,6 +7,8 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.4 1990/08/24 18:14:16 wlott Exp $
+;;;
 ;;; Stream functions for Spice Lisp.
 ;;; Written by Skef Wholey and Rob MacLachlan.
 ;;;
@@ -190,25 +192,27 @@
 	 (index (stream-in-index stream)))
     (declare (fixnum index))
     (if (simple-string-p buffer)
-	(let ((nl (%primitive find-character buffer index in-buffer-length
-			      #\newline)))
+	(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))))
+			     (setf (stream-in-index stream)
+				   (1+ (the fixnum nl))))
 		      nil)
 	      (multiple-value-bind (str eofp)
 				   (funcall (stream-misc stream) stream
 					    :read-line eof-errorp eof-value)
-		(declare (simple-string str))
 		(if (= index in-buffer-length)
 		    (values str eofp)
-		    (values (prog1
-			     (concatenate 'simple-string
-					  (subseq buffer index in-buffer-length)
-					  str)
-			     (setf (stream-in-index stream) in-buffer-length))
-			    eofp)))))
-	(funcall (stream-misc stream) stream :read-line eof-errorp eof-value))))
+		    (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.
@@ -304,7 +308,8 @@
     (cond
      ((not in-buffer)
       (with-in-stream stream stream-n-bin buffer start numbytes eof-errorp))
-     ((not (eql (%primitive get-vector-access-code in-buffer) 3))
+     ((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))
@@ -773,7 +778,7 @@
        (declare (simple-string string) (fixnum current end))
        (if (= current end)
 	   (eof-or-lose stream arg1 arg2)
-	   (let ((pos (%primitive find-character string current end #\newline)))
+	   (let ((pos (position #\newline string :start current :end end)))
 	     (if pos
 		 (let* ((res-length (- (the fixnum pos) current))
 			(result (make-string res-length)))
@@ -908,7 +913,7 @@
  
 (defun fill-pointer-ouch (stream character)
   (let* ((buffer (fill-pointer-output-stream-string stream))
-	 (current (%primitive header-ref buffer %array-fill-pointer-slot))
+	 (current (fill-pointer buffer))
 	 (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))
@@ -924,7 +929,7 @@
 	      (setf offset-current current)
 	      (set-array-header buffer workspace new-length
 				current+1 0 new-length nil))
-	    (%primitive header-set buffer %array-fill-pointer-slot current+1))
+	    (setf (fill-pointer buffer) current+1))
 	(setf (schar workspace offset-current) character)))
     current+1))
 
@@ -932,7 +937,7 @@
 (defun fill-pointer-sout (stream string start end)
   (declare (simple-string string) (fixnum start end))
   (let* ((buffer (fill-pointer-output-stream-string stream))
-	 (current (%primitive header-ref buffer %array-fill-pointer-slot))
+	 (current (fill-pointer buffer))
 	 (string-len (- end start))
 	 (dst-end (+ string-len current)))
     (declare (fixnum current dst-end string-len))
@@ -951,7 +956,7 @@
 	      (setf offset-dst-end dst-end)
 	      (set-array-header buffer workspace new-length
 				dst-end 0 new-length nil))
-	    (%primitive header-set buffer %array-fill-pointer-slot dst-end))
+	    (setf (fill-pointer buffer) dst-end))
 	(%primitive byte-blt string start
 		    workspace offset-current offset-dst-end)))
     dst-end))
@@ -962,7 +967,7 @@
   (case operation
     (:charpos
      (let* ((buffer (fill-pointer-output-stream-string stream))
-	    (current (%primitive header-ref buffer %array-fill-pointer-slot)))
+	    (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=
diff --git a/code/symbol.lisp b/code/symbol.lisp
index 8c1870872..2bf98e669 100644
--- a/code/symbol.lisp
+++ b/code/symbol.lisp
@@ -29,7 +29,11 @@
 (defun makunbound (variable)
   "VARIABLE must evaluate to a symbol.  This symbol is made unbound,
   removing any value it may currently have."
-  (makunbound variable))
+  (set variable
+       (%primitive make-other-immediate-type
+		   0
+		   vm:unbound-marker-type))
+  variable)
 
 (defun symbol-value (variable)
   "VARIABLE must evaluate to a symbol.  This symbol's current special
@@ -82,19 +86,17 @@
 (defun %put (symbol indicator value)
   "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
   Returns VALUE."
-  (%primitive put symbol indicator value)
-#|  (do ((pl (symbol-plist symbol) (cddr pl)))
-      ((atom pl)
+  (do ((pl (symbol-plist symbol) (cddr pl)))
+      ((endp pl)
        (setf (symbol-plist symbol)
 	     (list* indicator value (symbol-plist symbol)))
        value)
-    (cond ((atom (cdr pl))
+    (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))))|#
-  )
+	   (return value)))))
 
 (defun remprop (symbol indicator)
   "Look on property list of SYMBOL for property with specified
@@ -125,8 +127,14 @@
 	  ((eq (car plist) indicator)
 	   (return (cadr plist))))))
 
-(defun %putf (x y z)
-  (%primitive putf x y z))
+(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)
diff --git a/code/time.lisp b/code/time.lisp
index 0b99f9bb1..031e4788a 100644
--- a/code/time.lisp
+++ b/code/time.lisp
@@ -22,6 +22,10 @@
   "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))
@@ -32,47 +36,29 @@
 
 ;;; Get-Internal-Real-Time  --  Public
 ;;;
-;;;
-(defun get-internal-real-time ()
-  "Return the real time in the internal time format.  This is useful for
-  finding elapsed time.  See Internal-Time-Units-Per-Second."
-  (let ((val (system:%primitive get-real-time)))
-    (when (eq val -1)
-      (error "Failed to get real time."))
-    val))
-
-#|
 (defun get-internal-real-time ()
   "Return the real time in the internal time format.  This is useful for
   finding elapsed time.  See Internal-Time-Units-Per-Second."
   (multiple-value-bind (result seconds useconds) (mach:unix-gettimeofday)
-    (if result (+ (* seconds internal-time-units-per-second) useconds)
+    (if result
+	(+ (* seconds internal-time-units-per-second)
+	   (truncate useconds micro-seconds-per-internal-time-unit))
 	(error "Unix system call gettimeofday failed: ~A"
 	       (mach:get-unix-error-msg seconds)))))
-|#
 
 ;;; Get-Internal-Run-Time  --  Public
 ;;;
-;;; PmGetTimes returns run time in microseconds.  Convert to jiffies.
-;;;
-(defun get-internal-run-time ()
-  "Return the run time in the internal time format.  This is useful for
-  finding CPU usage."
-  (let ((val (system:%primitive get-run-time)))
-    (when (eq val -1)
-      (error "Failed to obtain run time."))
-    val))
-
-#|
 (defun get-internal-run-time ()
   "Return the run time in the internal time format.  This is useful for
   finding CPU usage."
   (multiple-value-bind (result utime stime)
 		       (mach:unix-getrusage mach:rusage_self)
-    (if result (+ utime stime)
+    (if result
+	(values (truncate (+ utime stime)
+			  micro-seconds-per-internal-time-unit))
 	(error "Unix system call getrusage failed: ~A"
 	       (mach:get-unix-error-msg utime)))))
-|#
+
 
 ;;; Subtract from the returned Internal_Time to get the universal time.
 ;;; The offset between our time base and the Perq one is 2145 weeks and
diff --git a/code/tty-inspect.lisp b/code/tty-inspect.lisp
index e3c3e4acf..0a66b3206 100644
--- a/code/tty-inspect.lisp
+++ b/code/tty-inspect.lisp
@@ -31,6 +31,10 @@
 ;;;
 (defvar *tty-object-stack* ())
 
+;;; ### Copied from inspect.lisp.  Remove after it is up.
+(defparameter inspect-length 10)
+(defparameter inspect-level 1)
+
 (proclaim '(inline numbered-parts-p))
 (defun numbered-parts-p (parts)
   (second parts))
@@ -42,7 +46,9 @@
       (cdr (nth (+ n parts-offset) parts))
       (nth (+ n parts-offset) parts)))
 
-(defun tty-inspect (object)
+;;; ### Change name back to tty-inspect when we have the real inspector up.
+;;; 
+(defun inspect (object)
   (unwind-protect
       (input-loop object (describe-parts object) *standard-output*)
     (setf *tty-object-stack* nil)))
@@ -55,6 +61,7 @@
   (tty-display-object parts s)
   (loop
     (format s "~&> ")
+    (force-output)
     (let ((command (read))
 	  ;; Use 2 less than length because first 2 elements are bookkeeping.
 	  (parts-len-2 (- (length parts) 2)))
@@ -157,37 +164,29 @@
 (defun describe-structure-parts (object)
   (let ((dd-slots
 	 (c::dd-slots
-	  (ext:info type defined-structure-info
-		    (system:%primitive header-ref object
-				       system:%g-vector-structure-name-slot))))
+	  (ext:info type defined-structure-info (type-of object))))
 	(parts-list ()))
     (push (format nil "~s is a structure.~%" object) parts-list)
     (push t parts-list)
     (dolist (dd-slot dd-slots (nreverse parts-list))
       (push (cons (c::dsd-%name dd-slot)
-		  (system:%primitive header-ref object (c::dsd-index dd-slot)))
+		  (funcall (c::dsd-accessor dd-slot) object))
 	    parts-list))))
 
 (defun describe-function-parts (object)
-  (let ((object (if (= (system:%primitive get-vector-subtype object)
-		       system:%function-closure-subtype)
-		    (system:%primitive header-ref object
-				       system:%function-name-slot)
-		    object)))
+  (let* ((type (kernel:get-type object))
+	 (object (if (= type vm:closure-header-type)
+		     (kernel:%closure-function object)
+		     object)))
     (list (format nil "Function ~s.~%Argument List: ~a." object
-		  (system:%primitive header-ref object
-				     lisp::%function-entry-arglist-slot)
-		  #|###
-		  (system:%primitive header-ref object
-				     lisp::%function-defined-from-slot)
-		  ~%Defined from: ~a
-		  |#
+		  (lisp::%function-header-arglist object)
+		  ;; Defined from stuff used to be here.  Someone took it out.
 		  )
 	  t)))
 
 (defun describe-vector-parts (object)
   (list* (format nil "Object is a ~:[~;displaced ~]vector of length ~d.~%"
-		 (lisp::%displacedp object) (length object))
+		 (lisp::%array-displaced-p object) (length object))
 	 nil
 	 (coerce object 'list)))
 
@@ -196,6 +195,19 @@
 	 nil
 	 object))
 
+;;; ### Copied from inspect.lisp.  Remove when it is up.
+;;; 
+(defun index-string (index rev-dimensions)
+  (if (null rev-dimensions)
+      "[]"
+      (let ((list nil))
+	(dolist (dim rev-dimensions)
+	  (multiple-value-bind (q r)
+			       (floor index dim)
+	    (setq index q)
+	    (push r list)))
+	(format nil "[~D~{,~D~}]" (car list) (cdr list)))))
+
 (defun describe-array-parts (object)
   (let* ((length (min (array-total-size object) inspect-length))
 	 (reference-array (make-array length :displaced-to object))
@@ -203,7 +215,7 @@
 	 (parts ()))
     (push (format nil "Object is ~:[a displaced~;an~] array of ~a.~%~
                        Its dimensions are ~s.~%"
-		  (array-element-type object) (lisp::%displacedp object)
+		  (array-element-type object) (lisp::%array-displaced-p object)
 		  dimensions)
 	  parts)
     (push t parts)
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index 4f1c6eca4..d62a2c1da 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -10,114 +10,98 @@
 
 (in-package "USER")
 
-(c::%proclaim '(optimize (speed 2) (space 2) (c::brevity 2)))
-(setq *print-pretty* nil)
+(setf *new-compile* t)
 
-(with-compiler-log-file ("code:compile-lisp.log")
+(with-compiler-log-file ("target:compile-lisp.log")
 
 ;;; these guys need to be first.
 
-(comf "code:globals" :always-once t) ; For global variables.
-(comf "code:struct" :always-once t) ; For structures.
-
-;;; these guys can supposedly come in any order, but not really.
-;;; some are put at the end so macros don't run interpreted and stuff.
-
-(comf "code:serve-event")
-(comf "code:lispinit")
-(comf "code:error")
-(comf "code:alieneval")
-(comf "code:stream")
-(comf "code:arith")
-(comf "code:array")
-(comf "code:backq")
-(comf "code:c-call")
-(comf "code:char")
-(comf "code:list")
-;(comf "code:clx-ext")
-(comf "code:commandline")
-(comf "code:eval")
-(comf "code:debug-info")
-(comf "code:debug-int")
-(comf "code:debug")
-(comf "code:trace")
-(comf "code:extensions")
-(comf "code:fd-stream")
-(comf "code:fdefinition")
-(comf "code:filesys")
-(comf "code:format")
-(comf "code:hash")
-(comf "code:lfloatcon")
-(comf "code:load")
-(comf "code:miscop")
-(comf "code:package")
-(comf "code:rompstrops")
-(comf "code:pred")
-(comf "code:print")
-(comf "code:provide")
-(comf "code:query")
-(comf "code:rand")
-(comf "code:reader")
-(comf "code:rompnum")
-(comf "code:salterror")
-(comf "code:save")
-(comf "code:search-list")
-(comf "code:seq")
-(comf "code:sharpm")
-(comf "code:sort")
-(comf "code:type-boot")
-(comf "code:run-program")
-(comf "code:spirrat")
-(comf "code:xp")
-(comf "code:xp-patch")
-(comf "code:pprint")
-(comf "code:string")
-(comf "code:subtypep")
-(comf "code:symbol")
-(comf "code:syscall")
-(comf "code:sysmacs")
-(comf "code:time")
-(comf "code:foreign")
-(comf "c:proclaim")
+(comf "target:code/globals" :always-once t) ; For global variables.
+(comf "target:code/struct" :always-once t) ; For structures.
+
+
+;;; Assembly files.
+(comf "target:assembly/assem-rtns" :assem t)
+(comf "target:assembly/array" :assem t)
+(comf "target:assembly/bit-bash" :assem t)
+
+(comf "target:compiler/type")
+(comf "target:compiler/mips/vm-type")
+(comf "target:compiler/type-init")
+
+(comf "target:code/serve-event")
+(comf "target:code/lispinit")
+(comf "target:code/error")
+(comf "target:code/alieneval")
+(comf "target:code/stream")
+(comf "target:code/arith")
+(comf "target:code/array")
+(comf "target:code/backq")
+(comf "target:code/c-call")
+(comf "target:code/char")
+(comf "target:code/list")
+;(comf "target:code/clx-ext")
+(comf "target:code/commandline")
+(comf "target:code/eval")
+(comf "target:code/debug")
+(comf "target:code/trace")
+(comf "target:code/extensions")
+(comf "target:code/fd-stream")
+(comf "target:code/fdefinition")
+(comf "target:code/filesys")
+(comf "target:code/format")
+(comf "target:code/hash")
+;(comf "target:code/lfloatcon")
+(comf "target:code/load")
+;(comf "target:code/miscop")
+(comf "target:code/package")
+(comf "target:code/mipsstrops")
+(comf "target:code/pred")
+(comf "target:code/print")
+(comf "target:code/provide")
+(comf "target:code/query")
+(comf "target:code/rand")
+(comf "target:code/reader")
+(comf "target:code/mipsnum")
+(comf "target:code/salterror")
+;(comf "target:code/save")
+(comf "target:code/search-list")
+(comf "target:code/seq")
+(comf "target:code/sharpm")
+(comf "target:code/sort")
+(comf "target:code/type-boot")
+(comf "target:code/run-program")
+;(comf "target:code/spirrat")
+;(comf "target:code/xp")
+;(comf "target:code/xp-patch")
+;(comf "target:code/pprint")
+(comf "target:code/string")
+(comf "target:code/symbol")
+(comf "target:code/syscall")
+(comf "target:code/sysmacs")
+(comf "target:code/time")
+;(comf "target:code/foreign")
+(comf "target:compiler/proclaim")
+(comf "target:compiler/knownfun")
+(comf "target:code/debug-info")
 
 ;;; Later so that miscellaneous structures are defined (not crucial, but nice.)
-(comf "code:describe")
-;(comf "code:inspect")
-(comf "code:tty-inspect")
-
-(comf "code:purify")
-(comf "code:gc")
-(comf "code:misc")
-(comf "code:format-time")
-(comf "code:parse-time")
-
-(comf "code:internet")
-(comf "code:wire")
-(comf "code:remote")
-
-(comf "assem:ropdefs")
-(comf "assem:rompconst")
-(comf "assem:disassemble")
-#+new-compiler
-(comf "assem:assem")
-#+new-compiler
-(comf "assem:assembler")
-
-(comf "code:machdef")
-(comf "code:mmlispdefs")
-(comf "icode:machdefs")
-(comf "icode:netnamedefs")
-
-(let ((system:*alien-eval-when* '(compile eval)))
-  (unless (probe-file "icode:machuser.nfasl")
-    (load "icode:machmsgdefs.lisp")
-    (comf "icode:machuser"))
-  
-  (unless (probe-file "icode:netnameuser.nfasl")
-    (load "icode:netnamemsgdefs.lisp")
-    (comf "icode:netnameuser")))
+(comf "target:code/describe")
+;(comf "target:code/inspect")
+(comf "target:code/tty-inspect")
+
+;(comf "target:code/purify")
+;(comf "target:code/gc")
+(comf "target:code/misc")
+(comf "target:code/format-time")
+(comf "target:code/parse-time")
+
+(comf "target:code/internet")
+(comf "target:code/wire")
+(comf "target:code/remote")
+
 
-(comf "code:constants")
+;(comf "target:code/constants")
 
 ;;; Compile basic macros that we assume are already in the compilation
 ;;; environment.  We inhibit compile-time definition to prevent these functions
@@ -127,11 +111,11 @@
 ;;; definition of a macro which uses itself.
 ;;;
 (let ((c:*compile-time-define-macros* nil))
-  (comf "code:defstruct")
-  (comf "code:defmacro")
-  (comf "code:macros")
-  (comf "code:defrecord")
+  (comf "target:code/defstruct")
+  (comf "target:code/defmacro")
+  (comf "target:code/macros")
+  (comf "target:code/defrecord")
   
-  (comf "c:globaldb"))
+  (comf "target:compiler/globaldb"))
 
 ); with-compiler-log-file
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index a9d83d236..a2d857546 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -12,24 +12,27 @@
 ;;; the resulting core image.  It writes "lisp.core" in the DEFAULT-DIRECTORY.
 ;;;
 
-
-#| Can't eval conditionals now...
-;;; Setup some packages.
+;;; Define a bunch of search lists relative to lisp:
 ;;;
-(unless (eq *package* (find-package "USER"))
-  (error "Set *package* to the User package and try again."))
-|#
+(setf (ext:search-list "code:") '("lisp:code/"))
+(setf (ext:search-list "c:") '("lisp:compiler/"))
+(setf (ext:search-list "mips:") '("c:mips/"))
+(setf (ext:search-list "assem:") '("lisp:assembly/"))
+(setf (ext:search-list "hem:") '("lisp:hemlock/"))
+
+;;; This must be here, because it's where assert-user-package is defined.
+(load "code:save")
+
+;;; Make sure the core will start up in the user package.
+(lisp::assert-user-package)
 
-(in-package "CLOS" :nicknames '("PCL"))
-(in-package "USER" :use '("LISP" "EXTENSIONS" "CONDITIONS" "DEBUG" "CLOS"))
-(in-package "HEMLOCK")
+;;; We want to be in the LISP package for the rest of the file.
 (in-package "LISP")
-#|
-;;; Must load this here, instead of before loading this file, otherwise
-;;; SEARCH-LIST is unknown.
+
+;;; Make sure the package structure is correct.
 ;;;
-(load "/afs/cs/project/clisp/new-compiler/logical-names.lisp")
-|#
+(load "code:exports")
+
 ;;; Get some data on this core.
 ;;;
 (write-string "What is the current lisp-implementation-version? ")
@@ -42,67 +45,62 @@
 (force-output)
 (set '*hemlock-version* (read-line))
 
-;;;
 ;;; Keep us entertained...
 (setq *load-verbose* t)
 
-(export 'ed)
-
-(load "code:lfloatcon")
-(load "code:spirrat")
-(load "code:foreign")
+;;; Load random code sources.
+;(load "code:lfloatcon")
+;(load "code:spirrat")
 (load "code:format-time")
 (load "code:parse-time")
-;(load "code:xp-patch")
-(load "assem:ropdefs")
-(load "assem:rompconst")
-(load "assem:disassemble")
+(load "code:purify")
+(load "code:commandline")
+(load "code:sort")
+(load "code:time")
+(load "code:tty-inspect")
+(load "code:describe")
+(load "code:rand")
+(load "code:trace")
+(load "code:weak")
+(load "code:sysmacs")
+(load "code:pprint")
+(load "code:run-program")
 
+;;; Load the compiler.
 (load "c:loadcom.lisp")
 
-(setq lisp::original-lisp-environment NIL)
-
-
-;;; Load the symbol table information for the Lisp start up code.
-;;; Used by CLX for the C routine to connect to the X11 server.
-;;;
-(load-foreign nil '("-lc") "/usr/cs/bin/ld"
-	      (namestring (truename "build:boot/lisp")))
-
-;;; This has to occur after the call to LOAD-FOREIGN.
-;;;
-(load "code:run-program")
-
+;;; Load the pretty printer after the compiler, 'cause it compiles stuff
+;;; at load time.
+(load "code:xp")
+(pprint-init)
 
+#|
 ;;; CLX.
 ;;;
-#+clx(progn
 (load "clx:defsystem")
-(setf (symbol-function 'xlib::clx-foreign-files) #'list); #### Hack...
-(xlib::load-clx (pathname "clx:"))
-)
+(load-clx (pathname "clx:"))
 
-#|
 ;;; A hack to fix a bug in the X11 R3 server.  This should go away when
 ;;; the server is fixed.
 ;;;
 (load "/afs/cs/project/clisp/systems-work/font-patch")
 |#
 
-;;; Stick these after LOAD-FORIEGN but before Hemlock.
+;;; Stick these before Hemlock.
 ;;;
 (load "code:internet")
 (load "code:wire")
 (load "code:remote")
 
-#+hemlock(progn
 ;;; Hemlock.
 ;;;
-(load "hem:rompsite") ;Contains site-init stuff called at load time.
 (load "hem:load-hem.lisp")
+(load "hem:rompsite") ;Contains site-init stuff called at load time.
 (hi::build-hemlock)
 
 #|
+Don't install any dir translations, 'cause we want the real things.
+
 ;;; Setup definition editing defaults to look in the stable AFS directory.
 ;;; The first translation says what we want most clearly, but we require
 ;;; the others due to symbol links.
@@ -127,11 +125,8 @@
 				    "/afs/cs/project/clisp/systems/")
 (ed::add-definition-dir-translation "/usr2/lisp/"
 				    "/afs/cs/project/clisp/systems/")
-|#
 
-); #+hemlock progn
 
-#|
 ;;; PCL.
 ;;;
 (load "pcl:defsys")
@@ -142,7 +137,7 @@
 ;;; Load these after PCL.
 ;;;
 ;(load "code:inspect")
-(load "code:tty-inspect")
+;(load "code:tty-inspect")
 
 
 ;;; There should be no search lists defined in a full core.
@@ -152,22 +147,26 @@
 
 ;;; Okay, build the thing!
 ;;;
-(in-package "USER")
-(progn 
-  (setq + NIL)
-  (setq * NIL)
-  (setq ++ NIL)
-  (setq ** NIL)
-  (setq +++ NIL)
-  (setq *** NIL)
+(progn
+  (setq - nil)
+  (setq + nil)
+  (setq * nil)
+  (setq / nil)
+  (setq ++ nil)
+  (setq ** nil)
+  (setq // nil)
+  (setq +++ nil)
+  (setq *** nil)
+  (setq /// nil)
   (setq *load-verbose* nil)
   (setq *info-environment*
 	(list (make-info-environment :name "Working")
 	      (compact-info-environment (car *info-environment*))))
   (save-lisp (namestring (merge-pathnames "lisp.core" (default-directory)))
 	     :purify t
+	     :init-function #'initial-init-function
 	     :root-structures `(ed
-				#|,hi::*global-command-table*|#
+				,hi::*global-command-table*
 				lisp::%top-level
 				extensions:save-lisp
 				,lisp::fop-codes
-- 
GitLab