diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index 268d8bbbd09457e9ccc638e7409510c52e230bed..427069ea112caeb9a9ac58db6c8e72a5b9389058 100644
--- a/pcl/cache.lisp
+++ b/pcl/cache.lisp
@@ -147,6 +147,9 @@
   (vector #() :type simple-vector)
   (overflow nil :type list))
 
+#+cmu
+(declaim (ext:freeze-type cache))
+
 (defun print-cache (cache stream depth)
   (declare (ignore depth))
   (printing-random-thing (cache stream)
@@ -243,10 +246,14 @@
 ;;; forms of this constant which it is more convenient for the runtime code
 ;;; to use.
 ;;; 
+#-cmu17
 (eval-when (compile load eval)
 
 (defconstant wrapper-cache-number-adds-ok 4)
 
+;;; Incorrect.  This actually allows 15 or 16 adds, depending on whether
+;;; most-positive-fixnum is all-ones.  -- Ram
+;;;
 (defconstant wrapper-cache-number-length
 	     (- (integer-length most-positive-fixnum)
 		wrapper-cache-number-adds-ok))
@@ -275,6 +282,16 @@
           You may want to consider changing the value of the constant~@
           WRAPPER-CACHE-NUMBER-ADDS-OK.")))
 
+#+cmu17
+(progn
+  (defconstant wrapper-cache-number-length
+    (integer-length kernel:layout-hash-max))
+  
+  (defconstant wrapper-cache-number-mask kernel:layout-hash-max)
+  
+  (defconstant wrapper-cache-number-adds-ok
+    (truncate most-positive-fixnum kernel:layout-hash-max)))
+
 
 ;;;
 ;;; wrappers themselves
@@ -384,10 +401,12 @@
 #+structure-wrapper
 (eval-when (compile load eval)
 
-(defconstant wrapper-cache-number-vector-length 8)
+(defconstant wrapper-cache-number-vector-length
+  #+cmu17 kernel:layout-hash-length #-cmu17 8)
 
+#-cmu17
 (deftype cache-number-vector ()
-  `(simple-array fixnum (8)))
+  `(simple-array fixnum (,wrapper-cache-number-vector-length)))
 
 (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
 				       :initial-element 'number))
@@ -397,7 +416,7 @@
 #+structure-wrapper
 (progn
 
-#-new-kcl-wrapper
+#-(or new-kcl-wrapper cmu17)
 (defun make-wrapper-cache-number-vector ()
   (let ((cnv (make-array #.wrapper-cache-number-vector-length
 			 :element-type 'fixnum)))
@@ -405,6 +424,8 @@
       (setf (aref cnv i) (get-wrapper-cache-number)))
     cnv))
 
+
+#-cmu17
 (defstruct (wrapper
 	     #+new-kcl-wrapper (:include si::basic-wrapper)
 	     (:print-function print-wrapper)
@@ -426,12 +447,61 @@
   #-new-kcl-wrapper
   (class *the-class-t* :type class))
 
+
 (unless (boundp '*the-class-t*) (setq *the-class-t* nil))
 
 #+new-kcl-wrapper
 (defmacro wrapper-no-of-instance-slots (wrapper)
   `(si::s-data-length ,wrapper))
 
+
+;;; Note that for CMU, the WRAPPER of a built-in or structure class will be
+;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only
+;;; two slots that WRAPPER adds are meaningless in those cases.
+;;;
+#+cmu17
+(progn
+  (defstruct (wrapper
+	      (:include kernel:layout)
+	      (:conc-name %wrapper-)
+	      (:print-function print-wrapper)
+	      (:constructor make-wrapper-internal))
+    (instance-slots-layout nil :type list)
+    (class-slots nil :type list))
+  (declaim (ext:freeze-type wrapper))
+
+  (defmacro wrapper-class (wrapper)
+    `(kernel:class-pcl-class (kernel:layout-class ,wrapper)))
+  (defmacro wrapper-no-of-instance-slots (wrapper)
+    `(kernel:layout-length ,wrapper))
+  (declaim (inline wrapper-state (setf wrapper-state)))
+
+  (defun wrapper-state (wrapper)
+    (let ((invalid (kernel:layout-invalid wrapper)))
+      (cond ((null invalid)
+	     t)
+	    ((atom invalid)
+	     ;; Some non-pcl object.  invalid is probably :INVALID
+	     ;; We should compute the new wrapper here instead
+	     ;; of returning nil, but why bother, since
+	     ;; obsolete-instance-trap can't use it.
+	     '(:obsolete nil))
+	    (t
+	     invalid))))
+  
+  (defun (setf wrapper-state) (new-value wrapper)
+    (setf (kernel:layout-invalid wrapper)
+	  (if (eq new-value 't)
+	      nil
+	      new-value)))
+
+  (defmacro wrapper-instance-slots-layout (wrapper)
+    `(%wrapper-instance-slots-layout ,wrapper))
+  (defmacro wrapper-class-slots (wrapper)
+    `(%wrapper-class-slots ,wrapper))
+  (defmacro wrapper-cache-number-vector (x) x))
+
+
 #+new-kcl-wrapper
 (defun make-wrapper (size &optional class)
   (multiple-value-bind (raw slot-positions)
@@ -449,6 +519,62 @@
 			   :size (* size #.(si::size-of t))
 			   :class class)))
 
+#+cmu17
+;;; BOOT-MAKE-WRAPPER  --  Interface
+;;;
+;;;    Called in BRAID when we are making wrappers for classes whose slots are
+;;; not initialized yet, and which may be built-in classes.  We pass in the
+;;; class name in addition to the class.
+;;;
+(defun boot-make-wrapper (length name &optional class)
+  (let ((found (lisp:find-class name nil)))
+    (cond
+     (found
+      (unless (kernel:class-pcl-class found)
+	(setf (kernel:class-pcl-class found) class))
+      (assert (eq (kernel:class-pcl-class found) class))
+      (let ((layout (kernel:class-layout found)))
+	(assert layout)
+	layout))
+     (t
+      (kernel:initialize-layout-hash
+       (make-wrapper-internal
+	:length length
+	:class (kernel:make-standard-class :name name :pcl-class class)))))))
+
+
+#+cmu17
+;;; MAKE-WRAPPER  --  Interface
+;;;
+;;;    In CMU CL, the layouts (a.k.a wrappers) for built-in and structure
+;;; classes already exist when PCL is initialized, so we don't necessarily
+;;; always make a wrapper.  Also, we help maintain the mapping between
+;;; lisp:class and pcl::class objects.
+;;;
+(defun make-wrapper (length class)
+  (cond
+   ((typep class 'std-class)
+    (kernel:initialize-layout-hash
+     (make-wrapper-internal
+      :length length
+      :class
+      (let ((owrap (class-wrapper class)))
+	(cond (owrap
+	       (kernel:layout-class owrap))
+	      ((*subtypep (class-of class)
+			  *the-class-standard-class*)
+	       (kernel:make-standard-class :pcl-class class))
+	      (t
+	       (kernel:make-random-pcl-class :pcl-class class)))))))
+   (t
+    (let* ((found (lisp:find-class (slot-value class 'name)))
+	   (layout (kernel:class-layout found)))
+      (unless (kernel:class-pcl-class found)
+	(setf (kernel:class-pcl-class found) class))
+      (assert (eq (kernel:class-pcl-class found) class))
+      (assert layout)
+      layout))))
+
 (defun print-wrapper (wrapper stream depth)
   (declare (ignore depth))
   (printing-random-thing (wrapper stream)
@@ -461,26 +587,37 @@
   `(and (< ,field-number #.(1- wrapper-cache-number-vector-length))
         (1+ ,field-number)))
 
+#-cmu17
 (defmacro cache-number-vector-ref (cnv n)
   `(#-kcl svref #+kcl aref ,cnv ,n))
 
+#+cmu17
+(defmacro cache-number-vector-ref (cnv n)
+  `(wrapper-cache-number-vector-ref ,cnv ,n))
+
 )
 
+#-cmu17
 (defmacro wrapper-cache-number-vector-ref (wrapper n)
   `(the fixnum
         (#-structure-wrapper svref #+structure-wrapper aref
           (wrapper-cache-number-vector ,wrapper) ,n)))
+#+cmu17
+(defmacro wrapper-cache-number-vector-ref (wrapper n)
+  `(kernel:layout-hash ,wrapper ,n))
 
 (defmacro class-no-of-instance-slots (class)
   `(wrapper-no-of-instance-slots (class-wrapper ,class)))
 
 (defmacro wrapper-class* (wrapper)
-  #-new-kcl-wrapper
+  #-(or new-kcl-wrapper cmu17)
   `(wrapper-class ,wrapper)
-  #+new-kcl-wrapper
+  #+(or new-kcl-wrapper cmu17)
   `(let ((wrapper ,wrapper))
      (or (wrapper-class wrapper)
-         (find-structure-class (si::s-data-name wrapper)))))
+         (find-structure-class
+	  #+new-kcl-wrapper (si::s-data-name wrapper)
+	  #+cmu17 (lisp:class-name (kernel:layout-class wrapper))))))
 
 ;;;
 ;;; The wrapper cache machinery provides general mechanism for trapping on
@@ -555,6 +692,7 @@
 		 (error "Wrapper returned from trap invalid.")))
 	  nwrapper))))
 
+#-cmu17
 (defmacro check-wrapper-validity1 (object)
   (let ((owrapper (gensym)))
     `(let ((,owrapper (cond ((std-instance-p ,object)
@@ -569,6 +707,16 @@
 	   ,owrapper
 	   (check-wrapper-validity ,object)))))
 
+#+cmu17
+;;; semantically equivalent, but faster.
+;;;
+(defmacro check-wrapper-validity1 (object)
+  (let ((owrapper (gensym)))
+    `(let ((,owrapper (kernel:layout-of object)))
+       (if (kernel:layout-invalid ,owrapper)
+	   (check-wrapper-validity ,object)
+	   ,owrapper))))
+
 
 (defvar *free-caches* nil)
 
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index 747be0110cacc562e7468f31b9d15eabe6c5eeba..6a7f900f37fb6bc6ca67132c50d85476be4f7071 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -150,7 +150,14 @@
               (error "The value of the :metaclass option (~S) is not a~%~
                       legal class name."
                      (cadr option)))
+	    #-cmu17
             (setq metaclass (cadr option))
+	    #+cmu17
+	    (setq metaclass
+		  (case (cadr option)
+		    (lisp:standard-class 'standard-class)
+		    (lisp:structure-class 'structure-class)
+		    (t (cadr option))))
 	    (setf options (remove option options))
 	    (return t))))
 
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 99a18934c04930cfbb37e710a5a59c70ae4007b9..fdb8d486e7b471f1ff41197d3413e95e98451b2e 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -34,7 +34,8 @@
 (defvar *defmethod-times*  '(load eval))
 (defvar *defgeneric-times* '(load eval))
 
-(defvar *boot-state* ())			;NIL
+; defvar is now actually in macros
+;(defvar *boot-state* ())			;NIL
 						;EARLY
 						;BRAID
 						;COMPLETE
@@ -74,6 +75,7 @@
 		       (non-setf-var . non-setf-case)
 		       (setf-var . setf-case))
   (declare (indentation 1 1))
+  #+setf (declare (ignore setf-var setf-case))
   (once-only (spec)
     `(cond (#-setf (symbolp ,spec) #+setf t
 	    (let ((,non-setf-var ,spec)) ,@non-setf-case))
@@ -212,12 +214,16 @@
                     *the-wrapper-of-complex* *the-wrapper-of-character*
                     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
 
+;;;; Type specifier hackery:
+
+;;; internal to this file.
 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
   (if (symbolp class)
       (or (find-class class (not make-forward-referenced-class-p))
 	  (ensure-class class))
       class))
 
+;;; Interface
 (defun specializer-from-type (type &aux args)
   (when (consp type)
     (setq args (cdr type) type (car type)))
@@ -229,8 +235,13 @@
 					 :object (coerce-to-class (car args))))
 	       (class-eq (class-eq-specializer (coerce-to-class (car args))))
 	       (eql      (intern-eql-specializer (car args))))))
+	#+cmu17
+	((and (null args) (typep type 'lisp:class))
+	 (or (kernel:class-pcl-class type)
+	     (find-structure-class (lisp:class-name type))))
 	((specializerp type) type)))
 
+;;; interface
 (defun type-from-specializer (specl)
   (cond ((eq specl 't)
 	 't)
@@ -299,12 +310,12 @@
   `(satisfies ,(make-class-eq-predicate class)))
 ||#
 
-#-excl
+#-(or excl cmu17)
 (deftype eql (type-object)
   `(member ,type-object))
 
 
-
+;;; Internal to this file.
 ;;;
 ;;; These functions are a pale imitiation of their namesake.  They accept
 ;;; class objects or types where they should.
@@ -328,9 +339,13 @@
         (t
          (error "~s is not a type" type))))
 
+;;; Not used...
+#+nil
 (defun unparse-type-list (tlist)
   (mapcar #'unparse-type tlist))
 
+;;; Not used...
+#+nil
 (defun unparse-type (type)
   (if (atom type)
       (if (specializerp type)
@@ -342,16 +357,21 @@
         (class (class-name (cadr type)))
         (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
 
+;;; internal to this file...
 (defun convert-to-system-type (type)
   (case (car type)
-    ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type))))
-    (class (class-name (cadr type))) ; it had better be a named class
-    (class-eq (class-name (cadr type))) ; this one is impossible to do right
+    ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
+					  (cdr type))))
+    ((class class-eq) ; class-eq is impossible to do right
+     #-cmu17 (class-name (cadr type))
+     #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
     (eql type)
     (t (if (null (cdr type))
 	   (car type)
 	   type))))
 
+;;; not used...
+#+nil
 (defun *typep (object type)
   (setq type (*normalize-type type))
   (cond ((member (car type) '(eql wrapper-eq class-eq class))
@@ -361,6 +381,9 @@
         (t
          (typep object (convert-to-system-type type)))))
 
+
+;;; *SUBTYPEP  --  Interface
+;;;
 ;Writing the missing NOT and AND clauses will improve
 ;the quality of code generated by generate-discrimination-net, but
 ;calling subtypep in place of just returning (values nil nil) can be
@@ -390,6 +413,7 @@
 			 (convert-to-system-type type2))))))))
 
 (defun do-satisfies-deftype (name predicate)
+  #+cmu17 (declare (ignore name predicate))
   #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
   (let* ((specifier `(satisfies ,predicate))
 	 (expand-fn #'(lambda (&rest ignore)
@@ -406,7 +430,7 @@
 	(setf (get name 'excl::deftype-expander) expand-fn)
 	#+:coral
 	(setf (get name 'ccl::deftype-expander) expand-fn)))
-  #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
+  #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)
   ;; This is the default for ports for which we don't know any
   ;; better.  Note that for most ports, providing this definition
   ;; should just speed up class definition.  It shouldn't have an
@@ -547,6 +571,40 @@
 		 list)     ()                       (symbol list sequence t)
      nil)))
 
+#+cmu17
+(labels ((direct-supers (class)
+	   (if (typep class 'lisp:built-in-class)
+	       (kernel:built-in-class-direct-superclasses class)
+	       (let ((inherits (kernel:layout-inherits
+				(kernel:class-layout class))))
+		 (list (svref inherits (1- (length inherits)))))))
+	 (direct-subs (class)
+	   (ext:collect ((res))
+	     (let ((subs (kernel:class-subclasses class)))
+	       (when subs
+		 (ext:do-hash (sub v subs)
+		   (declare (ignore v))
+		   (when (member class (direct-supers sub))
+		     (res sub)))))
+	     (res))))
+  (ext:collect ((res))
+    (dolist (bic kernel::built-in-classes)
+      (let* ((name (car bic))
+	     (class (lisp:find-class name)))
+	(unless (member name '(t kernel:instance kernel:funcallable-instance
+				 function))
+	  (res `(,name
+		 ,(mapcar #'lisp:class-name (direct-supers class))
+		 ,(mapcar #'lisp:class-name (direct-subs class))
+		 ,(map 'list #'(lambda (x)
+				 (lisp:class-name (kernel:layout-class x)))
+		       (reverse
+			(kernel:layout-inherits
+			 (kernel:class-layout class))))
+		 ,(let ((found (assoc name *built-in-classes*)))
+		    (if found (fifth found) 42)))))))
+    (setq *built-in-classes* (res))))
+
 
 ;;;
 ;;; The classes that define the kernel of the metabraid.
@@ -554,15 +612,27 @@
 (defclass t () ()
   (:metaclass built-in-class))
 
-(defclass slot-object (t) ()
+#+cmu17
+(progn
+  (defclass kernel:instance (t) ()
+    (:metaclass built-in-class))
+  
+  (defclass function (t) ()
+    (:metaclass built-in-class))
+
+  (defclass kernel:funcallable-instance (function) ()
+    (:metaclass built-in-class)))
+
+(defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()
   (:metaclass slot-class))
 
 (defclass structure-object (slot-object) ()
   (:metaclass structure-class))
 
-(defstruct (structure-object
+(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object
 	     (:constructor |STRUCTURE-OBJECT class constructor|)))
 
+
 (defclass standard-object (slot-object) ())
 
 (defclass metaobject (standard-object) ())
@@ -836,7 +906,8 @@
 (defclass generic-function (dependent-update-mixin
 			    definition-source-mixin
 			    documentation-mixin
-			    metaobject)
+			    metaobject
+			    #+cmu17 kernel:funcallable-instance)
      ()
   (:metaclass funcallable-standard-class))
     
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index 210c613e2720a06ba06e16724c730b7739e37d9e..f84658c2ce06dd9e3ff00b374c75b1b214947916 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -218,7 +218,7 @@
 ;;; 
 (defvar *the-pcl-package* (find-package :pcl))
 
-(defvar *pcl-system-date* "September 16 92 PCL (e)")
+(defvar *pcl-system-date* "September 16 92 PCL (f)")
 
 #+cmu
 (setf (getf ext:*herald-items* :pcl)
@@ -301,22 +301,7 @@
 (eval-when (eval compile load)
   (pushnew :excl-sun4 *features*))
 
-#+cmu
-(eval-when (compile load eval)
-  (let ((vs (lisp-implementation-version)))
-    (cond ((and (<= 2 (length vs))
-		(eql #\1 (aref vs 0))
-		(let ((d (digit-char-p (aref vs 1))))
-		  (and d (<= 6 d))))
-	   (pushnew :cmu16 *features*))
-	  ((string= "20-Dec-1992" vs)
-	   (pushnew :cmu16 *features*)
-	   (pushnew :cmu17 *features*)
-	   (when (fboundp 'pcl::original-defstruct)
-	     (setf (macro-function 'defstruct)
-		   (macro-function 'pcl::original-defstruct))))
-	  (t
-	   (error "what version of cmucl is this?")))))
+
 
 ;;; Yet Another Sort Of General System Facility and friends.
 ;;;
@@ -652,6 +637,9 @@ and load your system with:
   (declare (ignore ignore))
   't)
 
+#+cmu17
+(defparameter *byte-files* '(defclass defcombin iterate env))
+
 (defun operate-on-system (name mode &optional arg print-only)
   (let ((system (get-system name)))
     (unless system (error "Can't find system with name ~S." name))
@@ -673,7 +661,12 @@ and load your system with:
 				   :output-file
 				   (make-pathname :defaults
 						  (make-binary-pathname name)
-						  :version :newest))))))
+						  :version :newest)
+				   #+cmu17 :byte-compile #+cmu17
+				   (if (and (member name *byte-files*)
+					    (member :small *features*))
+				       t
+				       :maybe))))))
 	(#+Genera
 	 compiler:compiler-warnings-context-bind
 	 #+TI
@@ -773,15 +766,15 @@ and load your system with:
     #+cmu17 *load-truename*
     #-(or Lispm excl Xerox (and dec vax common) LUCID akcl cmu17) nil))
 
-#-(or (and cmu (not cmu17)) Symbolics)
+#-(or cmu Symbolics)
 (defvar *pcl-directory*
 	(or (load-truename t)
 	    (error "Because load-truename is not implemented in this port~%~
                     of PCL, you must manually edit the definition of the~%~
                     variable *pcl-directory* in the file defsys.lisp.")))
 
-#+(and cmu (not cmu17))
-(defvar *pcl-directory* (pathname "pcl:"))
+#+cmu 
+(defvar *pcl-directory* (pathname "target:pcl/"))
 
 #+Genera
 (defvar *pcl-directory*
@@ -1048,8 +1041,6 @@ and load your system with:
 		(or (c::info setf inverse sym)
 		    (c::info setf expander sym)
 		    (c::info type kind sym)
-		    (c::info type structure-info sym)
-		    (c::info type defined-structure-info sym)
 		    (c::info function macro-function sym)
 		    (c::info function compiler-macro-function sym)))
 	    (unintern sym pkg)
diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp
index f8538ad5f6b1f37f4c698c5d108ef7f1867ea9a4..0fe3b48389bdd7620717860d5fdb0f1538aaf765 100644
--- a/pcl/dlisp.lisp
+++ b/pcl/dlisp.lisp
@@ -104,7 +104,7 @@
 	 (lambda `(lambda ,closure-variables
 		    ,@(when (member 'miss-fn closure-variables)
 			`((declare (type function miss-fn))))
-		    #'(lambda ,args
+		    #'(#+cmu kernel:instance-lambda #-cmu lambda ,args
 			#+copy-&rest-arg
 			,@(when rest
 			    `((setq .lap-rest-arg.
@@ -117,6 +117,12 @@
 		(compile-lambda lambda))
 	    nil)))
 
+;;; cmu17 note: since std-instance-p is weakened, that branch may run
+;;; on non-pcl instances (structures).  The result will be the 
+;;; non-wrapper layout for the structure, which will cause a miss.  The "slots"
+;;; will be whatever the first slot is, but will be ignored.  Similarly,
+;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
+;;;
 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
   (when (and (null *precompiling-lap*) *emit-function-p*)
     (return-from emit-reader/writer
@@ -392,6 +398,12 @@
 					 #-lucid `(the fixnum ,form))))))))
 		 wrappers))))
      
+;;; cmu17 note: since std-instance-p is weakened, that branch may run
+;;; on non-pcl instances (structures).  The result will be the 
+;;; non-wrapper layout for the structure, which will cause a miss.  The "slots"
+;;; will be whatever the first slot is, but will be ignored.  Similarly,
+;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
+;;;
 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
   (ecase metatype
     ((standard-instance #+new-kcl-wrapper structure-instance)
diff --git a/pcl/env.lisp b/pcl/env.lisp
index 000ee3e7837cc2630d36d0d12b7422169efb10b1..7c286fa77ca217ead9924e4daa9a2a464e435025 100644
--- a/pcl/env.lisp
+++ b/pcl/env.lisp
@@ -67,12 +67,15 @@
     (values)))
 
 (defmethod describe-object (object stream)
-  (let ((*standard-output* stream))
+  #-cmu
     (cond ((or #+kcl (packagep object))
 	   (describe-package object stream))
 	  (t
-	   (funcall (original-definition 'describe) object)))))
+	   (funcall (original-definition 'describe) object)))
+  #+cmu
+  (describe object stream))
 
+#-cmu
 (redefine-function 'describe 'pcl-describe)
 
 )
@@ -218,7 +221,7 @@
   (format stream "~&Its rehash-size is ~d."
 	  (lisp::hash-table-rehash-size object))
   (format stream "~&Its rehash-threshold is ~d."
-	  (lisp::hash-table-rehash-threshold object))
+	  (hash-table-rehash-threshold object))
   (format stream "~&It currently holds ~d entries."
 	  (lisp::hash-table-number-entries object)))
 
@@ -329,3 +332,75 @@
 (pushnew :pcl *features*)
 (pushnew :portable-commonloops *features*)
 (pushnew :pcl-structures *features*)
+
+#+cmu
+(when (find-package "OLD-PCL")
+  (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
+        (symbol-function 'pcl::print-object)))
+
+
+;;;; MAKE-LOAD-FORM
+
+#+cmu17
+(export '(cl::make-load-form cl::make-load-form-saving-slots) "CL")
+
+#+cmu17
+(progn
+  (defgeneric make-load-form (object &optional environment))
+
+  (defmethod make-load-form ((object structure-object) &optional environment)
+    (declare (ignore environment))
+    (kernel:make-structure-load-form object))
+
+  (defmethod make-load-form ((object wrapper) &optional env)
+    (declare (ignore env))
+    (let ((pname (kernel:class-proper-name (kernel:layout-class object))))
+      (unless pname
+	(error "Can't dump wrapper for anonymous class:~%  ~S"
+	       (kernel:layout-class object)))
+      `(kernel:class-layout (lisp:find-class ',pname))))
+
+  (defun make-load-form-saving-slots (object &key slot-names environment)
+    (declare (ignore environment))
+    (when slot-names
+      (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~
+	     slots:~%  ~S"
+	    object))
+    :just-dump-it-normally))
+
+
+;;; The following are hacks to deal with CMU CL having two different CLASS
+;;; classes.
+;;;
+#+cmu17
+(defun coerce-to-pcl-class (class)
+  (if (typep class 'lisp:class)
+      (or (kernel:class-pcl-class class)
+	  (find-structure-class (lisp:class-name class)))
+      class))
+
+#+cmu17
+(progn
+  (defmethod make-instance ((class lisp:class) &rest stuff)
+    (apply #'make-instance (coerce-to-pcl-class class) stuff))
+  (defmethod change-class (instance (class lisp:class))
+    (apply #'change-class instance (coerce-to-pcl-class class))))
+
+#+cmu17
+(macrolet ((frob (&rest names)
+	     `(progn
+		,@(mapcar #'(lambda (name)
+			      `(defmethod ,name ((class lisp:class))
+				 (funcall #',name
+					  (coerce-to-pcl-class class))))
+			  names))))
+  (frob
+    class-direct-slots
+    class-prototype
+    class-precedence-list
+    class-direct-default-initargs
+    class-direct-superclasses
+    compute-class-precedence-list
+    class-default-initargs class-finalized-p
+    class-direct-subclasses class-slots
+    make-instances-obsolete))
diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp
index 31224265c19e4bfabcb508400c48b497759b5073..b475c5fac17dbfa4a1d283ba5774cc538569e178 100644
--- a/pcl/fast-init.lisp
+++ b/pcl/fast-init.lisp
@@ -562,14 +562,25 @@
 (defun make-default-initargs-form-list (class keys &optional (separate-p t))
   (let ((initargs-form-list (cons nil nil))
 	(default-initargs (class-default-initargs class))
-	(nkeys keys))
+	(nkeys keys)
+	(slots-alist
+	 (mapcan #'(lambda (slot)
+		     (mapcar #'(lambda (arg)
+				 (cons arg slot))
+			     (slot-definition-initargs slot)))
+		 (class-slots class)))
+	(nslots nil))
+    (dolist (key nkeys)
+      (pushnew (cdr (assoc key slots-alist)) nslots))
     (dolist (default default-initargs)
-      (let ((key (car default))
-	    (function (cadr default)))
-	(unless (member key nkeys)
+      (let* ((key (car default))
+	     (slot (cdr (assoc key slots-alist)))
+	     (function (cadr default)))
+	(unless (member slot nslots)
 	  (add-forms `((funcall ,function) (push-initarg ,key))
 		     initargs-form-list)
-	  (push key nkeys))))
+	  (push key nkeys)
+	  (push slot nslots))))
     (when separate-p
       (add-forms `((update-initialize-info-cache
 		    ,class ,(initialize-info class nkeys nil)))
@@ -886,3 +897,36 @@
 	    (iis-body ,@body)
 	    initargs))
      (list pv-cell (coerce cvector cvector-type)))))
+
+
+;The effect of this is to cause almost all of the overhead of make-instance
+;to happen at load time (or maybe at precompile time, as explained in a 
+;previous message) rather than the first time make-instance is called with 
+;a given class-name and sequence of keywords.  
+
+;This optimization applys only when the first argument and all the even 
+;numbered arguments are constants evaluating to interned symbols.
+
+#+cmu
+(declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
+
+; Use this definition in any CL implementation supporting 
+; both define-compiler-macro and load-time-value.
+#+cmu
+(define-compiler-macro make-instance (&whole form &rest args)
+  (declare (ignore args))
+  (let* ((*make-instance-function-keys* nil)
+	 (expanded-form (expand-make-instance-form form)))
+    (if expanded-form
+	`(funcall (symbol-function
+		   ;; The symbol is guaranteed to be fbound.
+		   ;; Is there a way to declare this?
+		   (load-time-value
+		    (get-make-instance-function-symbol 
+		     ',(first *make-instance-function-keys*))))
+		  ,@(cdr expanded-form))
+	form)))
+
+(defun get-make-instance-function-symbol (key)
+  (get-make-instance-functions (list key))
+  (make-instance-function-symbol key))
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
index 5328c488046c55ac02ea3f46562f9f7b6bad0414..c5edfc06df35d83cf0389abac8e1f62ee2285d6b 100644
--- a/pcl/fin.lisp
+++ b/pcl/fin.lisp
@@ -1247,63 +1247,28 @@ dbg:
 
 ;;;; Implementation of funcallable instances for CMU Common Lisp:
 ;;;
-;;;    We represent a FIN like a closure, but the header has a distinct type
-;;; tag.  The FIN data slots are stored at the end of a fixed-length closure
-;;; (at FIN-DATA-OFFSET.)  When the function is set to a closure that has no
-;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN
-;;; with the closure slots.  If the closure has too many slots, we must
-;;; indirect through a trampoline with a rest arg.  For non-closures, we just
-;;; set the function slot.
-;;;
-;;;    We can get away with this efficient and relatively simple scheme because
-;;; the compiler currently currently only references closure slots during the
-;;; initial call and on entry into the function.  So we don't have to worry
-;;; about bad things happening when the FIN is clobbered (the problem JonL
-;;; flames about somewhere...)
-;;;
-;;;    We also stick in a slot for the function name at the end, but before the
-;;; data slots.
+(defstruct (pcl-funcallable-instance
+	    (:alternate-metaclass kernel:funcallable-instance
+				  kernel:random-pcl-class
+				  kernel:make-random-pcl-class)
+	    (:type kernel:funcallable-structure)
+	    (:constructor allocate-funcallable-instance-1 ())
+	    (:conc-name nil))
+  ;;
+  ;; PCL wrapper is in the layout slot.
+  ;;
+  ;; PCL data vector.
+  (pcl-funcallable-instance-slots nil)
+  ;;
+  ;; The debug-name for this function.
+  (funcallable-instance-name nil))
 
 #+CMU
+;;; Note: returns true for non-pcl funcallable structures.
 (import 'kernel:funcallable-instance-p)
 
 #+CMU
 (progn
-
-(eval-when (compile load eval)
-  ;;; The offset of the function's name & the max number of real closure slots.
-  ;;;
-  (defconstant fin-name-slot 14)
-  
-  ;;; The offset of the data slots.
-  ;;;
-  (defconstant fin-data-offset 15))
-
-
-;;; ALLOCATE-FUNCALLABLE-INSTANCE-1  --  Interface
-;;;
-;;;    Allocate a funcallable instance, setting the function to an error
-;;; function and initializing the data slots to NIL.
-;;;
-(defun allocate-funcallable-instance-1 ()
-  (let* ((len (+ (length funcallable-instance-data) fin-data-offset))
-         (res (kernel:%make-funcallable-instance
-               len
-               #'called-fin-without-function)))
-    (dotimes (i (length funcallable-instance-data))
-      (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))
-    (kernel:%set-funcallable-instance-info res fin-name-slot nil)
-    res))
-
-
-;;; FUNCALLABLE-INSTANCE-P  --  Interface
-;;;
-;;;    Return true if X is a funcallable instance.  This is an interpreter
-;;; stub; the compiler directly implements this function.
-;;;
-(defun funcallable-instance-p (x) (funcallable-instance-p x))
-
-
 ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface
 ;;;
 ;;;    Set the function that is called when FIN is called.
@@ -1311,80 +1276,23 @@ dbg:
 (defun set-funcallable-instance-function (fin new-value)
   (declare (type function new-value))
   (assert (funcallable-instance-p fin))
-  (ecase (kernel:get-type new-value)
-    (#.vm:closure-header-type
-     (let ((len (- (kernel:get-closure-length new-value)
-                   (1- vm:closure-info-offset))))
-       (cond ((> len fin-name-slot)
-              (set-funcallable-instance-function
-               fin
-               #'(lambda (&rest args)
-                   (apply new-value args))))
-             (t
-              (dotimes (i fin-data-offset)
-                (kernel:%set-funcallable-instance-info
-                 fin i
-                 (if (>= i len)
-                     nil
-                     (kernel:%closure-index-ref new-value i))))
-              (kernel:%set-funcallable-instance-function
-               fin
-               (kernel:%closure-function new-value))))))
-    (#.vm:function-header-type
-     (kernel:%set-funcallable-instance-function fin new-value)))
-  new-value)
-
-
-;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME  --  Interface
-;;;
-;;;    Read or set the name slot in a funcallable instance.
-;;;
-(defun funcallable-instance-name (fin)
-  (kernel:%closure-index-ref fin fin-name-slot))
-;;;
-(defun set-funcallable-instance-name (fin new-value)
-  (kernel:%set-funcallable-instance-info fin fin-name-slot new-value)
-  new-value)
-;;;
-(defsetf funcallable-instance-name set-funcallable-instance-name)
+  (setf (kernel:funcallable-instance-function fin) new-value))
 
 
 ;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface
 ;;;
-;;;    If the slot is constant, use CLOSURE-REF with the appropriate offset,
-;;; otherwise do a run-time lookup of the slot offset.
+;;;    This "works" on non-PCL FINs, which allows us to weaken
+;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs.  This is also
+;;; necessary for bootstrapping to work, since the layouts for early GFs are
+;;; not initially initialized.
 ;;;
 (defmacro funcallable-instance-data-1 (fin slot)
-  (if (constantp slot)
-      `(sys:%primitive c:closure-ref ,fin
-                       ,(+ (or (position (eval slot) funcallable-instance-data)
-                               (error "Unknown slot: ~S." (eval slot)))
-                           fin-data-offset))
-      (ext:once-only ((n-slot slot))
-        `(kernel:%closure-index-ref
-          ,fin
-          (+ (or (position ,n-slot funcallable-instance-data)
-                 (error "Unknown slot: ~S." ,n-slot))
-             fin-data-offset)))))
-;;;
-(defmacro %set-funcallable-instance-data-1 (fin slot new-value)
-  (ext:once-only ((n-fin fin)
-                  (n-slot slot)
-                  (n-val new-value))
-    `(progn
-       (kernel:%set-funcallable-instance-info
-        ,n-fin
-	,(if (constantp slot)
-	     (+ (or (position (eval slot) funcallable-instance-data)
-		    (error "Unknown slot: ~S." (eval slot)))
-		fin-data-offset)
-	     `(+ (or (position ,n-slot funcallable-instance-data)
-		     (error "Unknown slot: ~S." ,n-slot))
-		 fin-data-offset))
-        ,n-val)
-       ,n-val)))
-;;;
-(defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)
+  (ecase (eval slot)
+    (wrapper `(kernel:%funcallable-instance-layout ,fin))
+    (slots `(kernel:%funcallable-instance-info ,fin 0))))
+
+(defmacro pcl-funcallable-instance-wrapper (x)
+  `(kernel:%funcallable-instance-layout ,x))
                 
 ); End of #+cmu progn
 
@@ -1957,6 +1865,3 @@ make_turbo_trampoline_internal(base0)
 
 (defmacro fsc-instance-slots (fin)
   `(funcallable-instance-data-1 ,fin 'slots))
-
-
-
diff --git a/pcl/init.lisp b/pcl/init.lisp
index ea607bc93a3610b504b2798d373f92f8b6bccdde..a46abe9bcbb82b0674acb35852472d39763271fe 100644
--- a/pcl/init.lisp
+++ b/pcl/init.lisp
@@ -169,7 +169,10 @@
   (let* ((class (class-of instance))
 	 (slotds (class-slots class))
 	 #-new-kcl-wrapper
-	 (std-p (or (std-instance-p instance) (fsc-instance-p instance))))
+	 (std-p #+cmu17
+		(pcl-instance-p instance)
+		#-cmu17
+		(or (std-instance-p instance) (fsc-instance-p instance))))
     (dolist (slotd slotds)
       (let ((slot-name (slot-definition-name slotd))
 	    (slot-initargs (slot-definition-initargs slotd)))
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 2f8937f662f9534c6b7f8d794dee6dc34083a440..e543c85f60369549538991f911037ba2c393adbb 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -111,6 +111,7 @@
 ;;;
 #-new-kcl-wrapper
 (progn
+#-cmu17
 (defstruct (std-instance (:predicate std-instance-p)
 			 (:conc-name %std-instance-)
 			 (:constructor %%allocate-instance--class ())
@@ -370,10 +371,8 @@
 		  (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*))
 	     (built-in-or-structure-wrapper1 ,x)))))
 
-
 ;Low level functions for structures
 
-
 ;Functions on arbitrary objects
 
 (defvar *structure-table* (make-hash-table :test 'eq))
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
index 117f448e773414bc1683327a83aecb191a8d91a0..b8be040cef8cfd6be04411fe5ab16c58ea41b0e4 100644
--- a/pcl/macros.lisp
+++ b/pcl/macros.lisp
@@ -333,12 +333,18 @@
 ;;; Similar to printing-random-object in the lisp machine but much simpler
 ;;; and machine independent.
 (defmacro printing-random-thing ((thing stream) &body body)
-  (once-only (stream)
-  `(progn (format ,stream "#<")
-	  ,@body
-	  (format ,stream " ")
-	  (printing-random-thing-internal ,thing ,stream)
-	  (format ,stream ">"))))
+  #+cmu17
+  `(print-unreadable-object (,thing ,stream :identity t) ,@body)
+  #-cmu17
+  (once-only (thing stream)
+    `(progn
+       (when *print-readably*
+	 (error "~S cannot be printed readably." thing))
+       (format ,stream "#<")
+       ,@body
+       (format ,stream " ")
+       (printing-random-thing-internal ,thing ,stream)
+       (format ,stream ">"))))
 
 (defun printing-random-thing-internal (thing stream)
   (declare (ignore thing stream))
@@ -373,6 +379,7 @@
 ;(warn "****** Things will go faster if you fix define-compiler-macro")
 )
 
+#-cmu
 (defmacro define-compiler-macro (name arglist &body body)
   #+(or lucid kcl)
   `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
@@ -456,21 +463,54 @@
   (find-class-predicate-from-cell 
    symbol (find-class-cell symbol errorp) errorp))
 
+(defvar *boot-state* nil) ; duplicate defvar to defs.lisp
+
+; Use this definition in any CL implementation supporting 
+; both define-compiler-macro and load-time-value.
+#+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class
+(define-compiler-macro find-class (&whole form
+				   symbol &optional (errorp t) environment)
+  (declare (ignore environment))
+  (if (and (constantp symbol) 
+	   (legal-class-name-p (eval symbol))
+	   (constantp errorp)
+	   (member *boot-state* '(braid complete)))
+      (let ((symbol (eval symbol))
+	    (errorp (not (null (eval errorp))))
+	    (class-cell (make-symbol "CLASS-CELL")))	
+	`(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
+	   (or (find-class-cell-class ,class-cell)
+	       #-cmu17
+	       (find-class-from-cell ',symbol ,class-cell ,errorp)
+	       #+cmu17
+	       ,(if errorp
+		    `(find-class-from-cell ',symbol ,class-cell t)
+		    `(and (kernel:class-cell-class 
+			   ',(kernel:find-class-cell symbol))
+			  (find-class-from-cell ',symbol ,class-cell nil))))))
+      form))
+
 #-setf
 (defsetf find-class (symbol &optional (errorp t) environment) (new-value)
   (declare (ignore errorp environment))
   `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))
 
 (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)
-  (declare (special *boot-state*))
   (if (legal-class-name-p symbol)
       (let ((cell (find-class-cell symbol)))
 	(setf (find-class-cell-class cell) new-value)
 	(when (or (eq *boot-state* 'complete)
 		  (eq *boot-state* 'braid))
+	  #+cmu17
+	  (let ((lclass (kernel:layout-class (class-wrapper new-value))))
+	    (setf (lisp:class-name lclass) (class-name new-value))
+	    (unless (eq (lisp:find-class symbol nil) lclass)
+	      (setf (lisp:find-class symbol) lclass)))
+
 	  (setf (find-class-cell-predicate cell)
 		(symbol-function (class-predicate-name new-value)))
 	  (when (and new-value (not (forward-referenced-class-p new-value)))
+
 	    (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
 	      (update-initialize-info-internal
 	       (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index 625b5bd4ad64951e129c03973e592dafc0309acf..0f7862c6a52cfd681576dcb49d07c63fac58c3fa 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -1028,15 +1028,18 @@
   (cond ((eq class *the-class-t*)
 	 't)
 	((eq class *the-class-slot-object*)
+	 #-(or new-kcl-wrapper cmu17)
+	 `(not (eq *the-class-built-in-class* 
+		   (wrapper-class (std-instance-wrapper (class-of ,arg)))))
 	 #+new-kcl-wrapper
 	 `(or (std-instance-p ,arg)
 	      (fsc-instance-p ,arg))
-	 #-new-kcl-wrapper
-	 `(not (eq *the-class-built-in-class* 
-		   (wrapper-class (std-instance-wrapper (class-of ,arg))))))
+	 #+cmu17
+	 `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class)))
 	#-new-kcl-wrapper
 	((eq class *the-class-standard-object*)
 	 `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
+	#-cmu17
 	((eq class *the-class-structure-object*)
 	 `(memq ',class (class-precedence-list (class-of ,arg))))
 	;; TYPEP is now sometimes faster than doing memq of the cpl
@@ -1367,52 +1370,60 @@
 
 (defun compute-secondary-dispatch-function1 (generic-function net
 					     &optional function-p)
-  (if (eq (car net) 'methods)
-      (get-effective-method-function1 generic-function (cadr net))
-      (let* ((name (generic-function-name generic-function))
-	     (arg-info (gf-arg-info generic-function))
-	     (metatypes (arg-info-metatypes arg-info))
-	     (applyp (arg-info-applyp arg-info))
-	     (fmc-arg-info (cons (length metatypes) applyp))
-	     (arglist (if function-p
-			  (make-dfun-lambda-list metatypes applyp)
-			  (make-fast-method-call-lambda-list metatypes applyp))))
-	(multiple-value-bind (cfunction constants)
-	    (get-function1 `(lambda ,arglist
-			      ,@(unless function-p
-				  `((declare (ignore .pv-cell.
-						     .next-method-call.))))
-			      #+copy-&rest-arg
-			      ,@(when (and applyp function-p)
-				  `((setq .dfun-rest-arg.
-					  (copy-list .dfun-rest-arg.))))
-			      (let ((emf ,net))
-			        ,(make-emf-call metatypes applyp 'emf)))
-			   #'net-test-converter
-			   #'net-code-converter
-			   #'(lambda (form)
-			       (net-constant-converter form generic-function)))
-	  #'(lambda (method-alist wrappers)
-	      (let* ((alist (list nil))
-		     (alist-tail alist))
-		(dolist (constant constants)
-		  (let* ((a (or (dolist (a alist nil)
-				  (when (eq (car a) constant)
-				    (return a)))
-				(cons constant
-				      (or (convert-table
-					   constant method-alist wrappers)
-					  (convert-methods
-					   constant method-alist wrappers)))))
-			 (new (list a)))
-		    (setf (cdr alist-tail) new)
-		    (setf alist-tail new)))
-		(let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
-		  (if function-p
-		      function
-		      (make-fast-method-call
-		       :function (set-function-name function `(sdfun-method ,name))
-		       :arg-info fmc-arg-info)))))))))
+  (cond
+   ((and (eq (car net) 'methods) (not function-p))
+    (get-effective-method-function1 generic-function (cadr net)))
+   (t
+    (let* ((name (generic-function-name generic-function))
+	   (arg-info (gf-arg-info generic-function))
+	   (metatypes (arg-info-metatypes arg-info))
+	   (applyp (arg-info-applyp arg-info))
+	   (fmc-arg-info (cons (length metatypes) applyp))
+	   (arglist (if function-p
+			(make-dfun-lambda-list metatypes applyp)
+			(make-fast-method-call-lambda-list metatypes applyp))))
+      (multiple-value-bind
+	  (cfunction constants)
+	  (get-function1 `(#+cmu ,(if function-p
+				      'kernel:instance-lambda
+				      'lambda)
+			   #-cmu lambda
+			   ,arglist
+				 ,@(unless function-p
+				     `((declare (ignore .pv-cell.
+							.next-method-call.))))
+				 #+copy-&rest-arg
+				 ,@(when (and applyp function-p)
+				     `((setq .dfun-rest-arg.
+					     (copy-list .dfun-rest-arg.))))
+				 (locally (declare #.*optimize-speed*)
+				   (let ((emf ,net))
+				     ,(make-emf-call metatypes applyp 'emf))))
+			 #'net-test-converter
+			 #'net-code-converter
+			 #'(lambda (form)
+			     (net-constant-converter form generic-function)))
+	#'(lambda (method-alist wrappers)
+	    (let* ((alist (list nil))
+		   (alist-tail alist))
+	      (dolist (constant constants)
+		(let* ((a (or (dolist (a alist nil)
+				(when (eq (car a) constant)
+				  (return a)))
+			      (cons constant
+				    (or (convert-table
+					 constant method-alist wrappers)
+					(convert-methods
+					 constant method-alist wrappers)))))
+		       (new (list a)))
+		  (setf (cdr alist-tail) new)
+		  (setf alist-tail new)))
+	      (let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
+		(if function-p
+		    function
+		    (make-fast-method-call
+		     :function (set-function-name function `(sdfun-method ,name))
+		     :arg-info fmc-arg-info))))))))))
 
 (defvar *show-make-unordered-methods-emf-calls* nil)
 
diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp
index b09f2f47a3bf5add580cba95c1a1ed49b951d4bf..bba0234984d35b5dace25a31f916fb865f5ebcc1 100644
--- a/pcl/pkg.lisp
+++ b/pcl/pkg.lisp
@@ -64,6 +64,11 @@
 #+CMU
 (shadow '(destructuring-bind)
         *the-pcl-package*)
+#+cmu17
+(shadow '(find-class class-name class-of
+		     class built-in-class structure-class
+		     standard-class)
+	*the-pcl-package*)
 
 #+GCLisp
 (shadow '(string-append memq assq delq neq make-instance)
@@ -154,7 +159,7 @@
 #+cmu (shadow 'lisp:dotimes)
 
 #+cmu
-(import '(kernel:funcallable-instance-p ext:structurep)
+(import '(kernel:funcallable-instance-p)
 	*the-pcl-package*)
 
 
@@ -205,12 +210,12 @@
 		    slot-unbound
 		    slot-value
 		    standard
-		    standard-class
+		    #-cmu17 standard-class
 		    standard-generic-function
 		    standard-method
 		    standard-object
-		    structure-class
-		    #-cmu symbol-macrolet
+		    #-cmu17 structure-class
+		    #-cmu17 symbol-macrolet
 		    update-instance-for-different-class
 		    update-instance-for-redefined-class
 		    with-accessors
@@ -251,9 +256,9 @@
           standard-effective-slot-definition
           specializer
           eql-specializer
-          built-in-class
+	  #-cmu17 built-in-class
           forward-referenced-class
-          standard-class
+          #-cmu17 standard-class
           funcallable-standard-class))
 
 (defvar *chapter-6-exports*
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
index 695222bd35f1e91e59696eab80d022a41df7d073..ad90099e53fda91099a6e68bb6c246cb19b7d716 100644
--- a/pcl/quadlap.lisp
+++ b/pcl/quadlap.lisp
@@ -1,6 +1,6 @@
 ;;				-[Thu Mar  1 10:54:27 1990 by jkf]-
 ;; pcl to quad translation
-;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.5 1992/11/09 15:21:37 ram Exp $
+;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.6 1997/02/06 21:24:19 pw Exp $
 ;;
 ;; copyright (c) 1990 Franz Inc.
 ;;
diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp
index 56a897169348ae4e97acaea5118ee31216cca742..dadb07cec77c86c5140c0970d87969dfcf974e91 100644
--- a/pcl/slots-boot.lisp
+++ b/pcl/slots-boot.lisp
@@ -59,10 +59,8 @@
        (,sym ,@args)
        (no-slot ',sym ',slot-name)))
 
-(defun no-slot (slot-name sym)
-  (error "No class has a slot named ~S (~s has no function binding)
-          (or maybe your files were compiled with an old version of PCL:~
-          try recompiling.)"
+(defun no-slot (sym slot-name)
+  (error "No class has a slot named ~S (~s has no function binding)."
 	 slot-name sym))
 
 (defmacro accessor-slot-value (object slot-name)
@@ -305,10 +303,7 @@
   (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
 	 (make-method-function
 	  (lambda (instance)
-	    (let ((wrapper (cond ((std-instance-p instance) 
-				  (std-instance-wrapper instance))
-				 ((fsc-instance-p instance) 
-				  (fsc-instance-wrapper instance)))))
+	    (let ((wrapper (get-instance-wrapper-or-nil instance)))
 	      (if wrapper
 		  (let* ((class (wrapper-class* wrapper))
 			 (index (or (instance-slot-index wrapper slot-name)
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 6ba1fb0eff126c3191b66114dc6a722840ac1742..480a8d78cd213501fa240444be2d2742e53502cb 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -318,12 +318,14 @@
 
 (defun real-load-defclass (name metaclass-name supers slots other accessors)
   (do-standard-defsetfs-for-defclass accessors)	                ;***
-  (apply #'ensure-class name :metaclass metaclass-name
-			     :direct-superclasses supers
-			     :direct-slots slots
-			     :definition-source `((defclass ,name)
-						  ,(load-truename))
-			     other))
+  (let ((res (apply #'ensure-class name :metaclass metaclass-name
+		    :direct-superclasses supers
+		    :direct-slots slots
+		    :definition-source `((defclass ,name)
+					 ,(load-truename))
+		    other)))
+    #+cmu17 (kernel:layout-class (class-wrapper res))
+    #-cmu17 res))
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
@@ -413,8 +415,10 @@
         (dolist (superclass direct-superclasses)
 	  (unless (validate-superclass class superclass)
 	    (error "The class ~S was specified as a~%super-class of the class ~S;~%~
-                    but the meta-classes ~S and~%~S are incompatible."
-		   superclass class (class-of superclass) (class-of class))))
+                    but the meta-classes ~S and~%~S are incompatible.~%
+                    Define a method for ~S to avoid this error."
+		   superclass class (class-of superclass) (class-of class)
+                   'validate-superclass)))
         (setf (slot-value class 'direct-superclasses) direct-superclasses))
       (setq direct-superclasses (slot-value class 'direct-superclasses)))
   (setq direct-slots
@@ -552,9 +556,13 @@
   (setf (slot-value class 'class-precedence-list) 
 	(compute-class-precedence-list class))
   (setf (slot-value class 'slots) (compute-slots class))
-  #-new-kcl-wrapper
+  #-(or cmu17 new-kcl-wrapper)
   (unless (slot-value class 'wrapper) 
     (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
+  #+cmu17
+ (let ((lclass (lisp:find-class (class-name class))))
+    (setf (kernel:class-pcl-class lclass) class)
+    (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
   #+new-kcl-wrapper
   (let ((wrapper (get (class-name class) 'si::s-data)))
     (setf (slot-value class 'wrapper) wrapper)
@@ -689,14 +697,18 @@
 		   ;;
 		   (make-instances-obsolete class)
 		   (class-wrapper class)))))
+
       (with-slots (wrapper slots) class
 	#+new-kcl-wrapper
 	(setf (si::s-data-name nwrapper) (class-name class))
+	#+cmu17
+	(update-lisp-class-layout class nwrapper)
 	(setf slots eslotds
 	      (wrapper-instance-slots-layout nwrapper) nlayout
 	      (wrapper-class-slots nwrapper) nwrapper-class-slots
 	      (wrapper-no-of-instance-slots nwrapper) nslots
 	      wrapper nwrapper))
+
       (unless (eq owrapper nwrapper)
 	(update-pv-table-cache-info class)))))
 
@@ -1021,6 +1033,8 @@
 	(setf (wrapper-class-slots nwrapper)
 	      (wrapper-class-slots owrapper))
 	(without-interrupts
+	  #+cmu17
+	  (update-lisp-class-layout class nwrapper)
 	  (setf (slot-value class 'wrapper) nwrapper)
 	  (invalidate-wrapper owrapper ':flush nwrapper))))))
 
@@ -1044,6 +1058,8 @@
       (setf (wrapper-class-slots nwrapper)
 	    (wrapper-class-slots owrapper))
       (without-interrupts
+	#+cmu17
+	(update-lisp-class-layout class nwrapper)
 	(setf (slot-value class 'wrapper) nwrapper)
 	(invalidate-wrapper owrapper ':obsolete nwrapper)
 	class)))
@@ -1072,66 +1088,101 @@
 ;;; happening when they should, and that the trap methods are computing
 ;;; apropriate new wrappers.
 ;;; 
-(defun obsolete-instance-trap (owrapper nwrapper instance)  
-  ;;
-  ;; local  --> local        transfer 
-  ;; local  --> shared       discard
-  ;; local  -->  --          discard
-  ;; shared --> local        transfer
-  ;; shared --> shared       discard
-  ;; shared -->  --          discard
-  ;;  --    --> local        add
-  ;;  --    --> shared        --
-  ;;
-  (let* ((class (wrapper-class* nwrapper))
-	 (guts (allocate-instance class))	;??? allocate-instance ???
-	 (olayout (wrapper-instance-slots-layout owrapper))
-	 (nlayout (wrapper-instance-slots-layout nwrapper))
-	 (oslots (get-slots instance))
-	 (nslots (get-slots guts))
-	 (oclass-slots (wrapper-class-slots owrapper))
-	 (added ())
-	 (discarded ())
-	 (plist ()))
-    ;;
-    ;; Go through all the old local slots.
-    ;; 
-    (iterate ((name (list-elements olayout))
-	      (opos (interval :from 0)))
-      (let ((npos (posq name nlayout)))
-	(if npos
-	    (setf (instance-ref nslots npos) (instance-ref oslots opos))
-	    (progn (push name discarded)
-		   (unless (eq (instance-ref oslots opos) *slot-unbound*)
-		     (setf (getf plist name) (instance-ref oslots opos)))))))
-    ;;
-    ;; Go through all the old shared slots.
-    ;;
-    (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
-      (let ((name (car oclass-slot-and-val))
-	    (val (cdr oclass-slot-and-val)))
-	(let ((npos (posq name nlayout)))
-	  (if npos
-	      (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
-	      (progn (push name discarded)
-		     (unless (eq val *slot-unbound*)
-		       (setf (getf plist name) val)))))))
-    ;;
-    ;; Go through all the new local slots to compute the added slots.
-    ;; 
-    (dolist (nlocal nlayout)
-      (unless (or (memq nlocal olayout)
-		  (assq nlocal oclass-slots))
-	(push nlocal added)))
-      
-    (swap-wrappers-and-slots instance guts)
 
-    (update-instance-for-redefined-class instance
-					 added
-					 discarded
-					 plist)
-    nwrapper))
+;;; obsolete-instance-trap might be called on structure instances
+;;; after a structure is redefined.  In most cases, obsolete-instance-trap
+;;; will not be able to fix the old instance, so it must signal an
+;;; error.  The hard part of this is that the error system and debugger
+;;; might cause obsolete-instance-trap to be called again, so in that
+;;; case, we have to return some reasonable wrapper, instead.
+
+(defvar *in-obsolete-instance-trap* nil)
+(defvar *the-wrapper-of-structure-object* 
+  (class-wrapper (find-class 'structure-object)))
+
+#+cmu17
+(define-condition obsolete-structure (error)
+  ((datum :reader obsolete-structure-datum :initarg :datum))
+  (:report
+   (lambda (condition stream)
+     ;; Don't try to print the structure, since it probably
+     ;; won't work.
+     (format stream "Obsolete structure error in ~S:~@
+		     For a structure of type: ~S"
+	     (conditions::condition-function-name condition)
+	     (type-of (obsolete-structure-datum condition))))))
+
+(defun obsolete-instance-trap (owrapper nwrapper instance)
+  (if (not #-(or cmu17 new-kcl-wrapper)
+           (or (std-instance-p instance) (fsc-instance-p instance))
+	   #+cmu17
+           (pcl-instance-p instance)
+           #+new-kcl-wrapper
+           nil)
+      (if *in-obsolete-instance-trap*
+          *the-wrapper-of-structure-object* 
+           (let ((*in-obsolete-instance-trap* t))
+	     #-cmu17
+             (error "The structure ~S is obsolete." instance)
+	     #+cmu17
+	     (error 'obsolete-structure :datum instance)))
+      (let* ((class (wrapper-class* nwrapper))
+	     (copy (allocate-instance class)) ;??? allocate-instance ???
+	     (olayout (wrapper-instance-slots-layout owrapper))
+	     (nlayout (wrapper-instance-slots-layout nwrapper))
+	     (oslots (get-slots instance))
+	     (nslots (get-slots copy))
+	     (oclass-slots (wrapper-class-slots owrapper))
+	     (added ())
+	     (discarded ())
+	     (plist ()))
+	;; local  --> local        transfer 
+	;; local  --> shared       discard
+	;; local  -->  --          discard
+	;; shared --> local        transfer
+	;; shared --> shared       discard
+	;; shared -->  --          discard
+	;;  --    --> local        add
+	;;  --    --> shared        --
+	;;
+	;; Go through all the old local slots.
+	;; 
+	(iterate ((name (list-elements olayout))
+		  (opos (interval :from 0)))
+	  (let ((npos (posq name nlayout)))
+	    (if npos
+		(setf (instance-ref nslots npos) (instance-ref oslots opos))
+		(progn
+		  (push name discarded)
+		  (unless (eq (instance-ref oslots opos) *slot-unbound*)
+		    (setf (getf plist name) (instance-ref oslots opos)))))))
+	;;
+	;; Go through all the old shared slots.
+	;;
+	(iterate ((oclass-slot-and-val (list-elements oclass-slots)))
+	  (let ((name (car oclass-slot-and-val))
+		(val (cdr oclass-slot-and-val)))
+	    (let ((npos (posq name nlayout)))
+	      (if npos
+		  (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
+		  (progn (push name discarded)
+			 (unless (eq val *slot-unbound*)
+			   (setf (getf plist name) val)))))))
+	;;
+	;; Go through all the new local slots to compute the added slots.
+	;; 
+	(dolist (nlocal nlayout)
+	  (unless (or (memq nlocal olayout)
+		      (assq nlocal oclass-slots))
+	    (push nlocal added)))
+      
+	(swap-wrappers-and-slots instance copy)
 
+	(update-instance-for-redefined-class instance
+					     added
+					     discarded
+					     plist)
+	nwrapper)))
 
 
 ;;;
@@ -1151,14 +1202,13 @@
 
 (defun change-class-internal (instance new-class)
   (let* ((old-class (class-of instance))
-	 (copy (copy-instance-internal instance))
-	 (guts (allocate-instance new-class))
-	 (new-wrapper (get-wrapper guts))
+	 (copy (allocate-instance new-class))
+	 (new-wrapper (get-wrapper copy))
 	 (old-wrapper (class-wrapper old-class))
 	 (old-layout (wrapper-instance-slots-layout old-wrapper))
 	 (new-layout (wrapper-instance-slots-layout new-wrapper))
 	 (old-slots (get-slots instance))
-	 (new-slots (get-slots guts))
+	 (new-slots (get-slots copy))
 	 (old-class-slots (wrapper-class-slots old-wrapper)))
 
     ;;
@@ -1184,7 +1234,7 @@
 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.
-    (swap-wrappers-and-slots instance guts)
+    (swap-wrappers-and-slots instance copy)
 
     (update-instance-for-different-class copy instance)
     instance))