diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index 69b6c6911a99c690d7d12845bebda94f4d2e8175..db2928e0c105f9e897efcf7d82598844199ffd19 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -1,4 +1,4 @@
-;;; -*- Log: code.log; Package: C -*-
+;;; -*- Package: KERNEL -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.37.1.1 1993/01/15 15:27:08 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.37.1.2 1993/02/08 22:20:58 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -15,7 +15,7 @@
 ;;; Written by Rob MacLachlan, William Lott and Skef Wholey.
 ;;;
 (in-package "LISP")
-(export '(defstruct copy-structure))
+(export '(defstruct copy-structure structure-object))
 (in-package "KERNEL")
 (export '(
 	  default-structure-print make-structure-load-form 
@@ -28,11 +28,16 @@
 	  defstruct-description dd-name dd-default-constructor dd-copier
 	  dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length
 	  defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type
-	  dsd-index dsd-raw-type dsd-read-only))
+	  dsd-index dsd-raw-type dsd-read-only undefine-structure))
 
 
 ;;;; Structure frobbing primitives.
 
+#+ns-boot 
+(defun %instancep (x)
+  (structurep x))
+
+#-ns-boot
 (defun %make-instance (length)
   "Allocate a new instance with LENGTH data slots."
   (declare (type index length))
@@ -41,18 +46,23 @@
 (defun %instance-length (instance)
   "Given an instance, return its length."
   (declare (type instance instance))
+  #+ns-boot
+  (structure-length instance)
+  #-ns-boot
   (%instance-length instance))
 
 (defun %instance-ref (instance index)
   "Return the value from the INDEXth slot of INSTANCE.  This is SETFable."
+  #+ns-boot
+  (structure-ref instance index)
+  #-ns-boot
   (%instance-ref instance index))
 
+#-ns-boot (progn
 (defun %instance-set (instance index new-value)
   "Set the INDEXth slot of INSTANCE to NEW-VALUE."
   (setf (%instance-ref instance index) new-value))
 
-(defsetf %instance-ref %instance-set)
-
 (defun %raw-ref-single (vec index)
   (declare (type index index))
   (%raw-ref-single vec index))
@@ -69,21 +79,32 @@
   (declare (type index index))
   (%raw-set-double vec index val))
 
-(defsetf %raw-ref-single %raw-set-single)
-(defsetf %raw-ref-double %raw-set-double)
+); #-ns-boot progn
 
 (defun %instance-layout (instance)
+  #+ns-boot
+  (layout-of instance)
+  #-ns-boot
   (%instance-layout instance))
 
+#-ns-boot
 (defun %set-instance-layout (instance new-value)
   (%set-instance-layout instance new-value))
 
+(defsetf %instance-ref %instance-set)
+(defsetf %raw-ref-single %raw-set-single)
+(defsetf %raw-ref-double %raw-set-double)
 (defsetf %instance-layout %set-instance-layout)
-
 
 ;;; This version of Defstruct is implemented using Defstruct, and is free of
 ;;; Maclisp compatability nonsense.  For bootstrapping, you're on your own.
 
+#-ns-boot
+;;; Define the STRUCTURE-OBJECT class as a subclass of INSTANCE.
+;;;
+(defstruct (structure-object (:alternate-metaclass instance)))
+
+
 ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a
 ;;; structure type.
 ;;;
@@ -117,6 +138,13 @@
   ;; The arguments to the :INCLUDE option, or NIL if no included structure.
   (include nil :type list)
   ;;
+  ;; The arguments to the :ALTERNATE-METACLASS option (an extension used to
+  ;; define structure-like objects with an arbitrary superclass and that may
+  ;; not have STRUCTURE-CLASS as the metaclass.)  Syntax is:
+  ;;    (superclass-name metaclass-name metaclass-constructor)
+  ;;
+  (alternate-metaclass nil :type list)
+  ;;
   ;; list of defstruct-slot-description objects for all slots (including
   ;; included ones.)
   (slots () :type list)
@@ -137,7 +165,7 @@
   (named nil :type boolean)
   ;;
   ;; Any INITIAL-OFFSET option on this direct type.
-  (offset nil :type index))
+  (offset nil :type (or index null))
   ;;
   ;; The next five slots are only meaningful in real default structures (i.e.
   ;; dd-type = structure), since they are recognizably typed objects (classes.)
