diff --git a/code/class.lisp b/code/class.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..6baea15ce4c0f39cdd4af9ae68182a59dd7617fb
--- /dev/null
+++ b/code/class.lisp
@@ -0,0 +1,607 @@
+;;; -*- Package: Kernel -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.1 1993/01/15 15:26:33 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; 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.
+;;;
+(in-package "KERNEL")
+
+(export '(layout layout-hash layout-hash-length layout-class layout-invalid
+		 layout-inherits layout-inheritance-depth layout-length
+		 structure-class-print-function
+		 structure-class-make-load-form-fun find-layout))
+
+(in-package "LISP")
+(export '(class structure-class class-name find-class))
+
+(in-package "KERNEL")
+
+;;; Table mapping class names to layouts for classes we have referenced but not
+;;; yet loaded.
+;;; 
+;;; ### Initialize to list of all layouts created by genesis.  Removed when we
+;;; actually see the definition in top-level code.
+;;; 
+(defvar *forward-referenced-layouts* (make-hash-table :test #'equal))
+
+
+;;;; Class definition structures:
+
+;;; The LAYOUT structure is pointed to by the first cell of instance (or
+;;; structure) objects.  It represents what we need to know for type checking
+;;; and garbage collection.  Whenever a class is incompatibly redefined, a new
+;;; layout is allocated.  If two object's layouts are EQ, then they are exactly
+;;; the same type.
+;;;
+;;; LAYOUTs are treated specially by the dumper so that genesis can help us
+;;; bootstrap the type system.  Only layouts for named classes can be dumped.
+;;; This is resolved at load-time to the current layout for the class of that
+;;; name --- except that genesis simply ensures that only one layout is
+;;; allocated for each class (interns the layouts by name.)  Only the INHERITS,
+;;; INHERITANCE-DEPTH and LENGTH slots are dumped.  In normal load, these slots
+;;; had better agree with any current loaded value.  In cold load, these slots
+;;; are used to create the LAYOUT if it doesn't exist yet (other slots left
+;;; unitialized.)
+;;;
+(defstruct (layout (:print-function %print-layout)
+		   (:make-load-form-fun :ignore-it))
+  ;;
+  ;; Some hash bits for this layout.  Sleazily accessed via STRUCTURE-REF, see
+  ;; LAYOUT-HASH.
+  (hash0 0 :type index)
+  (hash1 0 :type index)
+  (hash2 0 :type index)
+  (hash3 0 :type index)
+  (hash4 0 :type index)
+  (hash5 0 :type index)
+  (hash6 0 :type index)
+  (hash7 0 :type index)
+  ;;
+  ;; The class this is a layout for.
+  (class (required-argument) :type class)
+  ;;
+  ;; NIL if this is the latest layout for this class.  If non-null, then the
+  ;; class was changed after this instance was created.  The exact value may
+  ;; provide some information about what to do.
+  (invalid nil)
+  ;;
+  ;; Vector of the layouts for all classes we inherit.  If hierarchical
+  ;; these are in order from most general down to (but not including) this
+  ;; class.
+  (inherits #() :type simple-vector)
+  ;;
+  ;; Number of classes this class hierachically inherits
+  ;; (length inherits), or -1 if not hierarchical.
+  (inheritance-depth -1 :type (or index (integer -1 -1)))
+  ;;
+  ;; 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.
+  (info nil))
+
+(defconstant layout-hash-length 8)
+(declaim (inline layout-hash))
+(defun layout-hash (layout i)
+  (declare (type layout layout) (type index i))
+  (truly-the index (structure-ref layout (1+ i))))
+
+
+;;; The CLASS structure is a supertype of all CLASS types.  A CLASS is also a
+;;; CTYPE structure as recognized by the type system.
+;;;
+(defstruct (class
+	    (:make-load-form-fun class-make-load-form-fun)
+	    (:include ctype
+		      (:class-info (type-class-or-lose 'class))))
+  ;;
+  ;; Optional name, for printing.
+  (name nil)
+  ;;
+  ;; Current layout for this class.  Null if not assigned yet.
+  (layout nil :type (or layout null))
+  ;;
+  ;; How sure we are that this class won't be redefined.  If :READ-ONLY, we are
+  ;; committed to not changing the effective slots or superclasses.  If
+  ;; :SEALED, we can't even add subclasses.
+  (state nil :type (member nil :read-only :sealed))
+  ;;
+  ;; Representation of all of the subclasses (direct or indirect) of this
+  ;; class.  NIL if no subclasses or not initalized yet.  Otherwise, an EQ
+  ;; hash-table mapping class-objects to the subclass layout that was in effect
+  ;; at the time the subclass was created.
+  (subclasses nil :type (or hash-table null)))
+;;;
+(defun class-make-load-form-fun (class)
+  (let ((name (class-name class)))
+    (unless (and name (eq (find-class name nil) class))
+      (compiler-error
+       "Can't use anonymous or undefined class as constant:~%  ~S"
+       class))
+    `(find-class ',name)))
+
+
+;;; The UNDEFINED-CLASS is a cookie we make up to stick in forward referenced
+;;; layouts.  Users should never see them.
+;;;
+(defstruct (undefined-class
+	    (:include class)
+	    (:constructor make-undefined-class (name))))
+
+
+;;; BUILT-IN-CLASS is used to represent the standard classes that aren't
+;;; defined with DEFSTRUCT and other specially implemented primitve types whose
+;;; only attribute is their name.  Some standard classes are 
+;;;
+(defstruct (built-in-class
+	    (:include class))
+  ;;
+  ;; Translation of this class to some other composite type (usually a union of
+  ;; other classes.)  This translation is done when type specifiers are parsed.
+  ;; Internally we should never encounter translated classes, only their
+  ;; translation.  If NIL, then this class stands on its own.  
+  (translation nil :type (or ctype null))
+  ;;
+  ;; List of names of type-classes which are subtypes of this class.  This is
+  ;; mutually exclusive with TRANSLATION.
+  (type-classes nil :type list))
+
+
+;;; 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.
+;;;
+(defstruct (structure-class (:include class))
+  ;;
+  ;; Structure print function, or NIL if none.
+  (print-function nil :type (or function null))
+  ;;
+  ;; MAKE-LOAD-FORM method, or NIL if none. :J-D-I-N dumps the slots.
+  ;; :IGNORE-IT is used for magic structures which the compiler inserts in IR1,
+  ;; but that are never actually dumped.
+  (make-load-form-fun nil :type (or function symbol
+				    (member :just-dump-it-normally
+					    :ignore-it
+					    nil)))
+  ;;
+  ;; If true, a default keyword constructor for this structure.
+  (constructor nil :type (or function null)))
+
+
+;;;; Class namespace:
+
+;;; FIND-CLASS  --  Public
+;;;
+(defun find-class (name &optional (errorp t) environment)
+  "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 (info type class name)))
+    (if (or res (not errorp))
+	res
+	(error "Class not yet defined:~%  ~S" name))))
+;;;
+(defun (setf find-class) (new-value name)
+  (ecase (info type kind name)
+    (nil)
+    (:structure
+     (let ((old (class-of (info type class name)))
+	   (new (class-of new-value)))
+       (unless (eq old new)
+	 (compiler-warning "Changing meta-class of ~S from ~S to ~S."
+			   name (class-name old) (class-name new)))))
+    (:primitive
+     (compiler-error "Illegal to redefine standard type ~S." name))
+    (:defined
+     (compiler-warning "Redefining DEFTYPE type to be a class: ~S."
+		       name)
+     (setf (info type expander name) nil)))
+
+  (remhash name *forward-referenced-layouts*)
+  (%note-type-defined name)
+  (setf (info type kind name) :structure)
+  (setf (info type class name) new-value))
+
+
+;;; INSURED-FIND-CLASS  --  Interface
+;;;
+;;;    Called when we are about to define Name as class with the specified
+;;; Meta-Class.  The first result is always of the desired class.  The second
+;;; result is any existing layout for this name.
+;;;
+(defun insured-find-class (name meta-class constructor)
+  (let* ((name (dd-name info))
+	 (old (info type class name))
+	 (res (if (and old (eq (class-of old) meta-class))
+		  old
+		  (funcall constructor :name name)))
+	 (found (or (gethash name *forward-referenced-layouts*)
+		    (when old (class-layout old)))))
+    (when found
+      (setf (layout-class found) res))
+
+    (values res found)))
+
+
+;;;; Class type operations:
+
+(define-type-class class)
+
+(define-type-method (instance :simple-subtypep) (class1 class2)
+  (if (eq class1 class2)
+      (values t t)
+      (let ((subclasses (class-subclasses class2)))
+	(if (and subclasses (gethash class1 subclasses))
+	    (values t t)
+	    (values nil t)))))
+
+
+;;; SEALED-CLASS-INTERSECTION  --  Internal
+;;;
+;;;    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)
+  (let ((s-sub (class-subclasses sealed))
+	(o-sub (class-subclasses other)))
+    (if (and s-sub o-sub)
+	(collect ((res *empty-type* type-union))
+	  (do-hash (subclass layout s-sub)
+	    (declare (ignore layout))
+	    (when (gethash subclass o-sub)
+	      (res (specifier-type class))))
+	  (values (res) t))
+	(values *empty-type* t))))
+
+    
+;;; 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 (instance :simple-intersection) (class1 class2)
+  (declare (type class class1 class2))
+  (cond ((eq class1 class2) type1)
+	((let ((subclasses (class-subclasses class2)))
+	   (and subclasses (gethash class1 subclasses)))
+	 (values type1 t))
+	((let ((subclasses (class-subclasses class1)))
+	   (and subclasses (gethash class2 subclasses)))
+	 (values type2 t))
+	((or (structure-class-p class1)
+	     (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))
+	(t
+	 (values type1 nil))))
+
+
+(define-type-method (instance :complex-subtypep-arg2) (type1 type2)
+  (declare (type instance-type type2))
+  (values (or (eq type1 *wild-type*)
+	      (and (eq (type-class-name (type-class-info type1)) 'alien)
+		   (eq (class-name type2) 'alien-value)))
+	  t))
+
+(define-type-method (instance :unparse) (type)
+  (class-proper-name type))
+
+(define-type-method (instance :simple-=) (type1 type2)
+  (values (eq type1 type2) t))
+
+
+;;;; Class definition/redefinition:
+
+;;; MODIFY-CLASS  --  Internal
+;;;
+;;;    Called whenever we are altering a class.  Clear type system caches and
+;;; warn if read-only.
+;;;
+(defun modify-class (class)
+  (clear-type-caches)
+  (when (member (class-state class) '(:read-only :frozen))
+    (warn "Modifing ~(~A~) class ~S; making it writable."
+	  (class-state class) (class-name class))
+    (setf (class-state class) nil)))
+
+
+;;; INVALIDATE-LAYOUT  --  Internal
+;;;
+;;;    Mark a layout as invalid.  Depth -1 causes unsafe structure type tests
+;;; to fail.
+;;;
+(defun invalidate-layout (layout)
+  (setf (layout-invalid layout) t)
+  (setf (layout-inheritance-depth layout) -1))
+
+
+;;; REGISTER-LAYOUT  --  Interface
+;;;
+;;;    Record Layout as the layout for its class, adding it as a subtype of all
+;;; superclasses.  This is the operation that "installs" a layout for a class
+;;; in the type system, clobbering any old layout.  However, this does not
+;;; modify the class namespace; that is a separate operation (think anonymous
+;;; classes.)
+;;; -- If INVALIDATE-P, then all the layouts for any old definition
+;;;    and subclasses are invalidated, and the SUBCLASSES slot is cleared.
+;;  -- If DESTRUCT-P, then there must be an old layout, and this old layout is
+;;;    destructively modified to hold the same type information.
+;;;
+(defun register-layout (layout invalidate-p destruct-p)
+  (let* ((class (layout-class layout))
+	 (class-layout (class-layout class)))
+    (assert (not (eq class-layout layout)))
+    (when class-layout
+      (modify-class class)
+      (do-hash (c l (class-subclasses class))
+	(modify-class c)
+	(when invalidate-p (invalidate-layout l)))
+      (when invalidate-p
+	(invalidate-layout layout)
+	(setf (class-subclasses class) nil)))
+    
+    (cond (destruct-p
+	   (setf (layout-invalid class-layout) (layout-invalid layout))
+	   (setf (layout-inherits class-layout) (layout-inherits layout))
+	   (setf (layout-inheritance-depth class-layout)
+		 (layout-inheritance-depth layout))
+	   (setf (layout-length class-layout) (layout-length layout))
+	   (setf (layout-info class-layout) (layout-info layout)))
+	  (t
+	   (setf (class-layout class) layout)))
+
+    (let ((inherits (layout-inherits layout)))
+      (dotimes (i (length inherits))
+	(let* ((super (svref inherits i))
+	       (subclasses (or (class-subclasses super)
+			       (setf (class-subclasses super)
+				     (make-hash-table :test #'eq)))))
+	  (when (and (eq (class-state super) :sealed)
+		     (not (gethash class subclasses)))
+	    (warn "Subclassing sealed class ~S; unsealing it."
+		  (class-name super))
+	    (setf (class-state super) :read-only))
+	  (setf (gethash class subclasses)
+		(if destruct-p class-layout layout))))))
+
+    (undefined-value))
+
+
+;;; LAYOUT-PROPER-NAME  --  Internal
+;;;
+;;;    Return something we can print to unambiguously describe the class for a
+;;; layout.  If the class has a proper name, return the name, otherwise return
+;;; the class.
+;;;
+(defun layout-name (x)
+  (let* ((class (layout-class x))
+	 (name (class-name class)))
+    (if (and name (eq (find-class name) class))
+	name
+	class)))
+
+
+;;; REDEFINE-LAYOUT-WARNING  --  Interface
+;;;
+;;;    If layouts Old and New differ in any interesting way, then give a
+;;; warning and return T.
+;;;
+(defun redefine-layout-warning (old old-context new new-context)
+  (assert (eq (layout-class old) (layout-class new) class))
+  (let ((name (layout-proper-name old)))
+    (or (let ((oldi (layout-inherits old))
+	      (newi (layout-inherits new)))
+	  (or (when (mismatch oldi newi :key #'layout-proper-name)
+		(compiler-warning
+		 "Change in superclasses of class ~S:~@  ~
+		  ~A superclasses: ~S~%  ~
+		  ~A superclasses: ~S"
+		 name
+		 old-context (map 'list #'layout-proper-name oldi)
+		 new-context (map 'list #'layout-proper-name newi))
+		t)
+	      (let ((diff (mismatch oldi newi)))
+		(when diff
+		  (compiler-warning
+		   "In class ~S:~%  ~
+		    ~A definition of superclass ~S incompatible with ~
+		    ~A definition."
+		   name old-context (layout-name (svref oldi diff))
+		   new-context)
+		  t))))
+	(let ((old-len (layout-length old))
+	      (new-len (layout-length new)))
+	  (unless (= old-len new-len)
+	    (compiler-warning "Change in instance length of class ~S:~%  ~
+			       ~A length: ~D~%  ~
+			       ~A length: ~D"
+			      name
+			      old-context old-len
+			      new-context new-len)
+	    t))
+	(when (/= (layout-inheritance-depth old)
+		  (layout-inheritance-depth new))
+	  (compiler-warning "Change in the inheritance structure of class ~S~@
+			     between the ~A definition and the ~A definition."
+			    name old-context new-context)
+	  t))))
+
+
+;;; FIND-LAYOUT  --  Interface
+;;;
+;;;    Used by the loader to forward-reference layouts for classes whose
+;;; definitions may not have been loaded yet.  This allows type tests to be
+;;; loaded when the type definition hasn't been loaded yet.  Name is the class
+;;; name, Length is the length of instances, Inherits is a simple-vector of the
+;;; layouts for the classes it inherits, and Depth is the Inheritance-Depth.
+;;;
+;;;    If we can't find any existing layout, then we create a new one with the
+;;; supplied information, storing it in *FORWARD-REFERENCED-LAYOUTS*.  If we
+;;; can find the layout, then return it, after checking for compatibility.  If
+;;; incompatible, we allow the layout to be replaced, altered or left alone.
+;;;
+(defun find-layout (name length inherits depth)
+  (let* ((class (or (info type class name)
+		    (make-undefined-class name)))
+	 (old (or (class-layout class)
+		  (gethash name *forward-referenced-layouts*)))
+	 (res (make-layout :class class
+			   :invalid :undefined
+			   :inherits inherits
+			   :inheritance-depth depth
+			   :length length)))
+    (cond ((not old)
+	   (setf (gethash name *forward-referenced-layouts*) res))
+	  ((redefine-layout-warning old "current" res "compile time")
+	   (restart-case
+	       (error "Loading a reference to class ~S when the compile ~@
+		       time definition was incompatible with the current ~
+		       one."
+		      name)
+	     (continue ()
+	       :report "Invalidate current definition."
+	       (warn "New definition of ~S must be loaded eventually." name)
+	       (invalidate-layout old)
+	       (setf (gethash name *forward-referenced-layouts*) res))
+	     (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)
+	       (setf (layout-inherits-depth old) depth)
+	       (setf (layout-inheritance-depth old) inherits)
+	       (setf (layout-length old) length)
+	       old)
+	     (use-current ()
+	       :report "Ignore the incompatibility, leave class alone."
+	       (warn "Assuming the current definition of ~S is correct, and~@
+		      that the loaded code doesn't care about the ~
+		      incompatibility."
+		     name)
+	       old)))
+	  (t old))))
+
+
+;;;; Built-in classes:
+
+;;; ### If any of these layouts are referenced as constants in the cold load,
+;;; then genesis must pre-intern the layouts, and we would actually create the
+;;; classes here.  Probably needs to be an init-function that runs before
+;;; top-level forms.
+
+;;; ### special-case instance, funcallable-instance, null for LAYOUT-OF
+;;;
+(defconstant built-in-classes
+  '((t :subclasses (number array member function structure alien))
+    (character :enumerable t)
+    (base-char :inherits (character) :codes (#.vm:base-char-type)
+	       :enumerable t)
+    (extended-char :inherits (character) :translation nil :enumerable t)
+    (standard-char :inherits (base-char character) :enumerable t)
+
+    (array :tranlation array
+	   :codes
+	   (#.vm:complex-array-type
+	    #.vm:simple-array-type
+	    #.vm:simple-array-double-float-type
+	    #.vm:simple-array-single-float-type
+	    #.vm:simple-array-unsigned-byte-2-type
+	    #.vm:simple-array-unsigned-byte-4-type
+	    #.vm:simple-array-unsigned-byte-8-type
+	    #.vm:simple-array-unsigned-byte-16-type
+	    #.vm:simple-array-unsigned-byte-32-type))
+    (sequence :translation (or cons (member nil) vector))
+    (symbol :codes (#.vm:symbol-header-type))
+    (keyword :inherits (symbol))
+    (system-area-pointer)
+    (weak-pointer)
+    (scavenger-hook)
+    (code-component)
+    (lra)
+    (fdefn)
+
+    (function
+     :codes
+     (#.vm:byte-code-closure-type #.vm:byte-code-function-type
+      #.vm:closure-header-type  #.vm:function-header-type)
+     :subclasses (function))
+    (generic-function :inherits (function)
+		      :subclasses (function)
+		      :codes (#.vm:funcallable-instance-header-type))
+
+    (vector :translation vector :inherits (array sequence)
+	    :codes (#.vm:complex-vector-type #.vm:simple-vector-type))
+    (bit-vector
+     :translation bit-vector  :inherits (vector array sequence)
+     :codes (#.vm:complex-bit-vector-type #.vm:simple-bit-vector-type))
+    (string
+     :translation string  :inherits (vector array sequence)
+     :codes (#.vm:complex-string-type #.vm:simple-string-type))
+
+    (number :translation number)
+    (complex :translation complex :inherits (number)
+	     :codes (#.vm:complex-type))
+    (float :translation float :inherits (number))
+    (single-float
+     :translation single-float :inherits (float number)
+     :codes (#.vm:single-float-type))
+    (double-float
+     :translation double-float  :inherits (float number)
+     :codes (#.vm:double-float-type))
+    (rational :translation rational :inherits (number))
+    (ratio
+     :translation (and rational (not integer))
+     :inherits (rational number)
+     :codes (#.vm:ratio-type))
+    (integer
+     :translation integer  :inherits (rational number)
+     :codes (#.vm:bignum-type  #.vm:even-fixnum-type #.vm:odd-fixnum-type))
+
+    (list :translation (or cons (member nil)) :inherits (sequence))
+    (cons :inherits (list sequence) :codes (#.vm:list-type))
+    (null :translation (member nil) :inherits (symbol list sequence))))
+
+(dolist (x built-in-classes)
+  (let* ((name (first x))
+	 (class (make-built-in-class name (specifier-type name)))
+	 (layout (make-layout
+		  :class class
+		  :inherits (map 'vector #'find-layout (reverse (rest x))))))
+    (register-layout layout nil nil)
+    (setf (info type class name) class)))
+
+(dolist (x built-in-classes)
+  (setf (class-state (find-class (first x))) :frozen))
+
+(defconstant built-in-class-codes
+  (let ((res (make-array 256 :initial-element nil)))
+    (dolist (x built-in-classes)
+      (let ((layout (class-layout (find-class (first x)))))
+	(dolist (code (third x))
+	  (setf (svref res code) layout))))))
+
+(defun layout-of (x)
+  (cond ((%instancep x) (%instance-layout x))
+	((null x) (load-time-value (class-layout (find-class 'null))))
+	((svref built-in-class-codes (vm:get-type x)))
+	(t
+	 (error "Some strange object: ~S" x))))
+
+(defun class-of (x) (class-layout (layout-of x)))