From a6e86e458185274e0eb8915b57261a7e4268d98a Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 15 Jan 1993 15:27:20 +0000
Subject: [PATCH] *** empty log message ***

---
 code/defstruct.lisp | 1719 +++++++++++++++++++++++++++++--------------
 code/describe.lisp  |   19 +-
 2 files changed, 1179 insertions(+), 559 deletions(-)

diff --git a/code/defstruct.lisp b/code/defstruct.lisp
index a5dea3dfb..69b6c6911 100644
--- a/code/defstruct.lisp
+++ b/code/defstruct.lisp
@@ -7,60 +7,192 @@
 ;;; 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 1992/12/15 19:45:07 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.37.1.1 1993/01/15 15:27:08 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; Defstruct structure definition package (Mark II).
-;;; Written by Skef Wholey and Rob MacLachlan.
+;;; Defstruct structure definition package (Mark III).
+;;; Written by Rob MacLachlan, William Lott and Skef Wholey.
 ;;;
-(in-package "C")
-
 (in-package "LISP")
 (export '(defstruct copy-structure))
-
-(in-package :c)
-
-;;; Always compile safe.  This code isn't very careful about protecting itself.
-;;; Note: we only do this at compile time because defstruct gets cold-loaded
-;;; before enough stuff to handle the declaim has been set up.
-(eval-when (compile)
-  (declaim (optimize (safety 1))))
+(in-package "KERNEL")
+(export '(
+	  default-structure-print make-structure-load-form 
+	  %compiler-defstruct %%compiler-defstruct
+	  %make-instance
+	  %instance-length %instance-ref %instance-set %instance-layout
+	  %set-instance-layout 
+	  %raw-ref-single %raw-set-single
+	  %raw-ref-double %raw-set-double
+	  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))
 
 
 ;;;; Structure frobbing primitives.
 
-(defun make-structure (length)
-  "Allocate a new structure with LENGTH data slots."
+(defun %make-instance (length)
+  "Allocate a new instance with LENGTH data slots."
   (declare (type index length))
-  (make-structure length))
+  (%make-instance length))
 
-(defun structure-length (structure)
-  "Given a structure, return its length."
-  (declare (type structure structure))
-  (structure-length structure))
+(defun %instance-length (instance)
+  "Given an instance, return its length."
+  (declare (type instance instance))
+  (%instance-length instance))
+
+(defun %instance-ref (instance index)
+  "Return the value from the INDEXth slot of INSTANCE.  This is SETFable."
+  (%instance-ref instance index))
+
+(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))
 
-(defun structure-ref (struct index)
-  "Return the value from the INDEXth slot of STRUCT.  0 corresponds to the
-  type.  This is SETFable."
-  (structure-ref struct index))
+(defun %raw-ref-double (vec index)
+  (declare (type index index))
+  (%raw-ref-double vec index))
 
-(defun structure-set (struct index new-value)
-  "Set the INDEXth slot of STRUCT to NEW-VALUE."
-  (setf (structure-ref struct index) new-value))
+(defun %raw-set-single (vec index val)
+  (declare (type index index))
+  (%raw-set-single vec index val))
 
-(defsetf structure-ref structure-set)
+(defun %raw-set-double (vec index val)
+  (declare (type index index))
+  (%raw-set-double vec index val))
 