@@ -186,7 +214,7 @@
 (defun compiler-layout-or-lose (name)
   (let ((res (info type compiler-layout name)))
     (cond ((not res)
-	   (error "Inherited class not yet defined: ~S" name))
+	   (error "Class not yet defined or was undefined: ~S" name))
 	  ((not (defstruct-description-p (layout-info res)))
 	   (error "Inherited class is not a STRUCTURE-CLASS: ~S" name))
 	  (t res))))
@@ -262,14 +290,14 @@
        If true, no setter function is defined for this slot."
 
   (let* ((defstruct (parse-name-and-options
-		     (if (atom options)
+		     (if (atom name-and-options)
 			 (list name-and-options)
 			 name-and-options))) 
 	 (name (dd-name defstruct)))
     (when (stringp (car slot-descriptions))
       (setf (dd-doc defstruct) (pop slot-descriptions)))
     (dolist (slot slot-descriptions)
-      (allocate-1-slot (parse-1-dsd defstruct slot)))
+      (allocate-1-slot defstruct (parse-1-dsd defstruct slot)))
     (if (eq (dd-type defstruct) 'structure)
 	(let ((inherits (inherits-for-structure defstruct)))
 	  `(progn
@@ -324,6 +352,8 @@
        (when (dd-include defstruct)
 	 (error "Can't have more than one :INCLUDE option."))
        (setf (dd-include defstruct) args))
+      (:alternate-metaclass
+       (setf (dd-alternate-metaclass defstruct) args))
       (:print-function
        (destructuring-bind (&optional (fun 'default-structure-print)) args
 	 (setf (dd-print-function defstruct) fun)))
@@ -356,14 +386,14 @@
 ;;;
 (defun parse-name-and-options (name-and-options)
   (destructuring-bind (name &rest options) name-and-options
-    (let ((defstruct (make-defstruct-description :name name)))
+    (let ((defstruct (make-defstruct-description name)))
       (dolist (option options)
 	(cond ((consp option)
 	       (parse-1-option option defstruct))
 	      ((eq option :named)
 	       (setf (dd-named defstruct) t))
 	      ((member option '(:constructor :copier :predicate :named))
-	       (parse-1-option (list option)))
+	       (parse-1-option (list option) defstruct))
 	      (t
 	       (error "Unrecognized DEFSTRUCT option: ~S" option))))
 
@@ -383,7 +413,7 @@
 	  (when offset (incf (dd-length defstruct) offset)))))
 
       (when (dd-include defstruct)
-	(do-include-stuff defstruct))
+	(do-inclusion-stuff defstruct))
 
       defstruct)))
 
@@ -423,11 +453,13 @@
 
     (let* ((aname (concat-pnames (dd-conc-name defstruct) name))
 	   (existing (info function accessor-for aname)))
-      (if (and existing
-	       (string= (dsd-name (find aname (dd-slots existing)
-					:key #'dsd-accessor))
-			name)
-	       (member (dd-name existing) (dd-includes defstruct)))
+      (if #-ns-boot
+	  (and (structure-class-p existing)
+	       (not (eq (class-name existing) (dd-name defstruct)))
+	       (string= (dsd-%name (find aname (dd-slots existing)
+					 :key #'dsd-accessor))
+			name))
+	  #+ns-boot nil
 	  (setf (dsd-accessor islot) nil)
 	  (setf (dsd-accessor islot) aname)))
     
@@ -443,8 +475,8 @@
 	  (setf (dsd-read-only islot) t)
 	  (when (dsd-read-only islot)
 	    (error "Slot ~S must be read-only in subtype ~S." name
-		   (dd-name dsd)))))
-    dsd))
+		   (dsd-name islot)))))
+    islot))
 
 
 ;;; ALLOCATE-1-SLOT  --  Internal
@@ -460,7 +492,7 @@
 	(raw-type words)
 	(cond ((not (eq (dd-type defstruct) 'structure))
 	       (values nil nil))
-	      ((and (subtypep type '(usigned-byte 32))
+	      ((and (subtypep type '(unsigned-byte 32))
 		    (not (subtypep type 'fixnum)))
 	       (values 'unsigned-byte 1))
 	      ((subtypep type 'single-float)
@@ -494,17 +526,17 @@
 (defun do-inclusion-stuff (defstruct)
   (destructuring-bind (included-name &rest modified-slots)
 		      (dd-include defstruct)
-    (let ((type (dd-type defstruct))
-	  (included-structure
-	   (if (eq type 'structure)
-	       (layout-info (compiler-layout-or-lose included-name))
-	       (typed-structure-info-or-lose included-name))))
+    (let* ((type (dd-type defstruct))
+	   (included-structure
+	    (if (eq type 'structure)
+		(layout-info (compiler-layout-or-lose included-name))
+		(typed-structure-info-or-lose included-name))))
       (unless (and (eq type (dd-type included-structure))
 		   (type= (specifier-type (dd-element-type included-structure))
 			  (specifier-type (dd-element-type defstruct))))
 	(error ":TYPE option mismatch between structures ~S and ~S."
 	       (dd-name defstruct) included-name))
-
+      
       (incf (dd-length defstruct) (dd-length included-structure))
       (when (eq (dd-type defstruct) 'structure)
 	(unless (dd-print-function defstruct)
@@ -515,7 +547,7 @@
 		(dd-make-load-form-fun included-structure)))
 	(setf (dd-raw-index defstruct) (dd-raw-index included-structure))
 	(setf (dd-raw-length defstruct) (dd-raw-length included-structure)))
-
+      
       (dolist (islot (dd-slots included-structure))
 	(let* ((iname (dsd-name islot))
 	       (modified (or (find iname modified-slots
@@ -577,7 +609,7 @@
 (defun create-vector-constructor
        (defstruct cons-name arglist vars types values) 
   (let ((temp (gensym)))
-    `(defun ,cons-name ,args
+    `(defun ,cons-name ,arglist
        (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
 			  vars types))
        (let ((,temp (make-array ,(dd-length defstruct)
@@ -595,10 +627,10 @@
   (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
     (dolist (x (find-name-indices defstruct))
       (setf (elt vals (cdr x)) `',(car x)))
-    (loop for dsd in (dd-slots defstruct) and for val in values do
+    (loop for dsd in (dd-slots defstruct) and val in values do
       (setf (elt vals (dsd-index dsd)) val))
 
-    `(defun ,cons-name ,args
+    `(defun ,cons-name ,arglist
        (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
 			  vars types))
        (list ,@vals))))
@@ -612,7 +644,9 @@
        (let ((,temp (truly-the ,(dd-name defstruct)
 			       (%make-instance ,(dd-length defstruct)))))
 	 (setf (%instance-layout ,temp)
-	       ',(info type compiler-layout (dd-name defstruct)))
+	       (load-time-value
+		(class-layout
+		 (find-class ',(dd-name defstruct)))))
 	 ,@(when (dd-raw-index defstruct)
 	     `((setf (%instance-ref ,temp ,(dd-raw-index defstruct))
 		     (make-array ,(dd-raw-length defstruct)
@@ -623,26 +657,27 @@
 			       ,temp)
 			      ,value))
 		   (dd-slots defstruct)
-		   values))))
+		   values)))))
 
 
 ;;; CREATE-KEYWORD-CONSTRUCTOR   --  Internal
 ;;;
 ;;;    Create a default (non-BOA) keyword constructor.
 ;;;
-(defun create-default-constructor (defstruct creator)
+(defun create-keyword-constructor (defstruct creator)
   (collect ((arglist (list '&key))
 	    (types)
-	    (values))
+	    (vals))
     (dolist (slot (dd-slots defstruct))
       (let ((dum (gensym))
 	    (name (dsd-name slot)))
-	(arglist `((,(intern (string name) "KEYWORD") dum)))
-	(types (dsd-type wlot))
-	(values dum)))
+	(arglist `((,(intern (string name) "KEYWORD") ,dum)
+		   ,(dsd-default slot)))
+	(types (dsd-type slot))
+	(vals dum)))
     (funcall creator
-	     defstruct (dd-constructor defstruct)
-	     arglist values types values)))
+	     defstruct (dd-default-constructor defstruct)
+	     (arglist) (vals) (types) (vals))))
 
 
 ;;; CREATE-BOA-CONSTRUCTOR  --  Internal
@@ -650,13 +685,13 @@
 ;;;    Given a structure and a BOA constructor spec, call Creator with the
 ;;; appropriate args to make a constructor.
 ;;;
-(defun grovel-boa-constructor (defstruct boa creator)
+(defun create-boa-constructor (defstruct boa creator)
   (multiple-value-bind (req opt restp rest keyp keys allowp aux)
 		       (kernel:parse-lambda-list boa)
     (collect ((arglist)
 	      (vars)
 	      (types))
-      (labels ((get-slot (name default)
+      (labels ((get-slot (name)
 		 (let ((res (find name (dd-slots defstruct) :test #'string=
 				  :key #'dsd-name)))
 		   (if res
@@ -695,14 +730,14 @@
 	  (dolist (key keys)
 	    (if (consp key)
 		(destructuring-bind (wot &optional (def nil def-p))
-				    arg
+				    key
 		  (let ((name (if (consp wot)
 				  (destructuring-bind (key var) wot
 				    (declare (ignore key))
 				    var)
 				  wot)))
 		    (multiple-value-bind (type slot-def) (get-slot name)
-		      (arglist `(,wot ,(if def-p ,def ,slot-def)))
+		      (arglist `(,wot ,(if def-p def slot-def)))
 		      (vars name)
 		      (types type))))
 		(do-default key))))
@@ -723,7 +758,7 @@
 	       (mapcar #'(lambda (slot)
 			   (or (find (dsd-name slot) (vars))
 			       (dsd-default slot)))
-		       (dsd-slots defstruct))))))
+		       (dd-slots defstruct))))))
 
 
 ;;; DEFINE-CONSTRUCTORS  --  Internal
@@ -747,7 +782,7 @@
 	      (boa-p (push constructor boas))
 	      (t (push name defaults)))))
 
-    (when no-construtors
+    (when no-constructors
       (when (or defaults boas)
 	(error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs."))
       (return-from define-constructors ()))
@@ -758,7 +793,7 @@
     (collect ((res))
       (when defaults
 	(let ((cname (first defaults)))
-	  (setf (dd-constructor defstruct) cname)
+	  (setf (dd-default-constructor defstruct) cname)
 	  (res (create-keyword-constructor defstruct creator))
 	  (dolist (other-name (rest defaults))
 	    (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
@@ -832,8 +867,7 @@
 ;;;
 (defun define-accessors (defstruct)
   (collect ((stuff))
-    (let* ((type (dd-type defstruct))
-	   (ltype (dd-lisp-type defstruct)))
+    (let ((ltype (dd-lisp-type defstruct)))
       (dolist (slot (dd-slots defstruct))
 	(let ((name (dsd-accessor slot))
 	      (index (dsd-index slot))
@@ -846,8 +880,8 @@
 	    (stuff
 	     `(defun (setf ,name) (new-value structure)
 		(declare (type ,ltype structure) (type ,slot-type new-value))
-		(setf (elt structure ,index) new-value))))))))
-    (stuff))
+		(setf (elt structure ,index) new-value)))))))
+    (stuff)))
 
 
 ;;; Define-Copier returns the definition for a copier function of a typed
