X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fclass.lisp;h=a0e26d9822026f7538d855a7d75d88bcbdc04f7f;hb=670010e3f3dcd62efaf23f61abdc73950edb88c6;hp=b119f59b70d33153f371686a02f635c43084f0f1;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/class.lisp b/src/code/class.lisp
index b119f59..a0e26d9 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -1,7 +1,6 @@
 ;;;; This file contains structures and functions for the maintenance of
 ;;;; basic information about defined types. Different object systems
-;;;; can be supported simultaneously. Some of the functions here are
-;;;; nominally generic, and are overwritten when CLOS is loaded.
+;;;; can be supported simultaneously. 
 
 ;;;; This software is part of the SBCL system. See the README file for
 ;;;; more information.
@@ -14,31 +13,24 @@
 
 (in-package "SB!KERNEL")
 
-(file-comment
-  "$Header$")
-
 (!begin-collecting-cold-init-forms)
 
-;;;; the CLASS structure
+;;;; the CLASSOID structure
 
-;;; The CLASS structure is a supertype of all class types. A CLASS is
-;;; also a CTYPE structure as recognized by the type system.
-(def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are
-	     ;; pretty hairy. I'm considering cleaner ways to rewrite
-	     ;; the whole build system to avoid these (and other hacks
-	     ;; too, e.g. UNCROSS) but I'm not sure yet that I've got
-	     ;; it figured out. -- WHN 19990729
-	     #-sb-xc sb!xc:class
-	     #+sb-xc cl:class
-	     (:make-load-form-fun class-make-load-form-fun)
+;;; The CLASSOID structure is a supertype of all classoid types.  A
+;;; CLASSOID is also a CTYPE structure as recognized by the type
+;;; system.  (FIXME: It's also a type specifier, though this might go
+;;; away as with the merger of SB-PCL:CLASS and CL:CLASS it's no
+;;; longer necessary)
+(def!struct (classoid
+	     (:make-load-form-fun classoid-make-load-form-fun)
 	     (:include ctype
-		       (:class-info (type-class-or-lose #-sb-xc 'sb!xc:class
-							#+sb-xc 'cl:class)))
+		       (class-info (type-class-or-lose 'classoid)))
 	     (:constructor nil)
 	     #-no-ansi-print-object
 	     (:print-object
 	      (lambda (class stream)
-		(let ((name (sb!xc:class-name class)))
+		(let ((name (classoid-name class)))
 		  (print-unreadable-object (class stream
 						  :type t
 						  :identity (not name))
@@ -47,15 +39,12 @@
 			    ;; reasonably for anonymous classes.
 			    "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
 			    name
-			    (class-state class))))))
+			    (classoid-state class))))))
 	     #-sb-xc-host (:pure nil))
-  ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot
-  ;; accessor for this slot directly as the definition of
-  ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says
-  ;; that CL:CLASS-NAME is a generic function.)
-  (%name nil :type symbol)
+  ;; the value to be returned by CLASSOID-NAME.
+  (name nil :type symbol)
   ;; the current layout for this class, or NIL if none assigned yet
-  (layout nil :type (or sb!kernel::layout null))
+  (layout nil :type (or layout null))
   ;; How sure are we that this class won't be redefined?
   ;;   :READ-ONLY = We are committed to not changing the effective 
   ;;                slots or superclasses.
@@ -66,40 +55,36 @@
   (direct-superclasses () :type list)
   ;; representation of all of the subclasses (direct or indirect) of
   ;; this class. This is NIL if no subclasses or not initalized yet;
-  ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
+  ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the
   ;; subclass layout that was in effect at the time the subclass was
   ;; created.
   (subclasses nil :type (or null hash-table))
-  ;; the PCL class object for this class, or NIL if none assigned yet
+  ;; the PCL class (= CL:CLASS, but with a view to future flexibility
+  ;; we don't just call it the CLASS slot) object for this class, or
+  ;; NIL if none assigned yet
   (pcl-class nil))
 
-;;; KLUDGE: ANSI says this is a generic function, but we need it for
-;;; bootstrapping before CLOS exists, so we define it as an ordinary
-;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815
-(defun sb!xc:class-name (class)
-  (class-%name class))
-
-(defun class-make-load-form-fun (class)
-  (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class)
-  (let ((name (sb!xc:class-name class)))
-    (unless (and name (eq (sb!xc:find-class name nil) class))
+(defun classoid-make-load-form-fun (class)
+  (/show "entering CLASSOID-MAKE-LOAD-FORM-FUN" class)
+  (let ((name (classoid-name class)))
+    (unless (and name (eq (find-classoid name nil) class))
       (/show "anonymous/undefined class case")
       (error "can't use anonymous or undefined class as constant:~%  ~S"
 	     class))
     `(locally
-       ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
-       ;; names which creates fast but non-cold-loadable, non-compact
-       ;; code. In this context, we'd rather have compact,
+       ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for constant
+       ;; class names which creates fast but non-cold-loadable,
+       ;; non-compact code. In this context, we'd rather have compact,
        ;; cold-loadable code. -- WHN 19990928
-       (declare (notinline sb!xc:find-class))
-       (sb!xc:find-class ',name))))
+       (declare (notinline find-classoid))
+       (find-classoid ',name))))
 
 ;;;; basic LAYOUT stuff
 
 ;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
 ;;; in order to guarantee that several hash values can be added without
 ;;; overflowing into a bignum.
-(defconstant layout-clos-hash-max (ash most-positive-fixnum -3)
+(def!constant layout-clos-hash-max (ash most-positive-fixnum -3)
   #!+sb-doc
   "the inclusive upper bound on LAYOUT-CLOS-HASH values")
 
@@ -178,12 +163,8 @@
   (clos-hash-6 (random-layout-clos-hash) :type index)
   (clos-hash-7 (random-layout-clos-hash) :type index)
   ;; the class that this is a layout for
-  (class (required-argument)
-	 ;; FIXME: Do we really know this is a CL:CLASS? Mightn't it
-	 ;; be a SB-PCL:CLASS under some circumstances? What goes here
-	 ;; when the LAYOUT is in fact a PCL::WRAPPER?
-	 :type #-sb-xc sb!xc:class #+sb-xc cl:class)
-  ;; The value of this slot can be
+  (classoid (missing-arg) :type classoid)
+  ;; The value of this slot can be:
   ;;   * :UNINITIALIZED if not initialized yet;
   ;;   * NIL if this is the up-to-date layout for a class; or
   ;;   * T if this layout has been invalidated (by being replaced by 
@@ -191,14 +172,15 @@
   ;;   * something else (probably a list) if the class is a PCL wrapper
   ;;     and PCL has made it invalid and made a note to itself about it
   (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
-  ;; The layouts for all classes we inherit. If hierarchical these are
-  ;; in order from most general down to (but not including) this
-  ;; class.
+  ;; the layouts for all classes we inherit. If hierarchical, i.e. if
+  ;; DEPTHOID >= 0, then these are ordered by ORDER-LAYOUT-INHERITS,
+  ;; so that each inherited layout appears at its expected depth,
+  ;; i.e. at its LAYOUT-DEPTHOID value.
   ;;
-  ;; FIXME: Couldn't this be (SIMPLE-ARRAY LAYOUT 1) instead of
-  ;; SIMPLE-VECTOR?
+  ;; Remaining elements are filled by the non-hierarchical layouts or,
+  ;; if they would otherwise be empty, by copies of succeeding layouts.
   (inherits #() :type simple-vector)
-  ;; If inheritance is hierarchical, this is -1. If inheritance is not
+  ;; If inheritance is not hierarchical, this is -1. If inheritance is 
   ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
   ;; Note:
   ;;  (1) This turns out to be a handy encoding for arithmetically
@@ -209,7 +191,7 @@
   ;;      renamed because some of us find it confusing to call something
   ;;      a depth when it isn't quite.
   (depthoid -1 :type layout-depthoid)
-  ;; The number of top-level descriptor cells in each instance.
+  ;; the number of top level descriptor cells in each instance
   (length 0 :type index)
   ;; If this layout has some kind of compiler meta-info, then this is
   ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
@@ -231,11 +213,11 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun layout-proper-name (layout)
-    (class-proper-name (layout-class layout))))
+    (classoid-proper-name (layout-classoid layout))))
 
 ;;;; support for the hash values used by CLOS when working with LAYOUTs
 
-(defconstant layout-clos-hash-length 8)
+(def!constant layout-clos-hash-length 8)
 #!-sb-fluid (declaim (inline layout-clos-hash))
 (defun layout-clos-hash (layout i)
   ;; FIXME: Either this I should be declared to be `(MOD
@@ -280,42 +262,44 @@
 ;;; been split off into INIT-OR-CHECK-LAYOUT.
 (declaim (ftype (function (symbol) layout) find-layout))
 (defun find-layout (name)
-  (let ((class (sb!xc:find-class name nil)))
-    (or (and class (class-layout class))
+  (let ((classoid (find-classoid name nil)))
+    (or (and classoid (classoid-layout classoid))
 	(gethash name *forward-referenced-layouts*)
 	(setf (gethash name *forward-referenced-layouts*)
-	      (make-layout :class (or class (make-undefined-class name)))))))
+	      (make-layout :classoid (or classoid
+					 (make-undefined-classoid name)))))))
 
-;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH,
+;;; If LAYOUT is uninitialized, initialize it with CLASSOID, LENGTH,
 ;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
-;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
+;;; with CLASSOID, LENGTH, INHERITS, and DEPTHOID.
 ;;;
 ;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
 ;;; anything about the class", so if LAYOUT is initialized, any
 ;;; preexisting class slot value is OK, and if it's not initialized,
 ;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
 ;;; is no longer true, :UNINITIALIZED used instead.
-(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid) layout)
+(declaim (ftype (function (layout classoid index simple-vector layout-depthoid)
+			  layout)
 		init-or-check-layout))
-(defun init-or-check-layout (layout class length inherits depthoid)
+(defun init-or-check-layout (layout classoid length inherits depthoid)
   (cond ((eq (layout-invalid layout) :uninitialized)
 	 ;; There was no layout before, we just created one which
 	 ;; we'll now initialize with our information.
 	 (setf (layout-length layout) length
 	       (layout-inherits layout) inherits
 	       (layout-depthoid layout) depthoid
-	       (layout-class layout) class
+	       (layout-classoid layout) classoid
 	       (layout-invalid layout) nil))
 	;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
 	;; clause is not needed?
 	((not *type-system-initialized*)
-	 (setf (layout-class layout) class))
+	 (setf (layout-classoid layout) classoid))
 	(t
 	 ;; There was an old layout already initialized with old
 	 ;; information, and we'll now check that old information
 	 ;; which was known with certainty is consistent with current
 	 ;; information which is known with certainty.
-	 (check-layout layout class length inherits depthoid)))
+	 (check-layout layout classoid length inherits depthoid)))
   layout)
 
 ;;; In code for the target Lisp, we don't use dump LAYOUTs using the
@@ -337,12 +321,12 @@
   (declare (ignore env))
   (when (layout-invalid layout)
     (compiler-error "can't dump reference to obsolete class: ~S"
-		    (layout-class layout)))
-  (let ((name (sb!xc:class-name (layout-class layout))))
+		    (layout-classoid layout)))
+  (let ((name (classoid-name (layout-classoid layout))))
     (unless name
       (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
     ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
-    ;; we have to do this in two stages, a la the TREE-WITH-PARENT
+    ;; we have to do this in two stages, like the TREE-WITH-PARENT
     ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
     (values
      ;; "creation" form (which actually doesn't create a new LAYOUT if
@@ -351,7 +335,7 @@
      ;; "initialization" form (which actually doesn't initialize
      ;; preexisting LAYOUTs, just checks that they're consistent).
      `(init-or-check-layout ',layout
-			    ',(layout-class layout)
+			    ',(layout-classoid layout)
 			    ',(layout-length layout)
 			    ',(layout-inherits layout)
 			    ',(layout-depthoid layout)))))
@@ -396,8 +380,8 @@
 	(let ((old-length (layout-length old-layout)))
 	  (unless (= old-length length)
 	    (warn "change in instance length of class ~S:~%  ~
-		   ~A length: ~D~%  ~
-		   ~A length: ~D"
+		   ~A length: ~W~%  ~
+		   ~A length: ~W"
 		  name
 		  old-context old-length
 		  context length)
@@ -410,10 +394,11 @@
 
 ;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
 ;;; INHERITS, and DEPTHOID.
-(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
+(declaim (ftype (function
+		 (layout classoid index simple-vector layout-depthoid))
 		check-layout))
-(defun check-layout (layout class length inherits depthoid)
-  (assert (eq (layout-class layout) class))
+(defun check-layout (layout classoid length inherits depthoid)
+  (aver (eq (layout-classoid layout) classoid))
   (when (redefine-layout-warning "current" layout
 				 "compile time" length inherits depthoid)
     ;; Classic CMU CL had more options here. There are several reasons
@@ -445,8 +430,8 @@
 (defun find-and-init-or-check-layout (name length inherits depthoid)
   (let ((layout (find-layout name)))
     (init-or-check-layout layout
-			  (or (sb!xc:find-class name nil)
-			      (make-undefined-class name))
+			  (or (find-classoid name nil)
+			      (make-undefined-classoid name))
 			  length
 			  inherits
 			  depthoid)))
@@ -463,32 +448,32 @@
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 (defun register-layout (layout &key (invalidate t) destruct-layout)
   (declare (type layout layout) (type (or layout null) destruct-layout))
-  (let* ((class (layout-class layout))
-	 (class-layout (class-layout class))
-	 (subclasses (class-subclasses class)))
+  (let* ((classoid (layout-classoid layout))
+	 (classoid-layout (classoid-layout classoid))
+	 (subclasses (classoid-subclasses classoid)))
 
-    ;; Attempting to register ourselves with a temporary cookie is
-    ;; almost certainly a programmer error. (I should know, I did it.)
-    ;; -- WHN 19990927
-    (assert (not (undefined-class-p class)))
+    ;; Attempting to register ourselves with a temporary undefined
+    ;; class placeholder is almost certainly a programmer error. (I
+    ;; should know, I did it.) -- WHN 19990927
+    (aver (not (undefined-classoid-p classoid)))
 
     ;; This assertion dates from classic CMU CL. The rationale is
     ;; probably that calling REGISTER-LAYOUT more than once for the
     ;; same LAYOUT is almost certainly a programmer error.
-    (assert (not (eq class-layout layout)))
+    (aver (not (eq classoid-layout layout)))
 
     ;; Figure out what classes are affected by the change, and issue
     ;; appropriate warnings and invalidations.
-    (when class-layout
-      (modify-class class)
+    (when classoid-layout
+      (modify-classoid classoid)
       (when subclasses
 	(dohash (subclass subclass-layout subclasses)
-	  (modify-class subclass)
+	  (modify-classoid subclass)
 	  (when invalidate
 	    (invalidate-layout subclass-layout))))
       (when invalidate
-	(invalidate-layout class-layout)
-	(setf (class-subclasses class) nil)))
+	(invalidate-layout classoid-layout)
+	(setf (classoid-subclasses classoid) nil)))
 
     (if destruct-layout
 	(setf (layout-invalid destruct-layout) nil
@@ -496,32 +481,157 @@
 	      (layout-depthoid destruct-layout)(layout-depthoid layout)
 	      (layout-length destruct-layout) (layout-length layout)
 	      (layout-info destruct-layout) (layout-info layout)
-	      (class-layout class) destruct-layout)
+	      (classoid-layout classoid) destruct-layout)
 	(setf (layout-invalid layout) nil
-	      (class-layout class) layout))
+	      (classoid-layout classoid) layout))
 
     (let ((inherits (layout-inherits layout)))
       (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
-	(let* ((super (layout-class (svref inherits i)))
-	       (subclasses (or (class-subclasses super)
-			       (setf (class-subclasses super)
+	(let* ((super (layout-classoid (svref inherits i)))
+	       (subclasses (or (classoid-subclasses super)
+			       (setf (classoid-subclasses super)
 				     (make-hash-table :test 'eq)))))
-	  (when (and (eq (class-state super) :sealed)
-		     (not (gethash class subclasses)))
+	  (when (and (eq (classoid-state super) :sealed)
+		     (not (gethash classoid subclasses)))
 	    (warn "unsealing sealed class ~S in order to subclass it"
-		  (sb!xc:class-name super))
-	    (setf (class-state super) :read-only))
-	  (setf (gethash class subclasses)
+		  (classoid-name super))
+	    (setf (classoid-state super) :read-only))
+	  (setf (gethash classoid subclasses)
 		(or destruct-layout layout))))))
 
   (values))
 ); EVAL-WHEN
+
+;;; Arrange the inherited layouts to appear at their expected depth,
+;;; ensuring that hierarchical type tests succeed. Layouts with 
+;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first,
+;;; at exactly that index in the INHERITS vector. Then, non-hierarchical
+;;; layouts are placed in remaining elements. Then, any still-empty
+;;; elements are filled with their successors, ensuring that each
+;;; element contains a valid layout.
+;;;
+;;; This reordering may destroy CPL ordering, so the inherits should
+;;; not be read as being in CPL order.
+(defun order-layout-inherits (layouts)
+  (declare (simple-vector layouts))
+  (let ((length (length layouts))
+	(max-depth -1))
+    (dotimes (i length)
+      (let ((depth (layout-depthoid (svref layouts i))))
+	(when (> depth max-depth)
+	  (setf max-depth depth))))
+    (let* ((new-length (max (1+ max-depth) length))
+	   (inherits (make-array new-length)))
+      (dotimes (i length)
+	(let* ((layout (svref layouts i))
+	       (depth (layout-depthoid layout)))
+	  (unless (eql depth -1)
+	    (let ((old-layout (svref inherits depth)))
+	      (unless (or (eql old-layout 0) (eq old-layout layout))
+		(error "layout depth conflict: ~S~%" layouts)))
+	    (setf (svref inherits depth) layout))))
+      (do ((i 0 (1+ i))
+	   (j 0))
+	  ((>= i length))
+	(declare (type index i j))
+	(let* ((layout (svref layouts i))
+	       (depth (layout-depthoid layout)))
+	  (when (eql depth -1)
+	    (loop (when (eql (svref inherits j) 0)
+		    (return))
+		  (incf j))
+	    (setf (svref inherits j) layout))))
+      (do ((i (1- new-length) (1- i)))
+	  ((< i 0))
+	(declare (type fixnum i))
+	(when (eql (svref inherits i) 0)
+	  (setf (svref inherits i) (svref inherits (1+ i)))))
+      inherits)))
+
+;;;; class precedence lists
+
+;;; Topologically sort the list of objects to meet a set of ordering
+;;; constraints given by pairs (A . B) constraining A to precede B.
+;;; When there are multiple objects to choose, the tie-breaker
+;;; function is called with both the list of object to choose from and
+;;; the reverse ordering built so far.
+(defun topological-sort (objects constraints tie-breaker)
+  (declare (list objects constraints)
+	   (function tie-breaker))
+  (let ((obj-info (make-hash-table :size (length objects)))
+	(free-objs nil)
+	(result nil))
+    (dolist (constraint constraints)
+      (let ((obj1 (car constraint))
+	    (obj2 (cdr constraint)))
+	(let ((info2 (gethash obj2 obj-info)))
+	  (if info2
+	      (incf (first info2))
+	      (setf (gethash obj2 obj-info) (list 1))))
+	(let ((info1 (gethash obj1 obj-info)))
+	  (if info1
+	      (push obj2 (rest info1))
+	      (setf (gethash obj1 obj-info) (list 0 obj2))))))
+    (dolist (obj objects)
+      (let ((info (gethash obj obj-info)))
+	(when (or (not info) (zerop (first info)))
+	  (push obj free-objs))))
+    (loop
+     (flet ((next-result (obj)
+	      (push obj result)
+	      (dolist (successor (rest (gethash obj obj-info)))
+		(let* ((successor-info (gethash successor obj-info))
+		       (count (1- (first successor-info))))
+		  (setf (first successor-info) count)
+		  (when (zerop count)
+		    (push successor free-objs))))))
+       (cond ((endp free-objs)
+	      (dohash (obj info obj-info)
+		(unless (zerop (first info))
+		  (error "Topological sort failed due to constraint on ~S."
+			 obj)))
+	      (return (nreverse result)))
+	     ((endp (rest free-objs))
+	      (next-result (pop free-objs)))
+	     (t
+	      (let ((obj (funcall tie-breaker free-objs result)))
+		(setf free-objs (remove obj free-objs))
+		(next-result obj))))))))
+
+
+;;; standard class precedence list computation
+(defun std-compute-class-precedence-list (class)
+  (let ((classes nil)
+	(constraints nil))
+    (labels ((note-class (class)
+	       (unless (member class classes)
+		 (push class classes)
+		 (let ((superclasses (classoid-direct-superclasses class)))
+		   (do ((prev class)
+			(rest superclasses (rest rest)))
+		       ((endp rest))
+		     (let ((next (first rest)))
+		       (push (cons prev next) constraints)
+		       (setf prev next)))
+		   (dolist (class superclasses)
+		     (note-class class)))))
+	     (std-cpl-tie-breaker (free-classes rev-cpl)
+	       (dolist (class rev-cpl (first free-classes))
+		 (let* ((superclasses (classoid-direct-superclasses class))
+			(intersection (intersection free-classes
+						    superclasses)))
+		   (when intersection
+		     (return (first intersection)))))))
+      (note-class class)
+      (topological-sort classes constraints #'std-cpl-tie-breaker))))
 
-;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
+;;;; object types to represent classes
+
+;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
 ;;; referenced layouts. Users should never see them.
-(def!struct (undefined-class (:include #-sb-xc sb!xc:class
-				       #+sb-xc cl:class)
-			     (:constructor make-undefined-class (%name))))
+(def!struct (undefined-classoid
+	     (:include classoid)
+	     (:constructor make-undefined-classoid (name))))
 
 ;;; BUILT-IN-CLASS is used to represent the standard classes that
 ;;; aren't defined with DEFSTRUCT and other specially implemented
@@ -533,93 +643,102 @@
 ;;; This translation is done when type specifiers are parsed. Type
 ;;; system operations (union, subtypep, etc.) should never encounter
 ;;; translated classes, only their translation.
-(def!struct (sb!xc:built-in-class (:include #-sb-xc sb!xc:class
-					    #+sb-xc cl:class)
-				  (:constructor bare-make-built-in-class))
+(def!struct (built-in-classoid (:include classoid)
+			       (:constructor make-built-in-classoid))
   ;; the type we translate to on parsing. If NIL, then this class
   ;; stands on its own; or it can be set to :INITIALIZING for a period
   ;; during cold-load.
   (translation nil :type (or ctype (member nil :initializing))))
-(defun make-built-in-class (&rest rest)
-  (apply #'bare-make-built-in-class
-	 (rename-keyword-args '((:name :%name)) rest)))
 
 ;;; FIXME: In CMU CL, this was a class with a print function, but not
 ;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
 ;;; we let CLOS handle our print functions, so that is no longer needed.
 ;;; Is there any need for this class any more?
-(def!struct (slot-class (:include #-sb-xc sb!xc:class #+sb-xc cl:class)
-			(:constructor nil)))
+(def!struct (slot-classoid (:include classoid)
+			   (:constructor nil)))
 
 ;;; STRUCTURE-CLASS represents what we need to know about structure
 ;;; classes. Non-structure "typed" defstructs are a special case, and
 ;;; don't have a corresponding class.
-(def!struct (basic-structure-class (:include slot-class)
-				   (:constructor nil)))
+(def!struct (basic-structure-classoid (:include slot-classoid)
+				      (:constructor nil)))
 
-(def!struct (sb!xc:structure-class (:include basic-structure-class)
-				   (:constructor bare-make-structure-class))
+(def!struct (structure-classoid (:include basic-structure-classoid)
+				(:constructor make-structure-classoid))
   ;; If true, a default keyword constructor for this structure.
   (constructor nil :type (or function null)))
-(defun make-structure-class (&rest rest)
-  (apply #'bare-make-structure-class
-	 (rename-keyword-args '((:name :%name)) rest)))
 
 ;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
 ;;; structures, which are used to implement generic functions.
-(def!struct (funcallable-structure-class (:include basic-structure-class)
-					 (:constructor bare-make-funcallable-structure-class)))
-(defun make-funcallable-structure-class (&rest rest)
-  (apply #'bare-make-funcallable-structure-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+(def!struct (funcallable-structure-classoid
+	     (:include basic-structure-classoid)
+	     (:constructor make-funcallable-structure-classoid)))
 
-;;;; class namespace
+;;;; classoid namespace
 
 ;;; We use an indirection to allow forward referencing of class
 ;;; definitions with load-time resolution.
-(def!struct (class-cell
-	     (:constructor make-class-cell (name &optional class))
+(def!struct (classoid-cell
+	     (:constructor make-classoid-cell (name &optional classoid))
 	     (:make-load-form-fun (lambda (c)
-				    `(find-class-cell ',(class-cell-name c))))
+				    `(find-classoid-cell
+				      ',(classoid-cell-name c))))
 	     #-no-ansi-print-object
 	     (:print-object (lambda (s stream)
 			      (print-unreadable-object (s stream :type t)
-				(prin1 (class-cell-name s) stream)))))
+				(prin1 (classoid-cell-name s) stream)))))
   ;; Name of class we expect to find.
   (name nil :type symbol :read-only t)
   ;; Class or NIL if not yet defined.
-  (class nil :type (or #-sb-xc sb!xc:class #+sb-xc cl:class
-		       null)))
-(defun find-class-cell (name)
-  (or (info :type :class name)
-      (setf (info :type :class name)
-	    (make-class-cell name))))
+  (classoid nil :type (or classoid null)))
+(defun find-classoid-cell (name)
+  (or (info :type :classoid name)
+      (setf (info :type :classoid name)
+	    (make-classoid-cell name))))
 
 ;;; FIXME: When the system is stable, this DECLAIM FTYPE should
 ;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
-(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv))) sb!xc:find-class))
+(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv)))
+		find-classoid))
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
-(defun sb!xc:find-class (name &optional (errorp t) environment)
+(defun find-classoid (name &optional (errorp t) environment)
   #!+sb-doc
   "Return the class with the specified NAME. If ERRORP is false, then NIL is
    returned when no such class exists."
   (declare (type symbol name) (ignore environment))
-  (let ((res (class-cell-class (find-class-cell name))))
+  (let ((res (classoid-cell-classoid (find-classoid-cell name))))
     (if (or res (not errorp))
 	res
 	(error "class not yet defined:~%  ~S" name))))
-(defun (setf sb!xc:find-class) (new-value name)
-  #-sb-xc (declare (type sb!xc:class new-value))
+(defun (setf find-classoid) (new-value name)
+  #-sb-xc (declare (type classoid new-value))
   (ecase (info :type :kind name)
     ((nil))
+    (:forthcoming-defclass-type
+     ;; XXX Currently, nothing needs to be done in this case. Later, when
+     ;; PCL is integrated tighter into SBCL, this might need more work.
+     nil)
     (:instance
-     (let ((old (class-of (sb!xc:find-class name)))
+     ;; KLUDGE: The reason these clauses aren't directly parallel is
+     ;; that we need to use the internal CLASSOID structure ourselves,
+     ;; because we don't have CLASSes to work with until PCL is built.
+     ;; In the host, CLASSes have an approximately one-to-one
+     ;; correspondence with the target CLASSOIDs (as well as with the
+     ;; target CLASSes, modulo potential differences with respect to
+     ;; conditions).
+     #+sb-xc-host
+     (let ((old (class-of (find-classoid name)))
 	   (new (class-of new-value)))
        (unless (eq old new)
+	 (bug "trying to change the metaclass of ~S from ~S to ~S in the ~
+               cross-compiler."
+	      name (class-name old) (class-name new))))
+     #-sb-xc-host
+     (let ((old (classoid-of (find-classoid name)))
+	   (new (classoid-of new-value)))
+       (unless (eq old new)
 	 (warn "changing meta-class of ~S from ~S to ~S"
-	       name
-	       (class-name old)
-	       (class-name new)))))
+	       name (classoid-name old) (classoid-name new)))))
     (:primitive
      (error "illegal to redefine standard type ~S" name))
     (:defined
@@ -629,10 +748,10 @@
   (remhash name *forward-referenced-layouts*)
   (%note-type-defined name)
   (setf (info :type :kind name) :instance)
-  (setf (class-cell-class (find-class-cell name)) new-value)
+  (setf (classoid-cell-classoid (find-classoid-cell name)) new-value)
   (unless (eq (info :type :compiler-layout name)
-	      (class-layout new-value))
-    (setf (info :type :compiler-layout name) (class-layout new-value)))
+	      (classoid-layout new-value))
+    (setf (info :type :compiler-layout name) (classoid-layout new-value)))
   new-value)
 ) ; EVAL-WHEN
 
@@ -640,41 +759,41 @@
 ;;; predicate (such as a meta-class type test.) The first result is
 ;;; always of the desired class. The second result is any existing
 ;;; LAYOUT for this name.
-(defun insured-find-class (name predicate constructor)
-  (declare (function predicate constructor))
-  (let* ((old (sb!xc:find-class name nil))
+(defun insured-find-classoid (name predicate constructor)
+  (declare (type function predicate constructor))
+  (let* ((old (find-classoid name nil))
 	 (res (if (and old (funcall predicate old))
 		  old
 		  (funcall constructor :name name)))
 	 (found (or (gethash name *forward-referenced-layouts*)
-		    (when old (class-layout old)))))
+		    (when old (classoid-layout old)))))
     (when found
-      (setf (layout-class found) res))
+      (setf (layout-classoid found) res))
     (values res found)))
 
 ;;; If the class has a proper name, return the name, otherwise return
 ;;; the class.
-(defun class-proper-name (class)
-  #-sb-xc (declare (type sb!xc:class class))
-  (let ((name (sb!xc:class-name class)))
-    (if (and name (eq (sb!xc:find-class name nil) class))
+(defun classoid-proper-name (class)
+  #-sb-xc (declare (type classoid class))
+  (let ((name (classoid-name class)))
+    (if (and name (eq (find-classoid name nil) class))
 	name
 	class)))
 
 ;;;; CLASS type operations
 
-(define-type-class sb!xc:class)
+(!define-type-class classoid)
 
 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 ;;; the two classes are equal, since there are EQ checks in those
 ;;; operations.
-(define-type-method (sb!xc:class :simple-=) (type1 type2)
-  (assert (not (eq type1 type2)))
+(!define-type-method (classoid :simple-=) (type1 type2)
+  (aver (not (eq type1 type2)))
   (values nil t))
 
-(define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
-  (assert (not (eq class1 class2)))
-  (let ((subclasses (class-subclasses class2)))
+(!define-type-method (classoid :simple-subtypep) (class1 class2)
+  (aver (not (eq class1 class2)))
+  (let ((subclasses (classoid-subclasses class2)))
     (if (and subclasses (gethash class1 subclasses))
 	(values t t)
 	(values nil t))))
@@ -682,60 +801,74 @@
 ;;; When finding the intersection of a sealed class and some other
 ;;; class (not hierarchically related) the intersection is the union
 ;;; of the currently shared subclasses.
-(defun sealed-class-intersection (sealed other)
-  (declare (type sb!xc:class sealed other))
-  (let ((s-sub (class-subclasses sealed))
-	(o-sub (class-subclasses other)))
+(defun sealed-class-intersection2 (sealed other)
+  (declare (type classoid sealed other))
+  (let ((s-sub (classoid-subclasses sealed))
+	(o-sub (classoid-subclasses other)))
     (if (and s-sub o-sub)
 	(collect ((res *empty-type* type-union))
 	  (dohash (subclass layout s-sub)
 	    (declare (ignore layout))
 	    (when (gethash subclass o-sub)
 	      (res (specifier-type subclass))))
-	  (values (res) t))
-	(values *empty-type* t))))
+	  (res))
+	*empty-type*)))
 
-;;; If one is a subclass of the other, then that is the intersection,
-;;; but we can only be sure the intersection is otherwise empty if
-;;; they are structure classes, since a subclass of both might be
-;;; defined. If either class is sealed, we can eliminate this
-;;; possibility.
-(define-type-method (sb!xc:class :simple-intersection) (class1 class2)
-  (declare (type sb!xc:class class1 class2))
-  (cond ((eq class1 class2) class1)
-	((let ((subclasses (class-subclasses class2)))
+(!define-type-method (classoid :simple-intersection2) (class1 class2)
+  (declare (type classoid class1 class2))
+  (cond ((eq class1 class2)
+	 class1)
+	;; If one is a subclass of the other, then that is the
+	;; intersection.
+	((let ((subclasses (classoid-subclasses class2)))
 	   (and subclasses (gethash class1 subclasses)))
-	 (values class1 t))
-	((let ((subclasses (class-subclasses class1)))
+	 class1)
+	((let ((subclasses (classoid-subclasses class1)))
 	   (and subclasses (gethash class2 subclasses)))
-	 (values class2 t))
-	((or (basic-structure-class-p class1)
-	     (basic-structure-class-p class2))
-	 (values *empty-type* t))
-	((eq (class-state class1) :sealed)
-	 (sealed-class-intersection class1 class2))
-	((eq (class-state class2) :sealed)
-	 (sealed-class-intersection class2 class1))
+	 class2)
+	;; Otherwise, we can't in general be sure that the
+	;; intersection is empty, since a subclass of both might be
+	;; defined. But we can eliminate it for some special cases.
+	((or (basic-structure-classoid-p class1)
+	     (basic-structure-classoid-p class2))
+	 ;; No subclass of both can be defined.
+	 *empty-type*)
+	((eq (classoid-state class1) :sealed)
+	 ;; checking whether a subclass of both can be defined:
+	 (sealed-class-intersection2 class1 class2))
+	((eq (classoid-state class2) :sealed)
+	 ;; checking whether a subclass of both can be defined:
+	 (sealed-class-intersection2 class2 class1))
 	(t
-	 (values class1 nil))))
+	 ;; uncertain, since a subclass of both might be defined
+	 nil)))
+
+;;; KLUDGE: we need this because of the need to represent
+;;; intersections of two classes, even when empty at a given time, as
+;;; uncanonicalized intersections because of the possibility of later
+;;; defining a subclass of both classes.  The necessity for changing
+;;; the default return value from SUBTYPEP to NIL, T if no alternate
+;;; method is present comes about because, unlike the other places we
+;;; use INVOKE-COMPLEX-SUBTYPEP-ARG1-METHOD, in HAIRY methods and the
+;;; like, classes are in their own hierarchy with no possibility of
+;;; mixtures with other type classes.
+(!define-type-method (classoid :complex-subtypep-arg2) (type1 class2)
+  (if (and (intersection-type-p type1)
+	   (> (count-if #'classoid-p (intersection-type-types type1)) 1))
+      (values nil nil)
+      (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
 
-(define-type-method (sb!xc:class :unparse) (type)
-  (class-proper-name type))
+(!define-type-method (classoid :unparse) (type)
+  (classoid-proper-name type))
 
 ;;;; PCL stuff
 
-(def!struct (std-class (:include sb!xc:class)
-		       (:constructor nil)))
-(def!struct (sb!xc:standard-class (:include std-class)
-				  (:constructor bare-make-standard-class)))
-(def!struct (random-pcl-class (:include std-class)
-			      (:constructor bare-make-random-pcl-class)))
-(defun make-standard-class (&rest rest)
-  (apply #'bare-make-standard-class
-	 (rename-keyword-args '((:name :%name)) rest)))
-(defun make-random-pcl-class (&rest rest)
-  (apply #'bare-make-random-pcl-class
-	 (rename-keyword-args '((:name :%name)) rest)))
+(def!struct (std-classoid (:include classoid)
+			  (:constructor nil)))
+(def!struct (standard-classoid (:include std-classoid)
+			       (:constructor make-standard-classoid)))
+(def!struct (random-pcl-classoid (:include std-classoid)
+				 (:constructor make-random-pcl-classoid)))
 
 ;;;; built-in classes
 
@@ -785,296 +918,211 @@
      (character :enumerable t :translation base-char)
      (base-char :enumerable t
 		:inherits (character)
-		:codes (#.sb!vm:base-char-type))
-     (symbol :codes (#.sb!vm:symbol-header-type))
+		:codes (#.sb!vm:base-char-widetag))
+     (symbol :codes (#.sb!vm:symbol-header-widetag))
 
      (instance :state :read-only)
 
-     (system-area-pointer :codes (#.sb!vm:sap-type))
-     (weak-pointer :codes (#.sb!vm:weak-pointer-type))
-     (code-component :codes (#.sb!vm:code-header-type))
-     #!-gengc (lra :codes (#.sb!vm:return-pc-header-type))
-     (fdefn :codes (#.sb!vm:fdefn-type))
+     (system-area-pointer :codes (#.sb!vm:sap-widetag))
+     (weak-pointer :codes (#.sb!vm:weak-pointer-widetag))
+     (code-component :codes (#.sb!vm:code-header-widetag))
+     (lra :codes (#.sb!vm:return-pc-header-widetag))
+     (fdefn :codes (#.sb!vm:fdefn-widetag))
      (random-class) ; used for unknown type codes
 
      (function
-      :codes (#.sb!vm:byte-code-closure-type
-	      #.sb!vm:byte-code-function-type
-	      #.sb!vm:closure-header-type
-	      #.sb!vm:function-header-type)
+      :codes (#.sb!vm:closure-header-widetag
+	      #.sb!vm:simple-fun-header-widetag)
       :state :read-only)
      (funcallable-instance
       :inherits (function)
       :state :read-only)
 
-     ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything
-     ;; any more? COLLECTION is not defined in ANSI Common Lisp..
-     (collection :hierarchical-p nil :state :read-only)
-     (mutable-collection :state :read-only
-			 :inherits (collection))
-     (generic-sequence :state :read-only
-		       :inherits (collection))
-     (mutable-sequence :state :read-only
-		       :direct-superclasses (mutable-collection
-					     generic-sequence)
-		       :inherits (mutable-collection
-				  generic-sequence
-				  collection))
-     (generic-array :state :read-only
-		    :inherits (mutable-sequence
-			       mutable-collection
-			       generic-sequence
-			       collection))
-     (generic-vector :state :read-only
-		     :inherits (generic-array
-				mutable-sequence mutable-collection
-				generic-sequence collection))
-     (array :translation array :codes (#.sb!vm:complex-array-type)
-	    :inherits (generic-array mutable-sequence mutable-collection
-				     generic-sequence collection))
+     (array :translation array :codes (#.sb!vm:complex-array-widetag)
+            :hierarchical-p nil)
      (simple-array
-      :translation simple-array :codes (#.sb!vm:simple-array-type)
-      :inherits (array generic-array mutable-sequence mutable-collection
-		 generic-sequence collection))
+      :translation simple-array :codes (#.sb!vm:simple-array-widetag)
+      :inherits (array))
      (sequence
-      :translation (or cons (member nil) vector)
-      :inherits (mutable-sequence mutable-collection generic-sequence
-		 collection))
+      :translation (or cons (member nil) vector))
      (vector
-      :translation vector :codes (#.sb!vm:complex-vector-type)
-      :direct-superclasses (array sequence generic-vector)
-      :inherits (array sequence generic-vector generic-array
-		 mutable-sequence mutable-collection generic-sequence
-		 collection))
+      :translation vector :codes (#.sb!vm:complex-vector-widetag)
+      :direct-superclasses (array sequence)
+      :inherits (array sequence))
      (simple-vector
-      :translation simple-vector :codes (#.sb!vm:simple-vector-type)
+      :translation simple-vector :codes (#.sb!vm:simple-vector-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array
-		 sequence generic-vector generic-array
-		 mutable-sequence mutable-collection
-		 generic-sequence collection))
+      :inherits (vector simple-array array sequence))
      (bit-vector
-      :translation bit-vector :codes (#.sb!vm:complex-bit-vector-type)
-      :inherits (vector array sequence
-		 generic-vector generic-array mutable-sequence
-		 mutable-collection generic-sequence collection))
+      :translation bit-vector :codes (#.sb!vm:complex-bit-vector-widetag)
+      :inherits (vector array sequence))
      (simple-bit-vector
-      :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-type)
+      :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-widetag)
       :direct-superclasses (bit-vector simple-array)
       :inherits (bit-vector vector simple-array
-		 array sequence
-		 generic-vector generic-array mutable-sequence
-		 mutable-collection generic-sequence collection))
+		 array sequence))
      (simple-array-unsigned-byte-2
       :translation (simple-array (unsigned-byte 2) (*))
-      :codes (#.sb!vm:simple-array-unsigned-byte-2-type)
+      :codes (#.sb!vm:simple-array-unsigned-byte-2-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence
-		 generic-vector generic-array mutable-sequence
-		 mutable-collection generic-sequence collection))
+      :inherits (vector simple-array array sequence))
      (simple-array-unsigned-byte-4
       :translation (simple-array (unsigned-byte 4) (*))
-      :codes (#.sb!vm:simple-array-unsigned-byte-4-type)
+      :codes (#.sb!vm:simple-array-unsigned-byte-4-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence
-		 generic-vector generic-array mutable-sequence
-		 mutable-collection generic-sequence collection))
+      :inherits (vector simple-array array sequence))
      (simple-array-unsigned-byte-8
       :translation (simple-array (unsigned-byte 8) (*))
-      :codes (#.sb!vm:simple-array-unsigned-byte-8-type)
+      :codes (#.sb!vm:simple-array-unsigned-byte-8-widetag)
       :direct-superclasses (vector simple-array)
-      :inherits (vector simple-array array sequence
-		 generic-vector generic-array mutable-sequence
-		 mutable-collection generic-sequence collection))
+      :inherits (vector simple-array array sequence))
      (simple-array-unsigned-byte-16
      :translation (simple-array (unsigned-byte 16) (*))
-     :codes (#.sb!vm:simple-array-unsigned-byte-16-type)
+     :codes (#.sb!vm:simple-array-unsigned-byte-16-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-unsigned-byte-32
      :translation (simple-array (unsigned-byte 32) (*))
-     :codes (#.sb!vm:simple-array-unsigned-byte-32-type)
+     :codes (#.sb!vm:simple-array-unsigned-byte-32-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-8
      :translation (simple-array (signed-byte 8) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-8-type)
+     :codes (#.sb!vm:simple-array-signed-byte-8-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-16
      :translation (simple-array (signed-byte 16) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-16-type)
+     :codes (#.sb!vm:simple-array-signed-byte-16-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-30
      :translation (simple-array (signed-byte 30) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-30-type)
+     :codes (#.sb!vm:simple-array-signed-byte-30-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-signed-byte-32
      :translation (simple-array (signed-byte 32) (*))
-     :codes (#.sb!vm:simple-array-signed-byte-32-type)
+     :codes (#.sb!vm:simple-array-signed-byte-32-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-single-float
      :translation (simple-array single-float (*))
-     :codes (#.sb!vm:simple-array-single-float-type)
+     :codes (#.sb!vm:simple-array-single-float-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
      (simple-array-double-float
      :translation (simple-array double-float (*))
-     :codes (#.sb!vm:simple-array-double-float-type)
+     :codes (#.sb!vm:simple-array-double-float-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
     #!+long-float
     (simple-array-long-float
      :translation (simple-array long-float (*))
-     :codes (#.sb!vm:simple-array-long-float-type)
+     :codes (#.sb!vm:simple-array-long-float-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
     (simple-array-complex-single-float
      :translation (simple-array (complex single-float) (*))
-     :codes (#.sb!vm:simple-array-complex-single-float-type)
+     :codes (#.sb!vm:simple-array-complex-single-float-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
     (simple-array-complex-double-float
      :translation (simple-array (complex double-float) (*))
-     :codes (#.sb!vm:simple-array-complex-double-float-type)
+     :codes (#.sb!vm:simple-array-complex-double-float-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
+     :inherits (vector simple-array array sequence))
     #!+long-float
     (simple-array-complex-long-float
      :translation (simple-array (complex long-float) (*))
-     :codes (#.sb!vm:simple-array-complex-long-float-type)
+     :codes (#.sb!vm:simple-array-complex-long-float-widetag)
      :direct-superclasses (vector simple-array)
-     :inherits (vector simple-array array sequence
-		generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
-    (generic-string
-     :state :read-only
-     :inherits (mutable-sequence mutable-collection generic-sequence
-		collection))
+     :inherits (vector simple-array array sequence))
     (string
      :translation string
-     :codes (#.sb!vm:complex-string-type)
-     :direct-superclasses (vector generic-string)
-     :inherits (vector array sequence
-		generic-vector generic-array generic-string
-		mutable-sequence mutable-collection
-		generic-sequence collection))
+     :codes (#.sb!vm:complex-string-widetag)
+     :direct-superclasses (vector)
+     :inherits (vector array sequence))
     (simple-string
      :translation simple-string
-     :codes (#.sb!vm:simple-string-type)
+     :codes (#.sb!vm:simple-string-widetag)
      :direct-superclasses (string simple-array)
      :inherits (string vector simple-array
-		array sequence
-		generic-string generic-vector generic-array mutable-sequence
-		mutable-collection generic-sequence collection))
-    (generic-number :state :read-only)
-    (number :translation number :inherits (generic-number))
+		array sequence))
+    (list
+     :translation (or cons (member nil))
+     :inherits (sequence))
+    (cons
+     :codes (#.sb!vm:list-pointer-lowtag)
+     :translation cons
+     :inherits (list sequence))
+    (null
+     :translation (member nil)
+     :inherits (symbol list sequence)
+     :direct-superclasses (symbol list))
+    (number :translation number)
     (complex
      :translation complex
-     :inherits (number generic-number)
-     :codes (#.sb!vm:complex-type))
+     :inherits (number)
+     :codes (#.sb!vm:complex-widetag))
     (complex-single-float
      :translation (complex single-float)
-     :inherits (complex number generic-number)
-     :codes (#.sb!vm:complex-single-float-type))
+     :inherits (complex number)
+     :codes (#.sb!vm:complex-single-float-widetag))
     (complex-double-float
      :translation (complex double-float)
-     :inherits (complex number generic-number)
-     :codes (#.sb!vm:complex-double-float-type))
+     :inherits (complex number)
+     :codes (#.sb!vm:complex-double-float-widetag))
     #!+long-float
     (complex-long-float
      :translation (complex long-float)
-     :inherits (complex number generic-number)
-     :codes (#.sb!vm:complex-long-float-type))
-    (real :translation real :inherits (number generic-number))
+     :inherits (complex number)
+     :codes (#.sb!vm:complex-long-float-widetag))
+    (real :translation real :inherits (number))
     (float
      :translation float
-     :inherits (real number generic-number))
+     :inherits (real number))
     (single-float
      :translation single-float
-     :inherits (float real number generic-number)
-     :codes (#.sb!vm:single-float-type))
+     :inherits (float real number)
+     :codes (#.sb!vm:single-float-widetag))
     (double-float
      :translation double-float
-     :inherits (float real number generic-number)
-     :codes (#.sb!vm:double-float-type))
+     :inherits (float real number)
+     :codes (#.sb!vm:double-float-widetag))
     #!+long-float
     (long-float
      :translation long-float
-     :inherits (float real number generic-number)
-     :codes (#.sb!vm:long-float-type))
+     :inherits (float real number)
+     :codes (#.sb!vm:long-float-widetag))
     (rational
      :translation rational
-     :inherits (real number generic-number))
+     :inherits (real number))
     (ratio
      :translation (and rational (not integer))
-     :inherits (rational real number generic-number)
-     :codes (#.sb!vm:ratio-type))
+     :inherits (rational real number)
+     :codes (#.sb!vm:ratio-widetag))
     (integer
      :translation integer
-     :inherits (rational real number generic-number))
+     :inherits (rational real number))
     (fixnum
-     :translation (integer #.sb!vm:*target-most-negative-fixnum*
-			   #.sb!vm:*target-most-positive-fixnum*)
-     :inherits (integer rational real number
-		generic-number)
-     :codes (#.sb!vm:even-fixnum-type #.sb!vm:odd-fixnum-type))
+     :translation (integer #.sb!xc:most-negative-fixnum
+			   #.sb!xc:most-positive-fixnum)
+     :inherits (integer rational real number)
+     :codes (#.sb!vm:even-fixnum-lowtag #.sb!vm:odd-fixnum-lowtag))
     (bignum
      :translation (and integer (not fixnum))
-     :inherits (integer rational real number
-		generic-number)
-     :codes (#.sb!vm:bignum-type))
-
-    (list
-     :translation (or cons (member nil))
-     :inherits (sequence mutable-sequence mutable-collection
-		generic-sequence collection))
-    (cons
-     :codes (#.sb!vm:list-pointer-type)
-     :inherits (list sequence
-		mutable-sequence mutable-collection
-		generic-sequence collection))
-    (null
-     :translation (member nil)
-     :inherits (list sequence
-		mutable-sequence mutable-collection
-		generic-sequence collection symbol)
-     :direct-superclasses (list symbol))
+     :inherits (integer rational real number)
+     :codes (#.sb!vm:bignum-widetag))
     (stream
-     :hierarchical-p nil
      :state :read-only
-     :inherits (instance t)))))
+     :depth 3
+     :inherits (instance)))))
 
 ;;; comment from CMU CL:
 ;;;   See also type-init.lisp where we finish setting up the
 ;;;   translations for built-in types.
 (!cold-init-forms
-  #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*")
   (dolist (x *built-in-classes*)
     #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
     (destructuring-bind
@@ -1084,82 +1132,110 @@
 	      codes
 	      enumerable
 	      state
+              depth
 	      (hierarchical-p t) ; might be modified below
 	      (direct-superclasses (if inherits
 				     (list (car inherits))
 				     '(t))))
 	x
       (declare (ignore codes state translation))
-      (let ((inherits-list (if (eq name 't)
-			     ()
-			     (cons 't (reverse inherits))))
-	    (class (make-built-in-class
-		    :enumerable enumerable
-		    :name name
-		    :translation (if trans-p :initializing nil)
-		    :direct-superclasses
-		    (if (eq name 't)
-		      nil
-		      (mapcar #'sb!xc:find-class direct-superclasses)))))
-	(setf (info :type :kind name) :primitive
-	      (class-cell-class (find-class-cell name)) class)
+      (let ((inherits-list (if (eq name t)
+			       ()
+			       (cons t (reverse inherits))))
+	    (classoid (make-built-in-classoid
+		       :enumerable enumerable
+		       :name name
+		       :translation (if trans-p :initializing nil)
+		       :direct-superclasses
+		       (if (eq name t)
+			   nil
+			   (mapcar #'find-classoid direct-superclasses)))))
+	(setf (info :type :kind name) #+sb-xc-host :defined #-sb-xc-host :primitive
+	      (classoid-cell-classoid (find-classoid-cell name)) classoid)
 	(unless trans-p
-	  (setf (info :type :builtin name) class))
+	  (setf (info :type :builtin name) classoid))
 	(let* ((inherits-vector
-		(map 'vector
+		(map 'simple-vector
 		     (lambda (x)
 		       (let ((super-layout
-			      (class-layout (sb!xc:find-class x))))
+			      (classoid-layout (find-classoid x))))
 			 (when (minusp (layout-depthoid super-layout))
 			   (setf hierarchical-p nil))
 			 super-layout))
 		     inherits-list))
-	       (depthoid (if hierarchical-p (length inherits-vector) -1)))
+	       (depthoid (if hierarchical-p
+                           (or depth (length inherits-vector))
+                           -1)))
 	  (register-layout
 	   (find-and-init-or-check-layout name
 					  0
 					  inherits-vector
 					  depthoid)
 	   :invalidate nil)))))
-  #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*"))
+  (/show0 "done with loop over *BUILT-IN-CLASSES*"))
 
 ;;; Define temporary PCL STANDARD-CLASSes. These will be set up
-;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
+;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
 ;;; is loaded and the class defined.
 (!cold-init-forms
-  (dolist (x '((fundamental-stream (t instance stream))))
+  (/show0 "about to define temporary STANDARD-CLASSes")
+  (dolist (x '(;; Why is STREAM duplicated in this list? Because, when
+               ;; the inherits-vector of FUNDAMENTAL-STREAM is set up,
+               ;; a vector containing the elements of the list below,
+               ;; i.e. '(T INSTANCE STREAM STREAM), is created, and
+               ;; this is what the function ORDER-LAYOUT-INHERITS
+               ;; would do, too.
+               ;;
+               ;; So, the purpose is to guarantee a valid layout for
+               ;; the FUNDAMENTAL-STREAM class, matching what
+               ;; ORDER-LAYOUT-INHERITS would do.
+               ;; ORDER-LAYOUT-INHERITS would place STREAM at index 3
+               ;; in the INHERITS(-VECTOR). Index 2 would not be
+               ;; filled, so STREAM is duplicated there (as
+               ;; ORDER-LAYOUTS-INHERITS would do). Maybe the
+               ;; duplicate definition could be removed (removing a
+               ;; STREAM element), because FUNDAMENTAL-STREAM is
+               ;; redefined after PCL is set up, anyway. But to play
+               ;; it safely, we define the class with a valid INHERITS
+               ;; vector.
+	       (fundamental-stream (t instance stream stream))))
+    (/show0 "defining temporary STANDARD-CLASS")
     (let* ((name (first x))
 	   (inherits-list (second x))
-	   (class (make-standard-class :name name))
-	   (class-cell (find-class-cell name)))
-      (setf (class-cell-class class-cell) class
-	    (info :type :class name) class-cell
+	   (classoid (make-standard-classoid :name name))
+	   (classoid-cell (find-classoid-cell name)))
+      ;; Needed to open-code the MAP, below
+      (declare (type list inherits-list))
+      (setf (classoid-cell-classoid classoid-cell) classoid
+	    (info :type :classoid name) classoid-cell
 	    (info :type :kind name) :instance)
-      (let ((inherits (map 'vector
+      (let ((inherits (map 'simple-vector
 			   (lambda (x)
-			     (class-layout (sb!xc:find-class x)))
+			     (classoid-layout (find-classoid x)))
 			   inherits-list)))
+	#-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
 	(register-layout (find-and-init-or-check-layout name 0 inherits -1)
-			 :invalidate nil)))))
+			 :invalidate nil))))
+  (/show0 "done defining temporary STANDARD-CLASSes"))
 
 ;;; Now that we have set up the class heterarchy, seal the sealed
 ;;; classes. This must be done after the subclasses have been set up.
 (!cold-init-forms
   (dolist (x *built-in-classes*)
     (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
-      (setf (class-state (sb!xc:find-class name)) state))))
+      (setf (classoid-state (find-classoid name)) state))))
 
 ;;;; class definition/redefinition
 
 ;;; This is to be called whenever we are altering a class.
-(defun modify-class (class)
+(defun modify-classoid (classoid)
   (clear-type-caches)
-  (when (member (class-state class) '(:read-only :frozen))
+  (when (member (classoid-state classoid) '(:read-only :frozen))
     ;; FIXME: This should probably be CERROR.
     (warn "making ~(~A~) class ~S writable"
-	  (class-state class)
-	  (sb!xc:class-name class))
-    (setf (class-state class) nil)))
+	  (classoid-state classoid)
+	  (classoid-name classoid))
+    (setf (classoid-state classoid) nil)))
 
 ;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
 ;;; structure type tests to fail. Remove class from all superclasses
@@ -1170,13 +1246,13 @@
   (setf (layout-invalid layout) t
 	(layout-depthoid layout) -1)
   (let ((inherits (layout-inherits layout))
-	(class (layout-class layout)))
-    (modify-class class)
+	(classoid (layout-classoid layout)))
+    (modify-classoid classoid)
     (dotimes (i (length inherits)) ; FIXME: DOVECTOR
       (let* ((super (svref inherits i))
-	     (subs (class-subclasses (layout-class super))))
+	     (subs (classoid-subclasses (layout-classoid super))))
 	(when subs
-	  (remhash class subs)))))
+	  (remhash classoid subs)))))
   (values))
 
 ;;;; cold loading initializations
@@ -1184,14 +1260,14 @@
 ;;; FIXME: It would be good to arrange for this to be called when the
 ;;; cross-compiler is being built, not just when the target Lisp is
 ;;; being cold loaded. Perhaps this could be moved to its own file
-;;; late in the stems-and-flags.lisp-expr sequence, and be put in
+;;; late in the build-order.lisp-expr sequence, and be put in
 ;;; !COLD-INIT-FORMS there?
 (defun !class-finalize ()
   (dohash (name layout *forward-referenced-layouts*)
-    (let ((class (sb!xc:find-class name nil)))
+    (let ((class (find-classoid name nil)))
       (cond ((not class)
-	     (setf (layout-class layout) (make-undefined-class name)))
-	    ((eq (class-layout class) layout)
+	     (setf (layout-classoid layout) (make-undefined-classoid name)))
+	    ((eq (classoid-layout class) layout)
 	     (remhash name *forward-referenced-layouts*))
 	    (t
 	     ;; FIXME: ERROR?
@@ -1209,18 +1285,18 @@
   (setq *built-in-class-codes*
 	(let* ((initial-element
 		(locally
-		  ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
+		  ;; KLUDGE: There's a FIND-CLASSOID DEFTRANSFORM for
 		  ;; constant class names which creates fast but
 		  ;; non-cold-loadable, non-compact code. In this
 		  ;; context, we'd rather have compact, cold-loadable
 		  ;; code. -- WHN 19990928
-		  (declare (notinline sb!xc:find-class))
-		  (class-layout (sb!xc:find-class 'random-class))))
+		  (declare (notinline find-classoid))
+		  (classoid-layout (find-classoid 'random-class))))
 	       (res (make-array 256 :initial-element initial-element)))
 	  (dolist (x *built-in-classes* res)
 	    (destructuring-bind (name &key codes &allow-other-keys)
 				x
-	      (let ((layout (class-layout (sb!xc:find-class name))))
+	      (let ((layout (classoid-layout (find-classoid name))))
 		(dolist (code codes)
 		  (setf (svref res code) layout)))))))
   #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))