+(defsetf %raw-ref-single %raw-set-single)
+(defsetf %raw-ref-double %raw-set-double)
+
+(defun %instance-layout (instance)
+  (%instance-layout instance))
+
+(defun %set-instance-layout (instance new-value)
+  (%set-instance-layout instance new-value))
+
+(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.
 
+;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a
+;;; structure type.
+;;;
+(defstruct (defstruct-description
+             (:conc-name dd-)
+             (:print-function print-defstruct-description)
+	     (:make-load-form-fun :just-dump-it-normally)
+	     (:constructor make-defstruct-description (name)))
+  ;;
+  ;; name of the structure
+  (name (required-argument) :type symbol)
+  ;;
+  ;; documentation on the structure
+  (doc nil :type (or string null))
+  ;;
+  ;; prefix for slot names.  If NIL, none.
+  (conc-name (concat-pnames name '-) :type (or symbol null))
+  ;;
+  ;; The name of the primary standard keyword constructor, or NIL if none.
+  (default-constructor nil :type (or symbol null))
+  ;;
+  ;; All the explicit :CONSTRUCTOR specs, with name defaulted.
+  (constructors () :type list)
+  ;;
+  ;; name of copying function
+  (copier (concat-pnames 'copy- name) :type (or symbol null))
+  ;;
+  ;; Name of type predictate
+  (predicate (concat-pnames name '-p) :type (or symbol null))
+  ;;
+  ;; The arguments to the :INCLUDE option, or NIL if no included structure.
+  (include nil :type list)
+  ;;
+  ;; list of defstruct-slot-description objects for all slots (including
+  ;; included ones.)
+  (slots () :type list)
+  ;;
+  ;; Number of elements we've allocated (see also raw-length.)
+  (length 0 :type index)
+  ;;
+  ;; General kind of implementation.
+  (type 'structure :type (member structure vector list))
+  ;;
+  ;; The next three slots are for :TYPE'd structures (which aren't classes,
+  ;; i.e. dd-type /= structure.)
+  ;;
+  ;; Vector element type.
+  (element-type 't)
+  ;;
+  ;; T if :NAMED was explicitly specified, Nil otherwise.
+  (named nil :type boolean)
+  ;;
+  ;; Any INITIAL-OFFSET option on this direct type.
+  (offset nil :type index))
+  ;;
+  ;; The next five slots are only meaningful in real default structures (i.e.
+  ;; dd-type = structure), since they are recognizably typed objects (classes.)
+  ;;
+  ;; The argument to the PRINT-FUNCTION option, or NIL if none.  If we see an
+  ;; explicit (:PRINT-FUNCTION) option, then this is DEFAULT-STRUCTURE-PRINT.
+  ;; See also STRUCTURE-CLASS-PRINTER.
+  (print-function nil :type (or cons symbol null))
+  ;;
+  ;; Make-load-form function option.  See also STRUCTURE-CLASS-LOAD-FORM-MAKER.
+  (make-load-form-fun nil :type (or symbol cons null))
+  ;;
+  ;; The index of the raw data vector and the number of words in it.  NIL and 0
+  ;; if not allocated yet.
+  (raw-index nil :type (or index null))
+  (raw-length 0 :type index))
+
+
+;;; DEFSTRUCT-SLOT-DESCRIPTION  holds compile-time information about structure
+;;; slots.
+;;;
+(defstruct (defstruct-slot-description
+             (:conc-name dsd-)
+             (:print-function print-defstruct-slot-description)
+	     (:make-load-form-fun :just-dump-it-normally))
+  %name				; string name of slot
+  ;;
+  ;; its position in the implementation sequence
+  (index (required-argument) :type fixnum)
+  ;;
+  ;; Name of accesor, or NIL if this accessor has the same name as an inherited
+  ;; accessor (which we don't want to shadow.)
+  (accessor nil)
+  default			; default value expression
+  (type t)			; declared type specifier
+  ;;
+  ;; If a raw slot, what it holds.  T means not raw.
+  (raw-type t :type (member t single-float double-float unsigned-byte))
+  (read-only nil :type (member t nil)))
+
 (defun print-defstruct-description (structure stream depth)
   (declare (ignore depth))
   (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
 
-;;; DSD-Name  --  Internal
+
+(defun compiler-layout-or-lose (name)
+  (let ((res (info type compiler-layout name)))
+    (cond ((not res)
+	   (error "Inherited class not yet defined: ~S" name))
+	  ((not (defstruct-description-p (layout-info res)))
+	   (error "Inherited class is not a STRUCTURE-CLASS: ~S" name))
+	  (t res))))
+
+
+;;; DSD-Name  --  External
 ;;;
 ;;;    Return the the name of a defstruct slot as a symbol.  We store it
 ;;; as a string to avoid creating lots of worthless symbols at load time.
@@ -75,44 +207,84 @@
   (declare (ignore depth))
   (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
 
-
 
 ;;; The legendary macro itself.
 
+;;; DEFINE-CLASS-METHODS  --  Internal
+;;;
+;;; Return a list of forms to install print and make-load-form funs, mentioning
+;;; them in the expansion so that they can be compiled.
+;;;
+(defun define-class-methods (defstruct)
+  (let ((name (dd-name defstruct)))
+    `(,@(let ((pf (dd-print-function defstruct)))
+	  (when pf
+	    `((setf (structure-class-print-function (find-class ',name))
+		    ,(if (symbolp pf)
+			 `',pf
+			 `#',pf)))))
+	,@(let ((mlff (dd-make-load-form-fun defstruct)))
+	    (when mlff
+	      `((setf (structure-class-make-load-form-fun (find-class ',name))
+		      ,(if (symbolp mlff)
+			   `',mlff
+			   `#',mlff))))))))
+
+;;; DEFSTRUCT  --  Public
+;;;
 (defmacro defstruct (name-and-options &rest slot-descriptions)
-  "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
-  Define the structure type Name.  See the manual for details."
-  (let* ((defstruct (parse-name-and-options name-and-options))
+  "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
+   Define the structure type Name.  Instances are created by MAKE-<name>, which
+   takes keyword arguments allowing initial slot values to the specified.
+   A SETF'able function <name>-<slot> is defined for each slot to read&write
+   slot values.  <name>-p is a type predicate.
+
+   Popular DEFSTRUCT options (see manual for others):
+
+   (:CONSTRUCTOR Name)
+   (:PREDICATE Name)
+       Specify an alternate name for the constructor or predicate.
+
+   (:CONSTRUCTOR Name Lambda-List)
+       Explicitly specify the name and arguments to create a BOA constructor
+       (which is more efficient when keyword syntax isn't necessary.)
+
+   (:INCLUDE Supertype Slot-Spec*)
+       Make this type a subtype of the structure type Supertype.  The optional
+       Slot-Specs override inherited slot options.
+
+   Slot options:
+
+   :TYPE Type-Spec
+       Asserts that the value of this slot is always of the specified type.
+
+   :READ-ONLY {T | NIL}
+       If true, no setter function is defined for this slot."
+
+  (let* ((defstruct (parse-name-and-options
+		     (if (atom options)
+			 (list name-and-options)
+			 name-and-options))) 
 	 (name (dd-name defstruct)))
-    (parse-slot-descriptions defstruct slot-descriptions)
+    (when (stringp (car slot-descriptions))
+      (setf (dd-doc defstruct) (pop slot-descriptions)))
+    (dolist (slot slot-descriptions)
+      (allocate-1-slot (parse-1-dsd defstruct slot)))
     (if (eq (dd-type defstruct) 'structure)
-	`(progn
-	   (%defstruct ',defstruct)
-	   (%compiler-defstruct ',defstruct)
-	   ,@(define-constructors defstruct)
-	   ,@(define-boa-constructors defstruct)
-	   ;;
-	   ;; So the print function is in the right lexical environment, and
-	   ;; can be compiled...
-	   ,@(let ((pf (dd-print-function defstruct)))
-	       (when pf
-		 `((setf (info type printer ',name)
-			 ,(if (symbolp pf)
-			      `',pf
-			      `#',pf)))))
-	   ,@(let ((mlff (dd-make-load-form-fun defstruct)))
-	       (when mlff
-		 `((setf (info type load-form-maker ',name)
-			 ,(if (symbolp mlff)
-			      `',mlff
-			      `#',mlff)))))
-	   ',name)
+	(let ((inherits (inherits-for-structure defstruct)))
+	  `(progn
+	     (%defstruct ',defstruct ',inherits)
+	     (eval-when (compile)
+	       (%compiler-only-defstruct ',defstruct ',inherits))
+	     (%compiler-defstruct ',defstruct)
+	     ,@(define-constructors defstruct)
+	     ,@(define-raw-accessors defstruct)
+	     ,@(define-class-methods defstruct)
+	   ',name))
 	`(progn
 	   (eval-when (compile load eval)
-	     (setf (info type kind ',name) nil)
-	     (setf (info type structure-info ',name) ',defstruct))
+	     (setf (info typed-structure info ',name) ',defstruct))
 	   ,@(define-constructors defstruct)
-	   ,@(define-boa-constructors defstruct)
 	   ,@(define-predicate defstruct)
 	   ,@(define-accessors defstruct)
 	   ,@(define-copier defstruct)
@@ -121,123 +293,111 @@
 
 ;;;; Parsing:
 
+;;; PARSE-1-OPTION  --  Internal
+;;;
+;;;    Parse a single defstruct option and store the results in Defstruct.
+;;;
+(defun parse-1-option (option defstruct)
+  (let ((args (rest option))
+	(name (dd-name defstruct)))
+    (case (first option)
+      (:conc-name
+       (destructuring-bind (conc-name) args
+	 (setf (dd-conc-name defstruct)
+	       (if (symbolp conc-name)
+		   conc-name
+		   (make-symbol (string conc-name))))))
+      (:constructor
+       (destructuring-bind (&optional (cname (concat-pnames 'make- name))
+				      &rest stuff)
+			   args
+	 (push (cons cname stuff) (dd-constructors defstruct))))
+      (:copier
+       (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
+			   args
+	 (setf (dd-copier defstruct) copier)))
+      (:predicate
+       (destructuring-bind (&optional (pred (concat-pnames name '-p)))
+			   args
+	 (setf (dd-predicate defstruct) pred)))
+      (:include
+       (when (dd-include defstruct)
+	 (error "Can't have more than one :INCLUDE option."))
+       (setf (dd-include defstruct) args))
+      (:print-function
+       (destructuring-bind (&optional (fun 'default-structure-print)) args
+	 (setf (dd-print-function defstruct) fun)))
+      (:type
+       (destructuring-bind (type) args
+	 (cond ((member type '(list vector))
+		(setf (dd-element-type defstruct) 't)
+		(setf (dd-type defstruct) type))
+	       ((and (consp type) (eq (first type) 'vector))
+		(destructuring-bind (vector vtype) type
+		  (declare (ignore vector))
+		  (setf (dd-element-type defstruct) vtype)
+		  (setf (dd-type defstruct) 'vector)))
+	       (t
+		(error "~S is a bad :TYPE for Defstruct." type)))))
+      (:named
+       (error "The Defstruct option :NAMED takes no arguments."))
+      (:initial-offset
+       (destructuring-bind (offset) args
+	 (setf (dd-offset defstruct) offset)))
+      (:make-load-form-fun
+       (destructuring-bind (fun) args
+	 (setf (dd-make-load-form-fun defstruct) fun)))
+      (t (error "Unknown DEFSTRUCT option~%  ~S" option)))))
+
+
+;;; PARSE-NAME-AND-OPTIONS  --  Internal
+;;;
+;;;    Given name and options, return a DD holding that info.
+;;;
 (defun parse-name-and-options (name-and-options)
-  (if (atom name-and-options)
-      (setq name-and-options (list name-and-options)))
-  (do* ((options (cdr name-and-options) (cdr options))
-	(name (car name-and-options))
-	(print-function nil)
-	(pf-supplied-p)
-	(conc-name (concat-pnames name '-))
-	(constructors '())
-	(constructor-opt-p nil)
-	(boa-constructors '())
-	(copier (concat-pnames 'copy- name))
-	(predicate (concat-pnames name '-p))
-	(include)
-	(saw-type)
-	(type 'structure)
-	(saw-named)
-	(offset 0)
-	(make-load-form-fun nil)
-	(make-load-form-fun-p nil))
-       ((null options)
-	(let ((named (if saw-type saw-named t)))
-	  (make-defstruct-description
-	   :name name
-	   :conc-name conc-name
-	   :constructors
-	   (if constructor-opt-p
-	       (nreverse constructors)
-	       (list (concat-pnames 'make- name)))
-	   :boa-constructors boa-constructors
-	   :copier copier
-	   :predicate predicate
-	   :include include
-	   :print-function print-function
-	   :type type
-	   :length (if named 1 0)
-	   :lisp-type (cond ((eq type 'structure) 'simple-vector)
-			    ((eq type 'vector) 'simple-vector)
-			    ((eq type 'list) 'list)
-			    ((and (listp type) (eq (car type) 'vector))
-			     (cons 'simple-array (cdr type)))
-			    (t (error "~S is a bad :TYPE for Defstruct." type)))
-	   :named named
-	   :offset offset
-	   :make-load-form-fun make-load-form-fun)))
-    (if (atom (car options))
-	(case (car options)
-	  (:constructor
-	   (setf constructor-opt-p t)
-	   (setf constructors (list (concat-pnames 'make- name))))
-	  (:copier)
-	  (:predicate)
-	  (:named (setq saw-named t))
-	  (t (error "The Defstruct option ~S cannot be used with 0 arguments."
-		    (car options))))
-	(let ((option (caar options))
-	      (args (cdar options)))
-	  (case option
-	    (:conc-name
-	     (setq conc-name (car args))
-	     (unless (symbolp conc-name)
-	       (setq conc-name (make-symbol (string conc-name)))))
-	    (:constructor
-	     (setf constructor-opt-p t)
-	     (let ((lambda-list (cdr args))
-		   (constructor-name (car args))
-		   (no-explicit-nil-name (not args)))
-	       ;; Constructor-name may be nil because args has one element, the
-	       ;; explicit name of nil.  In this situation, don't make a
-	       ;; default constructor.  If args itself is nil, then we make a
-	       ;; default constructor.
-	       (cond (lambda-list
-		      (push args boa-constructors))
-		     (constructor-name
-		      (push constructor-name constructors))
-		     (no-explicit-nil-name
-		      (push (concat-pnames 'make- name) constructors)))))
-	    (:copier (setq copier (car args)))
-	    (:predicate (setq predicate (car args)))
-	    (:include
-	     (setf include args)
-	     (let* ((name (car include))
-		    (included-structure
-		     (info type structure-info name)))
-	       (unless included-structure
-		 (error "Cannot find description of structure ~S to use for ~
-		         inclusion."
-			name))
-	       (unless pf-supplied-p
-		 (setf print-function
-		       (dd-print-function included-structure)))
-	       (unless make-load-form-fun-p
-		 (setf make-load-form-fun
-		       (dd-make-load-form-fun included-structure)))))
-	    (:print-function
-	     (setf print-function (car args))
-	     (setf pf-supplied-p t))
-	    (:type (setf saw-type t type (car args)))
-	    (:named (error "The Defstruct option :NAMED takes no arguments."))
-	    (:initial-offset (setf offset (car args)))
-	    (:make-load-form-fun
-	     (setf make-load-form-fun (car args))
-	     (setf make-load-form-fun-p t))
-	    (t (error "~S is an unknown Defstruct option." option)))))))
+  (destructuring-bind (name &rest options) name-and-options
+    (let ((defstruct (make-defstruct-description :name 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)))
+	      (t
+	       (error "Unrecognized DEFSTRUCT option: ~S" option))))
+
+      (cond
+       ((eq (dd-type defstruct) 'structure)
+	(when (dd-offset defstruct)
+	  (error "Can't specify :OFFSET unless :TYPE is specified."))
+	(unless (dd-include defstruct)
+	  (incf (dd-length defstruct))))
+       (t
+	(when (dd-print-function defstruct)
+	  (warn "Silly to specify :PRINT-FUNCTION with :TYPE."))
+	(when (dd-make-load-form-fun defstruct)
+	  (warn "Silly to specify :MAKE-LOAD-FORM-FUN with :TYPE."))
+	(when (dd-named defstruct) (incf (dd-length defstruct)))
+	(let ((offset (dd-offset defstruct)))
+	  (when offset (incf (dd-length defstruct) offset)))))
 
+      (when (dd-include defstruct)
+	(do-include-stuff defstruct))
+
+      defstruct)))
 
 
 ;;;; Stuff to parse slot descriptions.
 
 ;;; PARSE-1-DSD  --  Internal
 ;;;
-;;;    Parse a slot description for DEFSTRUCT and add it to the description.
-;;; If supplied, ISLOT is a pre-initialized DSD that we modify to get the new
-;;; slot.  This is supplied when handling included slots.  If the new accessor
-;;; name is already an accessor for same slot in some included structure, then
-;;; set the DSD-ACCESSOR to NIL so that we don't clobber the more general
-;;; accessor.
+;;;    Parse a slot description for DEFSTRUCT, add it to the description and
+;;; return it.  If supplied, ISLOT is a pre-initialized DSD that we modify to
+;;; get the new slot.  This is supplied when handling included slots.  If the
+;;; new accessor name is already an accessor for same slot in some included
+;;; structure, then set the DSD-ACCESSOR to NIL so that we don't clobber the
+;;; more general accessor.
 ;;;
 (defun parse-1-dsd (defstruct spec &optional
 		     (islot (make-defstruct-slot-description
@@ -252,7 +412,7 @@
 	  (values name default default-p type type-p read-only ro-p)))
        (t
 	(when (keywordp spec)
-	  (warn "Keyword slot name indicates possible syntax ~
+	  (warn "Keyword slot name indicates probable syntax ~
 		 error in DEFSTRUCT -- ~S."
 		spec))
 	spec))
@@ -274,51 +434,446 @@
     (when default-p
       (setf (dsd-default islot) default))
     (when type-p
-      (setf (dsd-type islot) type))
+      (setf (dsd-type islot)
+	    (if (eq (dsd-type islot) 't)
+		type
+		`(and ,(dsd-type islot) ,type))))
     (when ro-p
-      (setf (dsd-read-only islot) read-only))
-    (setf (dsd-index islot) (dd-length defstruct))
-    (incf (dd-length defstruct)))
+      (if read-only
+	  (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))
+
+
+;;; ALLOCATE-1-SLOT  --  Internal
+;;;
+;;;    Allocate storage for a DSD in Defstruct.  This is where we decide if a
+;;; slot is raw or not.  If raw, and we haven't allocated a raw-index yet for
+;;; the raw data vector, then do it.  Raw objects are aligned on the unit of
+;;; their size.
+;;;
+(defun allocate-1-slot (defstruct dsd)
+  (let ((type (dsd-type dsd)))
+    (multiple-value-bind
+	(raw-type words)
+	(cond ((not (eq (dd-type defstruct) 'structure))
+	       (values nil nil))
+	      ((and (subtypep type '(usigned-byte 32))
+		    (not (subtypep type 'fixnum)))
+	       (values 'unsigned-byte 1))
+	      ((subtypep type 'single-float)
+	       (values 'single-float 1))
+	      ((subtypep type 'double-float)
+	       (values 'double-float 2))
+	      (t (values nil nil)))
+
+      (cond ((not raw-type)
+	     (setf (dsd-index dsd) (dd-length defstruct))
+	     (incf (dd-length defstruct)))
+	    (t
+	     (unless (dd-raw-index defstruct)
+	       (setf (dd-raw-index defstruct) (dd-length defstruct))
+	       (incf (dd-length defstruct)))
+	     (let ((off (rem (dd-length defstruct) words)))
+	       (unless (zerop off)
+		 (incf (dd-raw-length defstruct) (- words off))))
+	     (setf (dsd-raw-type dsd) raw-type)
+	     (setf (dsd-index dsd) (dd-raw-length defstruct))
+	     (incf (dd-raw-length defstruct) words)))))
+
   (undefined-value))
 
 
-;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
-;;; any structure inclusion that needs to be done.
-;;;
-(defun parse-slot-descriptions (defstruct slots)
-  ;; First strip off any doc string and stash it in the Defstruct.
-  (when (stringp (car slots))
-    (setf (dd-doc defstruct) (car slots))
-    (setq slots (cdr slots)))
-  ;; Then include stuff.  We add unparsed items to the start of the Slots.
-  (when (dd-include defstruct)
-    (destructuring-bind (included-name &rest modified-slots)
-			(dd-include defstruct)
-      (let ((included-thing
-	     (or (info type structure-info included-name)
-		 (error "Cannot find description of structure ~S ~
-			 to use for inclusion."
-			included-name))))
-	(setf (dd-includes defstruct)
-	      (cons (dd-name included-thing) (dd-includes included-thing)))
-	(incf (dd-offset defstruct) (dd-offset included-thing))
-	(incf (dd-length defstruct) (dd-offset defstruct))
-	(dolist (islot (dd-slots included-thing))
-	  (let* ((iname (dsd-name islot))
-		 (modified (or (find iname modified-slots
-				     :key #'(lambda (x) (if (atom x) x (car x)))
-				     :test #'string=)
-			       `(,iname))))
-	    (parse-1-dsd defstruct modified
-			 (copy-defstruct-slot-description islot)))))))
+;;; DO-INCLUSION-STUFF  --  Internal
+;;;
+;;;    Process any included slots pretty much like they were specified.  Also
+;;; inherit various other attributes (print function, etc.)
+;;;
+(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))))
+      (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)
+	  (setf (dd-print-function defstruct)
+		(dd-print-function included-structure)))
+	(unless (dd-make-load-form-fun defstruct)
+	  (setf (dd-make-load-form-fun defstruct)
+		(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
+				   :key #'(lambda (x) (if (atom x) x (car x)))
+				   :test #'string=)
+			     `(,iname))))
+	  (parse-1-dsd defstruct modified
+		       (copy-defstruct-slot-description islot)))))))
+
+
+
+;;;; Constructors:
+
+(defun typed-structure-info-or-lose (name)
+  (or (info typed-structure info name)
+      (error ":TYPE'd defstruct ~S not found for inclusion." name)))
+
+;;; FIND-NAME-INDICES  --  Internal
+;;;
+;;;      Returns a list of pairs (name . index).  Used for :TYPE'd constructors
+;;; to find all the names that we have to splice in & where.  Note that these
+;;; types don't have a layout, so we can't look at LAYOUT-INHERITS.
+;;;
+(defun find-name-indices (defstruct)
+  (collect ((res))
+    (let ((infos ()))
+      (do ((info defstruct
+		 (typed-structure-info-or-lose (first (dd-include info)))))
+	  ((not (dd-include info)))
+	(push info infos))
+      
+      (let ((i 0))
+	(dolist (info infos)
+	  (incf i (dd-offset info))
+	  (when (dd-named info)
+	    (res (cons (dd-name info) i)))
+	  (setq i (dd-length info)))))
+
+    (res)))
+
   
-  ;; Finally parse the slots into Slot-Description objects.
-  (dolist (slot slots)
-    (parse-1-dsd defstruct slot))
-  (undefined-value))
+;;; CREATE-{STRUCTURE,VECTOR,LIST}-CONSTRUCTOR  --  Internal
+;;;
+;;;    These functions are called to actually make a constructor after we have
+;;; processed the arglist.  The correct variant (according to the DD-TYPE)
+;;; should be called.  The function is defined with the specified name and
+;;; arglist.  Vars and Types are used for argument type declarations.  Values
+;;; are the values for the slots (in order.)
+;;;
+;;; This is split three ways because:
+;;; 1] list & vector structures need "name" symbols stuck in at various weird
+;;;    places, whereas STRUCTURE structures have a LAYOUT slot.
+;;; 2] We really want to use LIST to make list structures, instead of
+;;;    MAKE-LIST/(SETF ELT).
+;;; 3] STRUCTURE structures can have raw slots that must also be allocated and
+;;;    indirectly referenced.  We just call the setter function and let the
+;;;    compiler figure out the references.
+;;;
+(defun create-vector-constructor
+       (defstruct cons-name arglist vars types values) 
+  (let ((temp (gensym)))
+    `(defun ,cons-name ,args
+       (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+			  vars types))
+       (let ((,temp (make-array ,(dd-length defstruct)
+				:element-type ',(dd-element-type defstruct))))
+	 ,@(mapcar #'(lambda (x)
+		       `(setf (%instance-ref ,temp ,(cdr x))  ',(car x)))
+		   (find-name-indices defstruct))
+	 ,@(mapcar #'(lambda (dsd value)
+		       `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+		   (dd-slots defstruct) values)
+	 ,temp))))
+;;;
+(defun create-list-constructor
+       (defstruct cons-name arglist vars types values) 
+  (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
+      (setf (elt vals (dsd-index dsd)) val))
+
+    `(defun ,cons-name ,args
+       (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+			  vars types))
+       (list ,@vals))))
+;;;
+(defun create-structure-constructor
+       (defstruct cons-name arglist vars types values)
+  (let ((temp (gensym)))
+    `(defun ,cons-name ,arglist
+       (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+			  vars types))
+       (let ((,temp (truly-the ,(dd-name defstruct)
+			       (%make-instance ,(dd-length defstruct)))))
+	 (setf (%instance-layout ,temp)
+	       ',(info type compiler-layout (dd-name defstruct)))
+	 ,@(when (dd-raw-index defstruct)
+	     `((setf (%instance-ref ,temp ,(dd-raw-index defstruct))
+		     (make-array ,(dd-raw-length defstruct)
+				 :element-type '(unsigned-byte 32)))))
+	 ,@(mapcar #'(lambda (dsd value)
+		       `(setf (,(concat-pnames (dd-conc-name defstruct)
+					       (dsd-name dsd))
+			       ,temp)
+			      ,value))
+		   (dd-slots defstruct)
+		   values))))
+
+
+;;; CREATE-KEYWORD-CONSTRUCTOR   --  Internal
+;;;
+;;;    Create a default (non-BOA) keyword constructor.
+;;;
+(defun create-default-constructor (defstruct creator)
+  (collect ((arglist (list '&key))
+	    (types)
+	    (values))
+    (dolist (slot (dd-slots defstruct))
+      (let ((dum (gensym))
+	    (name (dsd-name slot)))
+	(arglist `((,(intern (string name) "KEYWORD") dum)))
+	(types (dsd-type wlot))
+	(values dum)))
+    (funcall creator
+	     defstruct (dd-constructor defstruct)
+	     arglist values types values)))
+
+
+;;; CREATE-BOA-CONSTRUCTOR  --  Internal
+;;;
+;;;    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)
+  (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)
+		 (let ((res (find name (dd-slots defstruct) :test #'string=
+				  :key #'dsd-name)))
+		   (if res
+		       (values (dsd-type res) (dsd-default res))
+		       (values t nil))))
+	       (do-default (arg)
+		 (multiple-value-bind (type default) (get-slot arg)
+		   (arglist `(,arg ,default))
+		   (vars arg)
+		   (types type))))
+	(dolist (arg req)
+	  (arglist arg)
+	  (vars arg)
+	  (types (get-slot arg)))
+	
+	(when opt
+	  (arglist '&optional)
+	  (dolist (arg opt)
+	    (cond ((consp arg)
+		   (destructuring-bind
+		       (name &optional (def (nth-value 1 (get-slot name))))
+		       arg
+		     (arglist `(,name ,def))
+		     (vars name)
+		     (types (get-slot name))))
+		  (t
+		   (do-default arg)))))
+
+	(when restp
+	  (arglist '&rest rest)
+	  (vars rest)
+	  (types 'list))
+
+	(when keyp
+	  (arglist '&key)
+	  (dolist (key keys)
+	    (if (consp key)
+		(destructuring-bind (wot &optional (def nil def-p))
+				    arg
+		  (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)))
+		      (vars name)
+		      (types type))))
+		(do-default key))))
+
+	(when allowp (arglist '&allow-other-keys))
+
+	(when aux
+	  (arglist '&aux)
+	  (dolist (arg aux)
+	    (let* ((arg (if (consp arg) arg (list arg)))
+		   (var (first arg)))
+	      (arglist arg)
+	      (vars var)
+	      (types (get-slot var))))))
+
+      (funcall creator defstruct (first boa)
+	       (arglist) (vars) (types)
+	       (mapcar #'(lambda (slot)
+			   (or (find (dsd-name slot) (vars))
+			       (dsd-default slot)))
+		       (dsd-slots defstruct))))))
+
+
+;;; DEFINE-CONSTRUCTORS  --  Internal
+;;;
+;;;    Grovel the constructor options, and decide what constructors (if any) to
+;;; create.
+;;;
+(defun define-constructors (defstruct)
+  (let ((no-constructors nil)
+	(boas ())
+	(defaults ())
+	(creator (ecase (dd-type defstruct)
+		   (structure #'create-structure-constructor)
+		   (vector #'create-vector-constructor)
+		   (list #'create-list-constructor))))
+    (dolist (constructor (dd-constructors defstruct))
+      (destructuring-bind (name &optional (boa-ll nil boa-p))
+			  constructor
+	(declare (ignore boa-ll))
+	(cond ((not name) (setq no-constructors t))
+	      (boa-p (push constructor boas))
+	      (t (push name defaults)))))
+
+    (when no-construtors
+      (when (or defaults boas)
+	(error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs."))
+      (return-from define-constructors ()))
 
+    (unless (or defaults boas)
+      (push (concat-pnames 'make- (dd-name defstruct)) defaults))
+
+    (collect ((res))
+      (when defaults
+	(let ((cname (first defaults)))
+	  (setf (dd-constructor defstruct) cname)
+	  (res (create-keyword-constructor defstruct creator))
+	  (dolist (other-name (rest defaults))
+	    (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+	    (res `(declaim (ftype function ',other-name))))))
+      
+      (dolist (boa boas)
+	(res (create-boa-constructor defstruct boa creator)))
+
+      (res))))
 
-;;;; Default structure access and copiers:
+;;;; Slot accessors for raw slots:
+
+;;; DEFINE-RAW-ACCESSORS  --  Internal
+;;;
+;;;    Define readers and writers for raw slots as inline functions.  We use
+;;; the special RAW-REF operations to store floats in the raw data vector.
+;;;
+(defun define-raw-accessors (defstruct)
+  (collect ((res))
+    (dolist (slot (dd-slots defstruct))
+      (let ((rtype (dsd-raw-type slot))
+	    (aname (dsd-accessor slot)))
+	(when (and aname (not (eq rtype 't)))
+	  (let ((accessor
+		 (ecase rtype
+		   (single-float '%raw-ref-single)
+		   (double-float '%raw-ref-double)
+		   (unsigned-byte 'aref)))
+		 (offset
+		  (if (eq rtype 'double-float)
+		      (ash (dsd-index slot) -1)
+		      (dsd-index slot)))
+		 (data `(truly-the (simple-array (unsigned-byte 32) (*))
+				   (%instance-ref object
+						  ,(dd-raw-index defstruct))))
+		(name (dd-name defstruct))
+		(stype (dsd-type slot)))
+	    (res `(declaim (inline ,aname)))
+	    (res `(declaim (ftype (function (,name) ,stype) ,aname)))
+	    (res
+	     `(defun ,aname (object)
+		(truly-the ,stype (,accessor ,data ,offset))))
+	    (unless (dsd-read-only slot)
+	      (res `(declaim (inline (setf ,aname))))
+	      (res `(declaim (ftype (function (,stype ,name) ,stype)
+				    (setf ,aname))))
+	      (res
+	       `(defun (setf ,aname) (new-value object)
+		  (setf (,accessor ,data ,offset) new-value))))))))
+    (res)))
+	  
+
+;;;; Typed (non-class) structures:
+
+;;; DD-LISP-TYPE  --  Internal
+;;;
+;;;    Return a type specifier we can use for testing :TYPE'd structures.
+;;;
+(defun dd-lisp-type (defstruct)
+  (ecase (dd-type defstruct)
+    (list 'list)
+    (vector `(simple-array ,(dd-element-type defstruct)
+			   (*)))))
+
+;;; DEFINE-ACCESSORS  --  Internal
+;;;
+;;;    Returns a list of function definitions for accessing and setting the
+;;; slots of the a typed Defstruct.  The functions are proclaimed to be inline,
+;;; and the types of their arguments and results are declared as well.  We
+;;; count on the compiler to do clever things with Elt.
+;;;
+(defun define-accessors (defstruct)
+  (collect ((stuff))
+    (let* ((type (dd-type defstruct))
+	   (ltype (dd-lisp-type defstruct)))
+      (dolist (slot (dd-slots defstruct))
+	(let ((name (dsd-accessor slot))
+	      (index (dsd-index slot))
+	      (slot-type (dsd-type slot)))
+	  (stuff `(proclaim '(inline ,name (setf ,name))))
+	  (stuff `(defun ,name (structure)
+		    (declare (type ,ltype structure))
+		    (the ,slot-type (elt structure ,index))))
+	  (unless (dsd-read-only slot)
+	    (stuff
+	     `(defun (setf ,name) (new-value structure)
+		(declare (type ,ltype structure) (type ,slot-type new-value))
+		(setf (elt structure ,index) new-value))))))))
+    (stuff))
+
+
+;;; Define-Copier returns the definition for a copier function of a typed
+;;; Defstruct if one is desired.
+(defun define-copier (defstruct)
+  (when (dd-copier defstruct)
+    `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq)
+      (declaim (ftype function ,(dd-copier defstruct))))))
+
+
+;;; Define-Predicate returns a definition for a predicate function if one is
+;;; desired.  Rather vaguely specified w.r.t. inclusion.
+;;;
+(defun define-predicate (defstruct)
+  (let ((name (dd-name defstruct))
+	(pred (dd-predicate defstruct)))
+    (when (and pred (dd-named defstruct))
+      (let ((ltype (dd-lisp-type defstruct)))
+	`((defun ,pred (object)
+	    (and (typep object ',ltype)
+		 (eq (elt (the ,ltype object)
+			  ,(cdr (car (last (find-name-indices defstruct)))))
+		     ',name))))))))
+
+
+;;;; Load time support for default structures (%DEFSTRUCT)
 ;;;
 ;;;    In the normal case of structures that have a real type (i.e. no :Type
 ;;; option was specified), we want to optimize things for space as well as
@@ -328,378 +883,445 @@
 ;;; general-case code.  Since the compiler will normally open-code accesors,
 ;;; the (minor) efficiency penalty is not a concern.
 
-;;; Typep-To-Structure  --  Internal
+;;; Typep-To-Layout  --  Internal
 ;;;
-;;;    Return true if Obj is an object of the structure type specified by Info.
-;;; This is called by the accessor closures, which have a handle on the type's
-;;; Defstruct-Description.
+;;;    Return true if Obj is an object of the structure type corresponding to
+;;; Layout.  This is called by the accessor closures, which have a handle on
+;;; the type's layout.
 ;;;
-#+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 (structure-ref obj 0)))
-	 (or (eq name (dd-name info))
-	     (member name (dd-included-by info) :test #'eq)))))
+(proclaim '(inline typep-to-layout))
+(defun typep-to-structure (obj layout)
+  (declare (type layout layout) (optimize (speed 3) (safety 0)))
+  (when (layout-invalid layout)
+    (error "Obsolete structure accessor function called."))
+  (and (%instancep obj)
+       (let ((depth (layout-inheritance-depth layout))
+	     (obj-layout (%instance-layout obj)))
+	 (cond ((eq obj-layout layout) t)
+	       ((layout-invalid obj-layout)
+		(error "Structure accessor called on obsolete instance:~%  ~S"
+		       obj))
+	       (t
+		(and (> (layout-inheritance-depth obj-layout) depth)
+		     (eq (svref (layout-inherits obj-layout) depth)
+			 layout)))))))
 
 
-;;; %REDEFINE-DEFSTRUCT  --  Internal
+;;; STRUCTURE-SLOT-SETTER, STRUCTURE-SLOT-ACCESSOR  --  Internal
 ;;;
-;;;    This function is called when we are redefining a structure from Old to
-;;; New.  If the slots are different, we flame loudly, but give the luser a
-;;; chance to proceed.  We flame especially loudly if there are structures that
-;;; include this one.  If proceeded, we FMAKUNBOUND all the old accessors.  If
-;;; the redefinition is not incompatible, we make the INCLUDED-BY of the new
-;;; definition be the same as the old one.
-;;;
-(defun %redefine-defstruct (old new)
-  (declare (type defstruct-description old new))
-  (cond
-   ((and (equalp (dd-slots old) (dd-slots new))
-	 (equal (dd-includes old) (dd-includes new)))
-    (setf (dd-included-by new) (dd-included-by old)))
-   (t
-    (let ((name (dd-name old))
-	  (included-by (dd-included-by old)))
-      (cerror
-       "Recklessly proceed with wanton disregard for Lisp and limb."
-       "Structure ~S is being incompatibly redefined.  If proceeded, you must~@
-       recompile all uses of this structure's accessors.~:[~;~@
-       ~S is included by these structures:~
-       ~%  ~S~@
-       You must also recompile these DEFSTRUCTs and all the uses of their ~
-       accessors.~]"
-       name included-by name included-by)
-
-      (dolist (slot (dd-slots old))
-	(fmakunbound (dsd-accessor slot))
-	(unless (dsd-read-only slot)
-	  (fmakunbound `(setf ,(dsd-accessor slot))))))))
+;;;    Return closures to do slot access (set), according to Layout and DSD.
+;;; We check types, then do the access.  This is only used for normal slots
+;;; (not raw.)
+;;;
+(defun structure-slot-accessor (layout dsd)
+  #'(lambda (structure)
+      (declare (optimize (speed 3) (safety 0)))
+      (unless (typep-to-structure structure layout)
+	(error "Structure for accessor ~S is not a ~S:~% ~S"
+	       (dsd-accessor dsd) (class-name (layout-class layout))
+	       structure))
+      (%instance-ref structure (dsd-index dsd))))
+;;;
+(defun structure-slot-setter (layout dsd)
+  #'(lambda (new-value structure)
+      (declare (optimize (speed 3) (safety 0)))
+      (unless (typep-to-structure structure layout)
+	(error "Structure for setter ~S is not a ~S:~% ~S"
+	       `(setf ,(dsd-accessor dsd)) (class-name (layout-class layout))
+	       structure))
+      (unless (typep new-value (dsd-type dsd))
+	(error "New-Value for setter ~S is not a ~S:~% ~S."
+	       `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
+	       new-value))
+      (setf (%instance-ref structure (dsd-index dsd)) new-value)))
 
-  (undefined-value))
 
-#+new-compiler
 ;;; %Defstruct  --  Internal
 ;;;
-;;;    Do miscellaneous load-time actions for the structure described by Info.
+;;;    Do miscellaneous (LOAD EVAL) time actions for the structure described by
+;;; Info.  Create the class & layout, checking for incompatible redefinition.
 ;;; Define setters, accessors, copier, predicate, documentation, instantiate
 ;;; definition in load-time env.  This is only called for default structures.
 ;;;
-(defun %defstruct (info)
+(defun %defstruct (info inherits)
   (declare (type defstruct-description info))
-  (let* ((name (dd-name info))
-	 (old (info type defined-structure-info name)))
-    ;;
-    ;; Don't flame about dd structures, since they are hackishly defined in
-    ;; type-boot...
-    (when (and old
-	       (not (member name '(defstruct-description
-				   defstruct-slot-description))))
-      (%redefine-defstruct old info))
+  (multiple-value-bind (class layout old-layout)
+		       (ensure-structure-class info inherits "current" "new")
+    (cond (old-layout
+	   (let ((old-info (layout-info old-layout)))    
+	     (when (defstruct-description-p old-info)
+	       (dolist (slot (dd-slots old-info))
+		 (fmakunbound (dsd-accessor slot))
+		 (unless (dsd-read-only slot)
+		   (fmakunbound `(setf ,(dsd-accessor slot)))))))
+	   (unless (eq layout old-layout)
+	     (%redefine-defstruct class old-layout layout)))
+	  (t
+	   (register-layout layout nil nil)))
+
+    (setf (find-class (dsd-name info)) class)
+      
+    (dolist (slot (dd-slots info))
+      (let ((dsd slot))
+	(when (and (dsd-accessor slot)
+		   (not (eq (dsd-raw-type slot) 'T)))
+	  (setf (symbol-function (dsd-accessor slot))
+		(structure-slot-accessor layout dsd))
+	  
+	  (unless (dsd-read-only slot)
+	    (setf (fdefinition `(setf ,(dsd-accessor slot)))
+		  (structure-slot-setter layout dsd))))))
     
-    (setf (info type defined-structure-info name) info)
-    (dolist (include (dd-includes info))
-      (let ((iinfo (info type defined-structure-info include)))
-	(unless iinfo
-	  (error "~S includes ~S, but it is not defined." name include))
-	(pushnew name (dd-included-by iinfo)))))
+    (when (dd-predicate info)
+      (setf (symbol-function (dd-predicate info))
+	    #'(lambda (object)
+		(declare (optimize (speed 3) (safety 0)))
+		(typep-to-layout object layout))))
     
-  (dolist (slot (dd-slots info))
-    (let ((dsd slot))
-      (when (dsd-accessor slot)
-	(setf (symbol-function (dsd-accessor slot))
-	      #'(lambda (structure)
-		  (declare (optimize (speed 3) (safety 0)))
-		  (unless (typep-to-structure structure info)
-		    (error "Structure for accessor ~S is not a ~S:~% ~S"
-			   (dsd-accessor dsd) (dd-name info) structure))
-		  (structure-ref structure (dsd-index dsd))))
-      
-	(unless (dsd-read-only slot)
-	  (setf (fdefinition `(setf ,(dsd-accessor slot)))
-		#'(lambda (new-value structure)
-		    (declare (optimize (speed 3) (safety 0)))
-		    (unless (typep-to-structure structure info)
-		      (error "Structure for setter ~S is not a ~S:~% ~S"
-			     `(setf ,(dsd-accessor dsd)) (dd-name info)
-			     structure))
-		    (unless (typep new-value (dsd-type dsd))
-		      (error "New-Value for setter ~S is not a ~S:~% ~S."
-			     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
-			     new-value))
-		    (setf (structure-ref structure (dsd-index dsd))
-			  new-value)))))))
-
-  (when (dd-predicate info)
-    (setf (symbol-function (dd-predicate info))
-	  #'(lambda (object)
-	      (declare (optimize (speed 3) (safety 0)))
-	      (if (typep-to-structure object info) t nil))))
-
-  (when (dd-copier info)
-    (setf (symbol-function (dd-copier info))
-	  #'(lambda (structure)
-	      (declare (optimize (speed 3) (safety 0)))
-	      (unless (typep-to-structure structure info)
-		(error "Structure for copier ~S is not a ~S:~% ~S"
-		       (dd-copier info) (dd-name info) structure))
-
-	      (let* ((len (dd-length info))
-		     (res (make-structure len)))
-		(declare (type structure-index len))
-		(dotimes (i len)
-		  (declare (type structure-index i))
-		  (setf (structure-ref res i)
-			(structure-ref structure i)))
-		res))))
+    (when (dd-copier info)
+      (setf (symbol-function (dd-copier info))
+	    #'(lambda (structure)
+		(declare (optimize (speed 3) (safety 0)))
+		(unless (typep-to-layout structure layout)
+		  (error "Structure for copier is not a ~S:~% ~S"
+			 (class-name (layout-class layout))
+			 structure))
+		(copy-structure structure)))))
+  
   (when (dd-doc info)
-    (setf (documentation (dd-name info) 'type) (dd-doc info))))
+    (setf (documentation (dd-name info) 'type) (dd-doc info)))
 
+  (undefined-value))
 
-;;; COPY-STRUCTURE  --  Public
+
+;;;; Redefinition stuff:
+
+;;; ENSURE-STRUCTURE-CLASS  --  Internal
 ;;;
-;;;    Copy any old kind of structure.
+;;;    Called when we are about to define a structure class.  Returns a
+;;; (possibly new) class object and the layout which should be used for the new
+;;; definition (may be the current layout.)  The third value is any old layout
+;;; for this class (may be NIL, and also might be an uninstalled forward
+;;; referenced layout.)
 ;;;
-(defun copy-structure (structure)
-  "Return a copy of Structure with the same (EQL) slot values."
-  (declare (type structure structure))
-  (locally (declare (optimize (speed 3) (safety 0)))
-    (let* ((len (structure-length structure))
-	   (res (make-structure len)))
-      (declare (type structure-index len))
-      (dotimes (i len)
-	(declare (type structure-index i))
-	(setf (structure-ref res i)
-	      (structure-ref structure i)))
-      res)))
+(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)
+    (let ((new-layout (make-layout :class class
+				   :inherits inherits
+				   :inheritance-depth (length inherits)
+				   :length (dd-length info)
+				   :info info)))
+      (if (or (not old-layout)
+	      (let ((old-info (layout-info old-layout)))
+		(or (redefine-layout-warning old-layout old-context
+					     new-layout new-context)
+		    (not (defstruct-description-p old-info))
+		    (redefine-structure-warning class old-info info))))
+	  (values class new-layout old-layout)
+	  (values class old-layout old-layout)))))
+	    
 
-
-;;; Define-Accessors returns a list of function definitions for accessing and
-;;; setting the slots of the a typed Defstruct.  The functions are proclaimed
-;;; to be inline, and the types of their arguments and results are declared as
-;;; well.  We count on the compiler to do clever things with Elt.
+;;; COMPARE-SLOTS  --  Internal
+;;;
+;;;    Compares the slots of Old and New, returning 3 lists of slot names:
+;;; 1] Slots which have moved,
+;;; 2] Slots whose type has changed,
+;;; 3] Deleted slots. 
+;;;
+(defun compare-slots (old new)
+  (let* ((oslots (dd-slots old))
+	 (nslots (dd-slots new))
+	 (onames (mapcar #'dsd-name oslots))
+	 (nnames (mapcar #'dsd-name nslots)))
+    (collect ((moved)
+	      (retyped))
+      (dolist (name (set-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))
+	    (retyped name))
+	  (unless (and (= (dsd-index os) (dsd-index ns))
+		       (eq (dsd-raw-type os) (dsd-raw-type ns)))
+	    (moved name))))
+      (values (moved)
+	      (retyped)
+	      (set-difference onames nnames)))))
 
-(defun define-accessors (defstruct)
-  (do ((slots (dd-slots defstruct) (cdr slots))
-       (stuff '())
-       (type (dd-lisp-type defstruct)))
-      ((null slots) stuff)
-    (let* ((slot (car slots))
-	   (name (dsd-accessor slot))
-	   (index (dsd-index slot))
-	   (slot-type (dsd-type slot)))
-      (push
-       `(progn
-	  (proclaim '(inline ,name (setf ,name)))
-	  (defun ,name (structure)
-	    (declare (type ,type structure))
-	    (the ,slot-type (elt structure ,index)))
-	  ,@(unless (dsd-read-only slot)
-	      `((defun (setf ,name) (new-value structure)
-		  (declare (type ,type structure) (type ,slot-type new-value))
-		  (setf (elt structure ,index) new-value)))))
-       stuff))))
 
-
-;;; Define-Constructors returns a definition for the constructor function of
-;;; the given Defstruct.  If the structure is implemented as a vector and is
-;;; named, we structurify it.  If the structure is a vector of some specialized
-;;; type, we can't use the Vector function.
+;;; REDEFINE-STRUCTURE-WARNING  --  Internal
 ;;;
-(defun define-constructors (defstruct)
-  (let ((cons-names (dd-constructors defstruct)))
-    (when cons-names
-      (let* ((name (first cons-names))
-	     (initial-cruft
-	      (if (dd-named defstruct)
-		  (make-list (1+ (dd-offset defstruct))
-			     :initial-element `',(dd-name defstruct))
-		  (make-list (dd-offset defstruct))))
-	     (slots (dd-slots defstruct))
-	     (names (mapcar #'dsd-name slots))
-	     (args (mapcar #'(lambda (slot)
-			       `(,(dsd-name slot) ,(dsd-default slot)))
-			   slots)))
-	`((defun ,name ,(if args `(&key ,@args))
-	    (declare
-	     ,@(mapcar #'(lambda (slot)
-			   `(type ,(dsd-type slot) ,(dsd-name slot)))
-		       slots))
-	    ,(case (dd-type defstruct)
-	       (list
-		`(list ,@initial-cruft ,@names))
-	       (structure
-		(let ((temp (gensym)))
-		  `(let ((,temp (make-structure ,(dd-length defstruct))))
-		     (declare (type structure ,temp))
-		     (setf (structure-ref ,temp 0) ',(dd-name defstruct))
-		     ,@(mapcar #'(lambda (slot)
-				   `(setf (structure-ref ,temp
-							 ,(dsd-index slot))
-					  ,(dsd-name slot)))
-			       slots)
-		     (truly-the ,(dd-name defstruct) ,temp))))
-	       (vector
-		`(vector ,@initial-cruft ,@names))
-	       (t
-		(do ((sluts slots (cdr sluts))
-		     (sets '())
-		     (temp (gensym)))
-		    ((null sluts)
-		     `(let ((,temp (make-array
-				    ,(dd-length defstruct)
-				    :element-type
-				    ',(cadr (dd-lisp-type defstruct)))))
-			,@(when (dd-named defstruct)
-			    `(setf (aref ,temp ,(dd-offset defstruct))
-				   ',(dd-name defstruct)))
-			,@sets
-			,temp))
-		  (let ((slot (car sluts)))
-		    (push `(setf (aref ,temp ,(dsd-index slot))
-				 ,(dsd-name slot))
-			  sets))))))
-	  ,@(mapcar #'(lambda (other-name)
-			`(setf (fdefinition ',other-name) #',name))
-		    (rest cons-names)))))))
+;;;    Give a warning and return true if we are redefining a structure with
+;;; 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))
+  (let ((name (dd-name new)))
+    (multiple-value-bind (moved renamed retyped new deleted)
+			 (compare-slots old new)
+      (when (or moved retyped deleted)
+	(compiler-warning 
+	 "Incompatibly redefining slots of structure class ~S~@
+	  Make sure any uses of affected accessors are recompiled:~@
+	  ~@[  These slots were moved to new positions:~%    ~S~%~]
+	  ~@[  These slots have new incompatible types:~%    ~S~%~]
+	  ~@[  These slots were deleted:~%    ~S~%~]"
+	 name moved retyped deleted)
+	t))))
+
+
+;;; %REDEFINE-DEFSTRUCT  --  Internal
+;;;
+;;;    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.
+;;;
+(defun %redefine-defstruct (class old-layout new-layout)
+  (declare (type structure-class class) (type defstruct-description info)
+	   (type layout new-layout))
+    (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)
+	(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)))
+
+  (undefined-value))
+
+
+;;; UNDEFINE-STRUCTURE  --  Interface
+;;;
+;;;    Blow away all the compiler info for the structure described by Info.
+;;; This recursively descends the inheritance hierarchy.
+;;; 
+(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)))))))
+    ;;
+    ;; 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)
+  (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)))))
 
 
-;;;; Support for By-Order-Argument Constructors.
-
-;;; FIND-LEGAL-SLOT   --  Internal
-;;;
-;;;    Given a defstruct description and a slot name, return the corresponding
-;;; slot if it exists, or signal an error if not.
-;;;
-(defun find-legal-slot (defstruct name)
-  (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
-      (error "~S is not a defined slot name in the ~S structure."
-	     name (dd-name defstruct))))
-
-
-;;; Define-Boa-Constructors defines positional constructor functions.  We
-;;; generate code to set each variable not specified in the arglist to the
-;;; default given in the Defstruct.  We just slap required args in, as with
-;;; rest args and aux args.  Optionals are treated a little differently.  Those
-;;; that aren't supplied with a default in the arg list are mashed so that
-;;; their default in the arglist is the corresponding default from the
-;;; Defstruct.
-;;;
-(defun define-boa-constructors (defstruct)
-  (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
-	(name (car (car boas)) (car (car boas)))
-	(args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
-	(slots (dd-slots defstruct) (dd-slots defstruct))
-	(slots-in-arglist '() '())
-	(defuns '()))
-       ((null boas) defuns)
-    ;; Find the slots in the arglist and hack the defaultless optionals.
-    (do ((args args (cdr args))
-	 (arg-kind 'required))
-	((null args))
-      (let ((arg (car args)))
-	(cond ((not (atom arg))
-	       (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
-	      ((member arg '(&optional &rest &aux &key) :test #'eq)
-	       (setq arg-kind arg))
-	      (t
-	       (case arg-kind
-		 ((required &rest &aux)
-		  (push (find-legal-slot defstruct arg) slots-in-arglist))
-		 ((&optional &key)
-		  (let ((dsd (find-legal-slot defstruct arg)))
-		    (push dsd slots-in-arglist)
-		    (rplaca args (list arg (dsd-default dsd))))))))))
+;;;; Compiler stuff:
+
+;;; DEFINE-DEFSTRUCT-NAME  --  Internal
+;;;
+;;;    Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and
+;;; blow away any ASSUMED-TYPE.  Also, if the thing is a slot accessor
+;;; currently, quietly unaccessorize it.  And if there are any undefined
+;;; warnings, we nuke them.
+;;;
+(defun define-defstruct-name (name)
+  (when name
+    (when (info function accessor-for name)
+      (setf (info function accessor-for name) nil))
+    (define-function-name name)
+    (note-name-defined name :function)
+    (setf (info function where-from name) :declared)
+    (when (info function assumed-type name)
+      (setf (info function assumed-type name) nil)))
+  (undefined-value))
+
+
+;;; INHERITS-FOR-STRUCTURE  --  Internal
+;;;
+;;;    This function is called at macroexpand time to compute the INHERITS
+;;; vector for a structure type definition.
+;;;
+(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))))
+
+
+;;; %COMPILER-ONLY-DEFSTRUCT  --  External
+;;;
+;;;    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.
+;;;
+(defun %compiler-only-defstruct (info inherits)
+  (multiple-value-bind (class 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))
+  (undefined-value))
+
+
+;;; %%Compiler-Defstruct  --  External
+;;;
+;;;    This function does the (compile load eval) time actions for updating the
+;;; compiler's global meta-information to represent the definition of the the
+;;; structure described by Info.  This primarily amounts to setting up info
+;;; about the accessor and other implicitly defined functions.  The
+;;; constructors are explicitly defined by top-level code.
+;;;
+(defun %%compiler-defstruct (info)
+  (declare (type defstruct-description info))
+  (let ((name (dd-name info)))
+    (let ((copier (dd-copier info)))
+      (when copier
+	(%proclaim `(ftype (function (,name) ,name) ,copier))))
     
-    ;; Then make a list that can be used with a (list ...) or (vector...).
-    (let ((initial-cruft
-	   (if (dd-named defstruct)
-	       (make-list (1+ (dd-offset defstruct))
-			  :initial-element `',(dd-name defstruct))
-	       (make-list (dd-offset defstruct))))
-	  (thing (mapcar #'(lambda (slot)
-			     (if (member slot slots-in-arglist
-					 :test #'eq)
-				 (dsd-name slot)
-				 (dsd-default slot)))
-			 slots)))
-      (push
-       `(defun ,name ,args
-	  (declare
-	   ,@(mapcar #'(lambda (slot)
-			 `(type ,(dsd-type slot) ,(dsd-name slot)))
-		     slots-in-arglist))
-	  ,(case (dd-type defstruct)
-	     (list
-	      `(list ,@initial-cruft ,@thing))
-	     (structure
-	      (let ((temp (gensym)))
-		`(let ((,temp (make-structure ,(dd-length defstruct))))
-		   (declare (type structure ,temp))
-		   (setf (structure-ref ,temp 0) ',(dd-name defstruct))
-		   ,@(mapcar #'(lambda (slot thing)
-				 `(setf (structure-ref ,temp
-						       ,(dsd-index slot))
-					,thing))
-			     slots thing)
-		   (truly-the ,(dd-name defstruct) ,temp))))
-	     (vector
-	      `(vector ,@initial-cruft ,@thing))
-	     (t
-	      (do ((things thing (cdr things))
-		   (index 0 (1+ index))
-		   (sets '())
-		   (temp (gensym)))
-		  ((null things)
-		   `(let ((,temp (make-array
-				  ,(dd-length defstruct)
-				  :element-type
-				  ',(cadr (dd-lisp-type defstruct)))))
-		      ,@(when (dd-named defstruct)
-			  `(setf (aref ,temp ,(dd-offset defstruct))
-				 ',(dd-name defstruct)))
-		      ,@sets
-		      ,temp))
-		(push `(setf (aref ,temp index) ,(car things))
-		      sets)))))
-       defuns))))
-
-;;; Define-Copier returns the definition for a copier function of a typed
-;;; Defstruct if one is desired.
+    (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))))))
 
-(defun define-copier (defstruct)
-  (when (dd-copier defstruct)
-    `((defun ,(dd-copier defstruct) (structure)
-	(declare (type ,(dd-lisp-type defstruct) structure))
-	(subseq structure 0 ,(dd-length defstruct))))))
+  (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)))))
 
-
-;;; Define-Predicate returns a definition for a predicate function if one is
-;;; desired.  This is only called for typed structures, since the default
-;;; structure predicate is implemented as a closure. 
+  (undefined-value))
 
-(defun define-predicate (defstruct)
-  (let ((name (dd-name defstruct))
-	(pred (dd-predicate defstruct)))
-    (when (and pred (dd-named defstruct))
-      (let ((ltype (dd-lisp-type defstruct)))
-	`((defun ,pred (object)
-	    (and (typep object ',ltype)
-		 (eq (elt (the ,ltype object) ,(dd-offset defstruct))
-		     ',name))))))))
+(setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
+
+
+;;; COPY-STRUCTURE  --  Public
+;;;
+;;;    Copy any old kind of structure.
+;;;
+(defun copy-structure (structure)
+  "Return a copy of Structure with the same (EQL) slot values."
+  (declare (type structure structure) (optimize (speed 3) (safety 0)))
+  (let* ((len (%instance-length structure))
+	 (res (%make-instance len))
+	 (layout (%instance-layout structure)))
+    (declare (type structure-index len))
+    (unless (structure-class-p (layout-class layout))
+      (error "Not a structure-class object:~%  ~S" structure))
+    (when (layout-invalid layout)
+      (error "Copying an obsolete structure:~%  ~S" structure))
+    
+    (dotimes (i len)
+      (declare (type structure-index i))
+      (setf (%instance-ref res i)
+	    (%instance-ref structure i)))
+    
+    (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)))
+	       (raw-len (length data))
+	       (new (make-array raw-len :element-type '(unsigned-byte 32))))
+	  (setf (%instance-ref res raw-index) new)
+	  (dotimes (i raw-len)
+	    (setf (aref new i) (aref data i))))))
+    
+    res))
 
 
-;;; Random sorts of stuff.
+;;; Default print and make-load-form methods.
 
 (defun default-structure-print (structure stream depth)
   (declare (ignore depth))
-  (let* ((type (structure-ref structure 0))
-	 (dd (info type defined-structure-info type)))
+  (let* ((type (%instance-layout structure))
+	 (name (class-name (layout-class type)))
+	 (dd (layout-info type)))
     (if *print-pretty*
 	(pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
-	  (prin1 type stream)
+	  (prin1 name stream)
 	  (let ((slots (dd-slots dd)))
 	    (when slots
 	      (write-char #\space stream)
@@ -712,7 +1334,7 @@
 		  (output-symbol-name (dsd-%name slot) stream)
 		  (write-char #\space stream)
 		  (pprint-newline :miser stream)
-		  (output-object (structure-ref structure (dsd-index slot))
+		  (output-object (%instance-ref structure (dsd-index slot))
 				 stream)
 		  (when (null slots)
 		    (return))
@@ -720,9 +1342,9 @@
 		  (pprint-newline :linear stream))))))
 	(descend-into (stream)
 	  (write-string "#S(" stream)
-	  (prin1 type stream)
+	  (prin1 name stream)
 	  (do ((index 1 (1+ index))
-	       (length (structure-length structure))
+	       (length (%instance-length structure))
 	       (slots (dd-slots dd) (cdr slots)))
 	      ((or (= index length)
 		   (and *print-length*
@@ -735,18 +1357,19 @@
 	    (write-char #\: stream)
 	    (output-symbol-name (dsd-%name (car slots)) stream)
 	    (write-char #\space stream)
-	    (output-object (structure-ref structure index) stream))))))
+	    (output-object (%instance-ref structure index) stream))))))
 
 
 (defun make-structure-load-form (structure)
   (declare (type structure structure))
-  (let* ((type (structure-ref structure 0))
-	 (fun (info type load-form-maker type)))
+  (let* ((class (layout-class (%instance-layout structure)))
+	 (fun (structure-class-load-form-maker class)))
     (etypecase fun
       ((member :just-dump-it-normally :ignore-it)
        fun)
       (null
-       (error "Structures of type ~S cannot be dumped as constants." type))
+       (error "Structures of type ~S cannot be dumped as constants."
+	      (class-name class)))
       (function
        (funcall fun structure))
       (symbol
diff --git a/code/describe.lisp b/code/describe.lisp
index 7226d8442..ac2ab0532 100644
--- a/code/describe.lisp
+++ b/code/describe.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.22 1992/12/17 09:07:01 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.22.1.1 1993/01/15 15:27:20 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -92,12 +92,9 @@
 	   (describe-aux x))
 	 (values))))
 
-;;; DESCRIBE-AUX does different things for each type.  The order of the
-;;; TYPECASE branches matters with respect to:
-;;;    - symbols and functions until the new standard makes them disjoint.
-;;;    - packages and structure since packages are structures.
-;;; We punt a given call if the current level is greater than *describe-level*,
-;;; or if we detect an object into which we have already descended.
+;;; DESCRIBE-AUX does different things for each type.  We punt a given call if
+;;; the current level is greater than *describe-level*, or if we detect an
+;;; object into which we have already descended.
 ;;;
 (defun describe-aux (x)
   (when (or (not (integerp *describe-level*))
@@ -113,7 +110,7 @@
     (function (describe-function x))
     (package (describe-package x))
     (hash-table (describe-hash-table x))
-    (structure (describe-structure x))
+    (instance (describe-instance x))
     (array (describe-array x))
     (fixnum (describe-fixnum x))
     (cons
@@ -142,12 +139,12 @@
 (defun default-describe (x)
   (format t "~&~S is a ~S." x (type-of x)))
 
-(defun describe-structure (x)
+(defun describe-instance (x)
   (cond ((and (fboundp 'pcl::std-instance-p)
 	      (pcl::std-instance-p x))
 	 (pcl::describe-object x *standard-output*))
 	(t
-	 (format t "~&~S is a structure of type ~A." x (c::structure-ref x 0))
+	 (format t "~&~S is a structure of type ~A." x (type-of x))
 	 (dolist (slot (cddr (inspect::describe-parts x)))
 	   (format t "~%~A: ~S." (car slot) (cdr slot))))))
 
@@ -184,7 +181,7 @@
 	  (hash-table-number-entries x)))
 
 (defun describe-package (x)
-  (describe-structure x)
+  (describe-instance x)
   (let* ((internal (package-internal-symbols x))
 	 (internal-count (- (package-hashtable-size internal)
 			    (package-hashtable-free internal)))
-- 
GitLab