@@ -883,6 +917,7 @@
 ;;; general-case code.  Since the compiler will normally open-code accesors,
 ;;; the (minor) efficiency penalty is not a concern.
 
+#-ns-boot(progn
 ;;; Typep-To-Layout  --  Internal
 ;;;
 ;;;    Return true if Obj is an object of the structure type corresponding to
@@ -959,7 +994,7 @@
 	  (t
 	   (register-layout layout nil nil)))
 
-    (setf (find-class (dsd-name info)) class)
+    (setf (find-class (dd-name info)) class)
       
     (dolist (slot (dd-slots info))
       (let ((dsd slot))
@@ -993,6 +1028,7 @@
 
   (undefined-value))
 
+); #-ns-boot progn
 
 ;;;; Redefinition stuff:
 
@@ -1005,10 +1041,14 @@
 ;;; referenced layout.)
 ;;;
 (defun ensure-structure-class (info inherits old-context new-context)
-  (multiple-value-bind (class old-layout)
-		       (insured-find-class (dd-name info)
-					   (find-class 'structure-class)
-					   #'make-structure-class)
+  (multiple-value-bind
+      (class old-layout)
+      (destructuring-bind (&optional name (class 'structure-class)
+				     (constructor 'make-structure-class))
+			  (dd-alternate-metaclass info)
+	(declare (ignore name))
+	(insured-find-class (dd-name info) (find-class class)
+			    (fdefinition constructor)))
     (let ((new-layout (make-layout :class class
 				   :inherits inherits
 				   :inheritance-depth (length inherits)
@@ -1038,7 +1078,7 @@
 	 (nnames (mapcar #'dsd-name nslots)))
     (collect ((moved)
 	      (retyped))
-      (dolist (name (set-intersection onames nnames))
+      (dolist (name (intersection onames nnames))
 	(let ((os (find name oslots :key #'dsd-name))
 	      (ns (find name nslots :key #'dsd-name)))
 	  (unless (subtypep (dsd-type ns) (dsd-type os))
@@ -1057,12 +1097,13 @@
 ;;; different slots than in the currently loaded version.
 ;;;
 (defun redefine-structure-warning (class old new)
-  (declare (type defstruct-description old new) (type structure-class class))
+  (declare (type defstruct-description old new) (type class class)
+	   (ignore class))
   (let ((name (dd-name new)))
-    (multiple-value-bind (moved renamed retyped new deleted)
+    (multiple-value-bind (moved retyped deleted)
 			 (compare-slots old new)
       (when (or moved retyped deleted)
-	(compiler-warning 
+	(warn 
 	 "Incompatibly redefining slots of structure class ~S~@
 	  Make sure any uses of affected accessors are recompiled:~@
 	  ~@[  These slots were moved to new positions:~%    ~S~%~]
@@ -1076,25 +1117,26 @@
 ;;;
 ;;;    This function is called when we are incompatibly redefining a structure
 ;;; Class to have the specified New-Layout.  We signal an error with some
-;;; proceed options.  In any case, we FMAKUNBOUND all the old accessors.
+;;; proceed options.
 ;;;
 (defun %redefine-defstruct (class old-layout new-layout)
-  (declare (type structure-class class) (type defstruct-description info)
-	   (type layout new-layout))
+  (declare (type class class) (type layout new-layout)
+	   (ignore old-layout))
+  (let ((name (class-proper-name class)))
     (restart-case
 	(error "Redefining class ~S incompatibly with the current ~
 		definition."
 	       name)
       (continue ()
 	:report "Invalidate current definition."
-	(warn "Previously loaded accessors will no longer work." name)
+	(warn "Previously loaded ~S accessors will no longer work." name)
 	(register-layout new-layout t nil))
       (clobber-it ()
 	:report "Smash current layout, preserving old code."
 	(warn "Any old ~S instances will be in a bad way.~@
 	       I hope you know what you're doing..."
 	      name)
-	(register-layout new-layout nil t)))
+	(register-layout new-layout nil t))))
 
   (undefined-value))
 
@@ -1102,90 +1144,26 @@
 ;;; UNDEFINE-STRUCTURE  --  Interface
 ;;;
 ;;;    Blow away all the compiler info for the structure described by Info.
-;;; This recursively descends the inheritance hierarchy.
+;;; Iterate over this type, clearing the compiler structure
+;;; type info, and undefining all the associated functions.
 ;;; 
 (defun undefine-structure (info)
-  (declare (type defstruct-description info))
-  (let* ((name (dd-name info))
-	 (all-types (cons name (dd-included-by info))))
-    ;;
-    ;; Iterate over this type and all subtypes, clearing the compiler structure
-    ;; type info, and undefining all the associated functions.
-    (dolist (type all-types)
-      (let ((this-info (info type structure-info type)))
-	(setf (info type kind type) nil)
-	(setf (info type structure-info type) nil)
-	(setf (info type frozen type) nil)
-	(undefine-function-name (dd-copier this-info))
-	(undefine-function-name (dd-predicate this-info))
-	(dolist (slot (dd-slots this-info))
-	  (let ((fun (dsd-accessor slot)))
-	    (undefine-function-name fun)
-	    (unless (dsd-read-only slot)
-	      (undefine-function-name `(setf ,fun)))))))
+  (when (defstruct-description-p info)
+    (let ((type (dd-name info)))
+      (setf (info type compiler-layout type) nil)
+      (undefine-function-name (dd-copier info))
+      (undefine-function-name (dd-predicate info))
+      (dolist (slot (dd-slots info))
+	(let ((fun (dsd-accessor slot)))
+	  (undefine-function-name fun)
+	  (unless (dsd-read-only slot)
+	    (undefine-function-name `(setf ,fun))))))
     ;;
-    ;; Iterate over all types that include this type, removing this type and
-    ;; all subtypes from the list of subtypes of the included type.  We copy
-    ;; the DD and included list so that we don't clobber the type in the
-    ;; compiler's Lisp.
-    (dolist (include (dd-includes info))
-      (let ((new (copy-defstruct-description
-		  (info type structure-info include))))
-	(setf (dd-included-by new)
-	      (set-difference (dd-included-by new) all-types))
-	(setf (info type structure-info include) new))))
-  ;;
-  ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
-  ;; unknown types.
-  (values-specifier-type-cache-clear)
+    ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
+    ;; unknown types.
+    (values-specifier-type-cache-clear))
   (undefined-value))
 
-
-;;; CHECK-FOR-STRUCTURE-REDEFINITION  --  Internal
-;;;
-;;;    Called when we process a DEFSTRUCT for a type that is already defined
-;;; for a structure.  We check for incompatible redefinition and undefine the
-;;; old structure if so.  We ignore the structures that DEFSTRUCT is built out
-;;; of, since they have to be hackishly defined in type-boot.  If the structure
-;;; is not incompatibly redefined, then we copy the old INCLUDED-BY into the
-;;; new structure.
-;;;
-(defun check-for-structure-redefinition (info)
-  (declare (type defstruct-description info))
-  (let* ((name (dd-name info))
-	 (old (info type structure-info name)))
-    (cond ((member name
-		   '(defstruct-description defstruct-slot-description)))
-	  ((and (equal (dd-includes old) (dd-includes info))
-		(equalp (dd-slots old) (dd-slots info)))
-	   (setf (dd-included-by info) (dd-included-by old)))
-	  (t
-	   (compiler-warning
-	    "Incompatibly redefining structure ~S.~@
-	    Removing the old definition~:[.~;~:* and these subtypes:~%  ~S~]"
-	    name (dd-included-by old))
-	   (undefine-structure old))))
-  (undefined-value))
-
-
-;;; ADD-NEW-SUBTYPE  --  Internal
-;;;
-;;;    Add a new subtype NAME to the structure type INC.  INFO is INC's current
-;;; info.
-;;;
-(defun add-new-subtype (name inc info)
-  (let ((new (copy-defstruct-description info)))
-    (setf (info type structure-info inc) new)
-    (push name (dd-included-by new))
-    (when (info type frozen inc)
-      (compiler-warning "Adding new subtype ~S to frozen type ~S.~@
-      			 Unfreezing this type and its inferiors.~@
-			 Previously compiled type tests must be recompiled."
-			name inc)
-      (setf (info type frozen inc) nil)
-      (dolist (subtype (dd-included-by info))
-	(setf (info type frozen subtype) nil)))))
-
 
 ;;;; Compiler stuff:
 
@@ -1215,29 +1193,49 @@
 ;;;
 (defun inherits-for-structure (info)
   (declare (type defstruct-description info))
-  (let ((include (dd-include info))
-	(super
-	 (if include
-	     (compiler-layout-or-lose (first include))
-	     (class-layout (find-class 'structure-object)))))
-    (concatentate 'simple-vector (layout-inherits super) (vector super))))
+  (let* ((include (dd-include info))
+	 (superclass-opt (dd-alternate-metaclass info))
+	 (super
+	  (if include
+	      (compiler-layout-or-lose (first include))
+	      (class-layout (find-class (or (first superclass-opt)
+					    'structure-object))))))
+    (concatenate 'simple-vector (layout-inherits super) (vector super))))
 
 
-;;; %COMPILER-ONLY-DEFSTRUCT  --  External
+;;; %COMPILER-ONLY-DEFSTRUCT  --  Internal
 ;;;
 ;;;    This function is called by an EVAL-WHEN to do the compile-time-only
 ;;; actions for defining a structure type.  It installs the class in the type
 ;;; system in a similar way to %DEFSTRUCT, but is quieter and safer in the case
 ;;; of redefinition.  This is not called at all for interpreted defstructs.
 ;;;
+;;;    Basically, this function avoids trashing the compiler by only actually
+;;; defining the class if there is no current definition.  Instead, we just set
+;;; the INFO TYPE COMPILER-LAYOUT.
+;;;
 (defun %compiler-only-defstruct (info inherits)
-  (multiple-value-bind (class layout)
+  (multiple-value-bind (class layout old-layout)
 		       (ensure-structure-class info inherits
 					       "current" "compiled")
-    (setf (info type compiler-layout (dd-name info)) layout)
-    (unless (eq (class-layout class) layout)
-      (register-layout layout nil nil))
-    (setf (find-class (dsd-name info)) class))
+    (cond
+     (old-layout
+      (undefine-structure (layout-info old-layout))
+      (when (and (class-subclasses class)
+		 (not (eq layout old-layout)))
+	(collect ((subs))
+	  (do-hash (class layout (class-subclasses class))
+	    (undefine-structure (layout-info layout))
+	    (subs (class-proper-name class)))
+	  (when (subs)
+	    (warn "Removing old subclasses of ~S:~%  ~S"
+		  (class-name class) (subs))))))
+     (t
+      (register-layout layout nil nil)
+      (setf (find-class (dd-name info)) class)))
+    
+    (setf (info type compiler-layout (dd-name info)) layout))
+  
   (undefined-value))
 
 
@@ -1251,28 +1249,29 @@
 ;;;
 (defun %%compiler-defstruct (info)
   (declare (type defstruct-description info))
-  (let ((name (dd-name info)))
+  (let* ((name (dd-name info))
+	 (class (find-class name)))
     (let ((copier (dd-copier info)))
       (when copier
-	(%proclaim `(ftype (function (,name) ,name) ,copier))))
+	(proclaim `(ftype (function (,name) ,name) ,copier))))
     
     (let ((pred (dd-predicate info)))
       (when pred
 	(define-defstruct-name pred)
 	(setf (info function inlinep pred) :inline)
 	(setf (info function inline-expansion pred)
-	      `(lambda (x) (typep x ',name))))))
-
-  (dolist (slot (dd-slots info))
-    (let* ((fun (dsd-accessor slot))
-	   (setf-fun `(setf ,fun)))
-      (when (and fun (not (dsd-raw-type slot)))
-	(define-defstruct-name fun)
-	(setf (info function accessor-for fun) info)
-	(unless (dsd-read-only slot)
-	  (define-defstruct-name setf-fun)
-	  (setf (info function accessor-for setf-fun) info)))))
-
+	      `(lambda (x) (typep x ',name)))))
+    
+    (dolist (slot (dd-slots info))
+      (let* ((fun (dsd-accessor slot))
+	     (setf-fun `(setf ,fun)))
+	(when (and fun (eq (dsd-raw-type slot) 't))
+	  (define-defstruct-name fun)
+	  (setf (info function accessor-for fun) class)
+	  (unless (dsd-read-only slot)
+	    (define-defstruct-name setf-fun)
+	    (setf (info function accessor-for setf-fun) class))))))
+  
   (undefined-value))
 
 (setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
@@ -1282,9 +1281,10 @@
 ;;;
 ;;;    Copy any old kind of structure.
 ;;;
+#-ns-boot
 (defun copy-structure (structure)
   "Return a copy of Structure with the same (EQL) slot values."
-  (declare (type structure structure) (optimize (speed 3) (safety 0)))
+  (declare (type instance structure) (optimize (speed 3) (safety 0)))
   (let* ((len (%instance-length structure))
 	 (res (%make-instance len))
 	 (layout (%instance-layout structure)))
@@ -1301,10 +1301,10 @@
     
     (let ((raw-index (dd-raw-index (layout-info layout))))
       (when raw-index
-	(let* ((data (truly-the (simply-array (unsigned-byte 32) (*))
-				(%instance-ref structure raw-index)))
+	(let* ((data (%instance-ref structure raw-index))
 	       (raw-len (length data))
 	       (new (make-array raw-len :element-type '(unsigned-byte 32))))
+	  (declare (type (simple-array (unsigned-byte 32) (*)) data))
 	  (setf (%instance-ref res raw-index) new)
 	  (dotimes (i raw-len)
 	    (setf (aref new i) (aref data i))))))
@@ -1314,6 +1314,7 @@
 
 ;;; Default print and make-load-form methods.
 
+#-ns-boot
 (defun default-structure-print (structure stream depth)
   (declare (ignore depth))
   (let* ((type (%instance-layout structure))
@@ -1359,11 +1360,11 @@
 	    (write-char #\space stream)
 	    (output-object (%instance-ref structure index) stream))))))
 
-
+#-ns-boot
 (defun make-structure-load-form (structure)
   (declare (type structure structure))
   (let* ((class (layout-class (%instance-layout structure)))
-	 (fun (structure-class-load-form-maker class)))
+	 (fun (structure-class-make-load-form-fun class)))
     (etypecase fun
       ((member :just-dump-it-normally :ignore-it)
        fun)