From 1f6f213c125a3b4a674908d6e2ad50dd4643ea61 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sat, 1 Aug 1992 15:30:24 +0000
Subject: [PATCH] This is July 92 PCL

---
 pcl/boot.lisp              | 2735 ++++++++++++++++++++++--------------
 pcl/braid.lisp             |  542 ++++---
 pcl/cache.lisp             |  562 +++++---
 pcl/cmu-low.lisp           |   33 +-
 pcl/combin.lisp            |   49 +-
 pcl/construct.lisp         |   17 +-
 pcl/cpatch.lisp            |    5 +
 pcl/cpl.lisp               |    8 +-
 pcl/defclass.lisp          |  305 +++-
 pcl/defcombin.lisp         |   54 +-
 pcl/defs.lisp              |  240 ++--
 pcl/defsys.lisp            |   57 +-
 pcl/dfun.lisp              |  139 +-
 pcl/dlap.lisp              |   23 +-
 pcl/env.lisp               |  376 +++--
 pcl/excl-low.lisp          |   10 +
 pcl/extensions.lisp        |  496 +++++++
 pcl/fin.lisp               |   82 +-
 pcl/fixup.lisp             |    1 -
 pcl/fngen.lisp             |   66 +-
 pcl/fsc.lisp               |   47 +-
 pcl/generic-functions.lisp |  278 ++--
 pcl/ibcl-low.lisp          |    5 +
 pcl/init.lisp              |  204 ++-
 pcl/iterate.lisp           |   20 +-
 pcl/kcl-low.lisp           |   43 +-
 pcl/kcl-patches.lisp       |  143 ++
 pcl/lap.lisp               |   25 +-
 pcl/list-functions.lisp    |   12 +-
 pcl/low.lisp               |  620 ++++++--
 pcl/lucid-low.lisp         |   62 +-
 pcl/macros.lisp            |  428 ++++--
 pcl/march-92-notes.text    |  311 ++++
 pcl/methods.lisp           | 1508 +++++++++++++++-----
 pcl/notes.text             |  482 +++----
 pcl/pcl-env.lisp           |   16 +-
 pcl/pkg.lisp               |  188 ++-
 pcl/plap.lisp              |   73 +-
 pcl/quadlap.lisp           |    9 +-
 pcl/slots.lisp             | 1576 +++++++++++++++------
 pcl/std-class.lisp         | 1179 ++++++++++------
 pcl/structure-class.lisp   |  340 +++++
 pcl/sys-package.lisp       |  135 +-
 pcl/sys-proclaim.lisp      | 1487 +++++++++++---------
 pcl/sysdef.lisp            |  105 +-
 pcl/time.lisp              |   57 +-
 pcl/user-instances.lisp    |  684 +++++++++
 pcl/vector.lisp            |  660 ++++-----
 pcl/walk.lisp              |   87 +-
 49 files changed, 11342 insertions(+), 5242 deletions(-)
 create mode 100644 pcl/extensions.lisp
 create mode 100644 pcl/march-92-notes.text
 create mode 100644 pcl/structure-class.lisp
 create mode 100644 pcl/user-instances.lisp

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index e715989ae..890ccd00e 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -72,19 +72,40 @@ work during bootstrapping.
 |#
 
 (proclaim '(notinline make-a-method
-		      add-named-method		      
-		      ensure-generic-function-using-class
+                      add-named-method                
+                      call-make-method-lambda
+                      call-make-closure-generator-form
+                      call-store-method-function-p
+                      call-store-method-optimized-function-p
+                      call-store-closure-generator-p
+                      call-store-optimized-method-lambda-p
 
-		      add-method
-		      remove-method
-		      ))
+                      ensure-generic-function-using-class
+
+                      add-method
+                      remove-method
+                      ))
 
 (defvar *early-functions*
-	'((make-a-method early-make-a-method
-			 real-make-a-method)
-	  (add-named-method early-add-named-method
-			    real-add-named-method)
-	  ))
+        '((make-a-method early-make-a-method
+                         real-make-a-method)
+          (add-named-method early-add-named-method
+                            real-add-named-method)
+          (call-make-method-lambda early-make-method-lambda
+                                   make-method-lambda)
+          (call-make-closure-generator-form make-std-closure-generator-form
+                                            make-closure-generator-form)
+          (call-store-method-function-p early-store-method-function-p
+                                        store-method-function-p)
+          (call-store-method-optimized-function-p
+             early-store-method-optimized-function-p
+             store-method-optimized-function-p)
+          (call-store-closure-generator-p early-store-closure-generator-p
+                                          store-closure-generator-p)
+          (call-store-optimized-method-lambda-p
+             early-store-optimized-method-lambda-p
+             store-optimized-method-lambda-p)
+          ))
 
 ;;;
 ;;; For each of the early functions, arrange to have it point to its early
@@ -99,13 +120,13 @@ work during bootstrapping.
 (eval-when (load eval)
 
   (defun redirect-early-function-internal (to)
-    #'(lambda (&rest args) (apply (symbol-function to) args)))
+    #'(lambda (&rest args) (apply-function (symbol-function to) args)))
   
   (dolist (fns *early-functions*)
     (let ((name (car fns))
-	  (early-name (cadr fns)))
+          (early-name (cadr fns)))
       (setf (symbol-function name)
-	    (redirect-early-function-internal early-name))))
+            (redirect-early-function-internal early-name))))
 
   )
 
@@ -117,28 +138,28 @@ work during bootstrapping.
 ;;; 
 (defvar *generic-function-fixups*
     '((add-method
-	((generic-function method)		        ;lambda-list
-	 (standard-generic-function method)	        ;specializers
-	 real-add-method))			        ;method-function
+        ((generic-function method)                      ;lambda-list
+         (standard-generic-function method)             ;specializers
+         real-add-method))                              ;method-function
       (remove-method
-	((generic-function method)
-	 (standard-generic-function method)
-	 real-remove-method))
+        ((generic-function method)
+         (standard-generic-function method)
+         real-remove-method))
       (get-method
         ((generic-function qualifiers specializers &optional (errorp t))
-	 (standard-generic-function t t)
-	 real-get-method))
+         (standard-generic-function t t)
+         real-get-method))
       (ensure-generic-function-using-class
-	((generic-function function-specifier
-			   &key generic-function-class environment
-			   &allow-other-keys)
-	 (generic-function t)
-	 real-ensure-gf-using-class--generic-function)
-	((generic-function function-specifier
-			   &key generic-function-class environment
-			   &allow-other-keys)
-	 (null t)
-	 real-ensure-gf-using-class--null))
+        ((generic-function function-specifier
+                           &key generic-function-class environment
+                           &allow-other-keys)
+         (generic-function t)
+         real-ensure-gf-using-class--generic-function)
+        ((generic-function function-specifier
+                           &key generic-function-class environment
+                           &allow-other-keys)
+         (null t)
+         real-ensure-gf-using-class--null))
       ))
 
 
@@ -148,81 +169,100 @@ work during bootstrapping.
 (defmacro defgeneric (function-specifier lambda-list &body options)
   (expand-defgeneric function-specifier lambda-list options))
 
+(defvar *defgeneric-temp* NIL)
+
 (defun expand-defgeneric (function-specifier lambda-list options)
   (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
-  (let ((initargs ()))
+  (let ((initargs ())
+        (methods  ()))
     (flet ((duplicate-option (name)
-	     (error "The option ~S appears more than once." name)))
+             (error "The option ~S appears more than once." name)))
       ;;
       ;; INITARG takes this screwy new argument to get around a bad
       ;; interaction between lexical macros and setf in the Lucid
       ;; compiler.
       ;; 
       (macrolet ((initarg (key &optional new)
-		   (if new
-		       `(setf (getf initargs ,key) ,new)
-		       `(getf initargs ,key))))
-	(dolist (option options)
-	  (ecase (car option)
-	    (:argument-precedence-order
-	      (if (initarg :argument-precedence-order)
-		  (duplicate-option :argument-precedence-order)
-		  (initarg :argument-precedence-order `',(cdr option))))
-	    (declare
-	      (initarg :declarations
-		       (append (cdr option) (initarg :declarations))))
-	    (:documentation
-	      (if (initarg :documentation)
-		  (duplicate-option :documentation)
-		  (initarg :documentation `',(cadr option))))
-	    (:method-combination
-	      (if (initarg :method-combination)
-		  (duplicate-option :method-combination)
-		  (initarg :method-combination `',(cdr option))))
-	    (:generic-function-class
-	      (if (initarg :generic-function-class)
-		  (duplicate-option :generic-function-class)
-		  (initarg :generic-function-class `',(cadr option))))
-	    (:method-class
-	      (if (initarg :method-class)
-		  (duplicate-option :method-class)
-		  (initarg :method-class `',(cadr option))))
-	    (:method
-	      (error
-		"DEFGENERIC doesn't support the :METHOD option yet."))))
-
-	(let ((declarations (initarg :declarations)))
-	  (when declarations (initarg :declarations `',declarations)))))
-    `(progn
-       (proclaim-defgeneric ',function-specifier ',lambda-list)
-       ,(make-top-level-form `(defgeneric ,function-specifier)
-	  *defgeneric-times*
-	  `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)))))
+                   (if new
+                       `(setf (getf initargs ,key) ,new)
+                       `(getf initargs ,key))))
+        (dolist (option options)
+          (ecase (car option)
+            (:argument-precedence-order
+              (if (initarg :argument-precedence-order)
+                  (duplicate-option :argument-precedence-order)
+                  (initarg :argument-precedence-order `',(cdr option))))
+            (declare
+              (initarg :declarations
+                       (append (cdr option) (initarg :declarations))))
+            (:documentation
+              (if (initarg :documentation)
+                  (duplicate-option :documentation)
+                  (initarg :documentation `',(cadr option))))
+            (:method-combination
+              (if (initarg :method-combination)
+                  (duplicate-option :method-combination)
+                  (initarg :method-combination `',(cdr option))))
+            (:generic-function-class
+              (if (initarg :generic-function-class)
+                  (duplicate-option :generic-function-class)
+                  (initarg :generic-function-class `',(cadr option))))
+            (:method-class
+              (if (initarg :method-class)
+                  (duplicate-option :method-class)
+                  (initarg :method-class `',(cadr option))))
+            (:method
+              (push (cdr option) methods))))
+
+        (let ((declarations (initarg :declarations)))
+          (when declarations (initarg :declarations `',declarations)))))
+     (let ((load-defgeneric-form
+             (make-top-level-form `(defgeneric ,function-specifier)
+               *defgeneric-times*
+               `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
+       (if methods
+           `(progn
+              (proclaim-defgeneric ',function-specifier ',lambda-list)
+              (setf *defgeneric-temp* ,load-defgeneric-form)
+              ,@(mapcar #'(lambda (method-descrip)
+                           `(defmethod ,function-specifier ,@method-descrip))
+                        (nreverse methods))
+              (prog1 *defgeneric-temp* (setf *defgeneric-temp* NIL)))
+           `(progn
+              (proclaim-defgeneric ',function-specifier ',lambda-list)
+              ,load-defgeneric-form)))))
+
 
 (defun load-defgeneric (function-specifier lambda-list &rest initargs)
   (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
   (apply #'ensure-generic-function
-	 function-specifier
-	 :lambda-list lambda-list
-	 :definition-source `((defgeneric ,function-specifier)
-			      ,(load-truename))
-	 initargs))
+         function-specifier
+         :lambda-list lambda-list
+         :definition-source `((defgeneric ,function-specifier)
+                              ,(load-truename))
+         initargs))
 
 
 ;;;
 ;;;
 ;;;
+
+(declaim (ftype (function (T) (values T T T T)) parse-defmethod))
+
 (defmacro DEFMETHOD (&rest args &environment env)
-  #+(or (not :lucid) :lcl3.0)	
+  #+(or (not :lucid) :lcl3.0)   
   (declare (arglist name
-		    {method-qualifier}*
-		    specialized-lambda-list
-		    &body body))
+                    {method-qualifier}*
+                    specialized-lambda-list
+                    &body body))
   (multiple-value-bind (name qualifiers lambda-list body)
       (parse-defmethod args)
-    (let ((proto-method (method-prototype-for-gf name)))
+    (let ((proto-gf
+            (prototype-of-generic-function name))
+          (proto-method
+            (method-prototype-for-gf name)))
       (expand-defmethod
-	proto-method name qualifiers lambda-list body env))))
+        proto-gf proto-method name qualifiers lambda-list body env))))
 
 ;;;
 ;;; takes a name which is either a generic function name or a list specifying
@@ -239,45 +279,122 @@ work during bootstrapping.
 ;;; 
 (defun method-prototype-for-gf (name)      
   (let ((gf? (and (gboundp name)
-		  (gdefinition name))))
+                  (gdefinition name))))
     (cond ((neq *boot-state* 'complete) nil)
-	  ((or (null gf?)
-	       (not (generic-function-p gf?)))	        ;Someone else MIGHT
-						        ;error at load time.
-	   (class-prototype (find-class 'standard-method)))
-	  (t
-	    (class-prototype (or (generic-function-method-class gf?)
-				 (find-class 'standard-method)))))))
+          ((or (null gf?)
+               (not (generic-function-p gf?)))          ;Someone else MIGHT
+                                                        ;error at load time.
+           (class-prototype (find-class 'standard-method)))
+          (t
+            (let ((method-class (or (generic-function-method-class gf?)
+                                    (find-class 'standard-method))))
+              (unless (class-finalized-p method-class)
+                (finalize-inheritance method-class))
+              (class-prototype method-class))))))
+
+(defun prototype-of-generic-function (name)
+  ;;   Takes a name which is either a generic function name or a list specifying
+  ;; a setf generic function (like: (SETF <generic-function-name>)).
+  ;;   Returns the generic function itself, unless the generic-function has
+  ;; not yet been defined, in which case it returns the class-prototype
+  ;; of 'standard-generic-function.
+  ;;
+  ;; NOTE that during bootstrapping, this function is allowed to return NIL.
+  ;; 
+  (let ((gf? (and (gboundp name)
+                  (gdefinition name))))
+    (cond ((neq *boot-state* 'complete) nil)
+          ((or (null gf?) (not (generic-function-p gf?)))
+           (let ((std-generic-function-class
+                   (find-class 'standard-generic-function NIL)))
+              (if std-generic-function-class
+                  (class-prototype std-generic-function-class))))
+          (T gf?))))
 
 
+(defconstant *standard-pcl-make-method-lambda-doc-string*
+   "Standard PCL make-method-lambda here.")
+
+(defun early-store-method-function-p
+       (generic-function method initargs)
+  ;; Should methods of this generic-function store their own method-function?
+  ;; Answer is normally T to keep stay compatible with the AMOP even
+  ;; though PCL actually uses the function in method-optimized-function
+  ;; for efficiency.  However, answer can be NIL if the programmer doesn't
+  ;; care about method-functions, which will cut down on binary sizes
+  ;; significantly since it would stop methods from carrying around
+  ;; an extra (unused) method-function.
+  ;; 
+  (declare (ignore generic-function method initargs))
+  *standard-store-method-function-p*)
+
+(defun early-store-method-optimized-function-p
+       (generic-function method initargs)
+  ;; Should methods of this generic-function store their own
+  ;; method-optimized-function?
+  ;;   Answer better be T unless a closure-generator is stored
+  ;; for the method instead, or if the programmer has redefined the
+  ;; discriminating method function dispatch code to use the
+  ;; documented method-functions rather than the optimized PCL
+  ;; method-optimized-functions,
+  (declare (ignore generic-function method))
+  (null (memq :optimized-slot-indices initargs)))
+
+(defun early-store-closure-generator-p
+       (generic-function method initargs)
+  ;; Should methods of this generic-function store their own
+  ;; method function closure generators?
+  ;;   Answer better be T unless a method-optimized-function is
+  ;; stored instead, or if the programmer has redefined the
+  ;; the discriminating method function dispatch code to use
+  ;; the documented method-functions rather than the optimized
+  ;; PCL method-optimized-functions.
+  (declare (ignore generic-function method))
+  (not (null (memq :optimized-slot-indices initargs))))
+
+(defun early-store-optimized-method-lambda-p
+       (generic-function method initargs)
+  ;;   Should methods of this generic-function store their own
+  ;; their optimized-method-lambdas?
+  ;;   Generally only stored when the method contains slot-value
+  ;; accesses on its parameter lists, in which case the lambda
+  ;; is used to compile the cached method at runtime to directly
+  ;; optimize those accesses.
+  (declare (ignore generic-function method))
+  (and *compile-slot-access-method-functions-at-runtime-p*
+       (not (null (memq :optimized-slot-indices initargs)))))
+
+
 ;#-Genera
-(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
+(defun expand-defmethod
+       (proto-generic-function proto-method name qualifiers lambda-list
+        body env)
   (when (listp name) (do-standard-defsetf-1 (cadr name)))
-  (multiple-value-bind (fn-form specializers doc plist)
-      (expand-defmethod-internal name qualifiers lambda-list body env)
+  (multiple-value-bind (method-lambda optimized-method-lambda closure-generator
+                        initargs specializers doc)
+      (expand-defmethod-internal proto-generic-function proto-method
+                                 name qualifiers lambda-list body env)
     (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers)
-			 *defmethod-times*
+                         *defmethod-times*
       `(progn
-	 (proclaim-defgeneric ',name ',lambda-list)
-	 (load-defmethod
-	  ',(if proto-method
-		(class-name (class-of proto-method))
-		'standard-method)
-	  ',name
-	  ',qualifiers
-	  (list ,@(mapcar #'(lambda (specializer)
-			      (if (consp specializer)
-				  ``(,',(car specializer) ,,(cadr specializer))
-				  `',specializer))
-			  specializers))
-	  ',(extract-lambda-list lambda-list)
-	  ',doc
-	  ',(getf plist :isl-cache-symbol) ;Paper over a bug in KCL by
-					   ;passing the cache-symbol
-					   ;here in addition to in the
-					   ;plist.
-	  ',plist
-	  ,fn-form)))))
+         (proclaim-defgeneric ',name ',lambda-list)
+         (load-defmethod
+          ',(if proto-method
+                (class-name (class-of proto-method))
+                'standard-method)
+          ',name
+          ',qualifiers
+          (list ,@(mapcar #'(lambda (specializer)
+                              (if (consp specializer)
+                                  ``(,',(car specializer) ,,(cadr specializer))
+                                  `',specializer))
+                          specializers))
+          ',(extract-lambda-list lambda-list)
+          ',doc
+          ,(if method-lambda `(function ,method-lambda))
+          ,(if optimized-method-lambda `(function ,optimized-method-lambda))
+          ,closure-generator
+          ',initargs)))))
 
 #||
 #+Genera
@@ -286,403 +403,997 @@ work during bootstrapping.
   (multiple-value-bind (fn-form specializers doc plist)
       (expand-defmethod-internal name qualifiers lambda-list body env)
     (let ((fn-args (cadadr fn-form))
-	  (fn-body (cddadr fn-form))
-	  (method-name `(method ,name ,@qualifiers ,specializers)))
+          (fn-body (cddadr fn-form))
+          (method-name `(method ,name ,@qualifiers ,specializers)))
       `(progn
-	 (proclaim '(function ,name))
-	 (defun ,method-name ,fn-args
-	   ,@fn-body)
-	 (load-defmethod
-	   ',(if proto-method
-		 (class-name (class-of proto-method))
-		 'standard-method)
-	   ',name
-	   ',qualifiers
-	   (list ,@(mapcar #'(lambda (specializer)
-			       (if (consp specializer)
-				   ``(,',(car specializer) ,,(cadr specializer))
-				   `',specializer))
-			   specializers))
-	   ',(extract-lambda-list lambda-list)
-	   ',doc
-	   ',(getf plist :isl-cache-symbol)	;Paper over a bug in KCL by
-						;passing the cache-symbol
-						;here in addition to in the
-						;plist.
-	   ',plist
-	   #',method-name)))))
+         (proclaim '(function ,name))
+         (defun ,method-name ,fn-args
+           ,@fn-body)
+         (load-defmethod
+           ',(if proto-method
+                 (class-name (class-of proto-method))
+                 'standard-method)
+           ',name
+           ',qualifiers
+           (list ,@(mapcar #'(lambda (specializer)
+                               (if (consp specializer)
+                                   ``(,',(car specializer) ,,(cadr specializer))
+                                   `',specializer))
+                           specializers))
+           ',(extract-lambda-list lambda-list)
+           ',doc
+           ',(getf plist :isl-cache-symbol)     ;Paper over a bug in KCL by
+                                                ;passing the cache-symbol
+                                                ;here in addition to in the
+                                                ;plist.
+           ',plist
+           #',method-name)))))
 ||#
 
+(defvar *expand-defmethod-internal-real-body* NIL)
+
 (defun expand-defmethod-internal
-       (generic-function-name qualifiers specialized-lambda-list body env)
-  ;;(declare (values fn-form specializers doc))
+       (proto-generic-function proto-method generic-function-name
+        qualifiers specialized-lambda-list body env)
   (declare (ignore qualifiers))
+  (declare (values fn-form optimized-fn-form closure-generator-form
+                   initargs specializers doc))
   (when (listp generic-function-name)
     (do-standard-defsetf-1 (cadr generic-function-name)))
   (multiple-value-bind (documentation declarations real-body)
       (extract-declarations body)
     (multiple-value-bind (parameters lambda-list specializers)
-	(parse-specialized-lambda-list specialized-lambda-list)
-
-      
+        (parse-specialized-lambda-list specialized-lambda-list)
       (let* ((required-parameters
-	       (mapcar #'(lambda (r s) (declare (ignore s)) r)
-		       parameters
-		       specializers))
-	     (parameters-to-reference
-	       (make-parameter-references specialized-lambda-list
-					  required-parameters
-					  declarations
-					  generic-function-name
-					  specializers))
-	     (class-declarations 
-	       `(declare
-		  ,@(remove nil
-			    (mapcar #'(lambda (a s) (and (symbolp s)
-							 (neq s 't)
-							 `(class ,a ,s)))
-				    parameters
-				    specializers))))
-	     (method-lambda 
-	       ;; Remove the documentation string and insert the
-	       ;; appropriate class declarations.  The documentation
-	       ;; string is removed to make it easy for us to insert
-	       ;; new declarations later, they will just go after the
-	       ;; cadr of the method lambda.  The class declarations
-	       ;; are inserted to communicate the class of the method's
-	       ;; arguments to the code walk.
-	       (let ()
-		 `(lambda ,lambda-list
-		    ,class-declarations
-		    ,@declarations
-		    (progn ,@parameters-to-reference)
-		    (block ,(if (listp generic-function-name)
-				(cadr generic-function-name)
-				generic-function-name)
-		      ,@real-body))))
-
-	     (constant-value-p (and (null (cdr real-body))
-				    (constantp (car real-body))))
-	     (constant-value (and constant-value-p
-				  (eval (car real-body))))
-	     (plist (if (and constant-value-p
-			     (or (typep constant-value '(or number character))
-				 (and (symbolp constant-value)
-				      (symbol-package constant-value))))
-			(list :constant-value constant-value)
-			()))
-
-	     (call-next-method-p nil)   ;flag indicating that call-next-method
-	                                ;should be in the method definition
-	     (closurep nil)		;flag indicating that #'call-next-method
-					;was seen in the body of a method
-	     (next-method-p-p nil)      ;flag indicating that next-method-p
+               (mapcar #'(lambda (r s) (declare (ignore s)) r)
+                       parameters
+                       specializers))
+             (parameters-to-reference
+               (make-parameter-references specialized-lambda-list
+                                          required-parameters
+                                          declarations
+                                          generic-function-name
+                                          specializers))
+             (class-declarations 
+               `(declare
+                  ,@(remove nil
+                            (mapcar #'(lambda (a s) (and (symbolp s)
+                                                         (neq s 't)
+                                                         `(class ,a ,s)))
+                                    parameters
+                                    specializers))))
+             (lambda-expression
+               ;; Remove the documentation string and insert the
+               ;; appropriate class declarations.  The documentation
+               ;; string is removed to make it easy for us to insert
+               ;; new declarations later, they will just go after the
+               ;; cadr of the method lambda.  The class declarations
+               ;; are inserted to communicate the class of the method's
+               ;; arguments to the code walk.
+               (let ()
+                 `(lambda ,lambda-list
+                    ,class-declarations
+                    ,@declarations
+                    (progn ,@parameters-to-reference)
+                    (block ,(if (listp generic-function-name)
+                                (cadr generic-function-name)
+                                generic-function-name)
+                      ,@real-body)))))
+        (let ((*expand-defmethod-internal-real-body* real-body))
+          (multiple-value-bind
+              (function optimized-function closure-generator initargs)
+            (make-method-lambda-and-optimized-lambda
+                proto-generic-function proto-method lambda-expression env)
+            (values function
+                    optimized-function
+                    closure-generator
+                    initargs
+                    specializers
+                    documentation)))))))
+
+
+(declaim (ftype (function (T T T T) (values list list))
+		call-make-method-lambda
+		call-make-optimized-method-lambda))
+
+(defvar *optimized-method-lambda* NIL)
+
+(defun make-method-lambda-and-optimized-lambda
+  (generic-function method lambda-expression env)
+  ;;   Given the method body lambda-expression from expand-defmethod-internal,
+  ;; this method calls make-method-lambda to make the method-functions.
+  ;;   To adhere to the AMOP while retaining maximum efficiency, method
+  ;; functions are actually stored in two ways: as a (1) METHOD-FUNCTION and
+  ;; (2) as a METHOD-OPTIMIZED-FUNCTION or METHOD-CLOSURE-GENERATOR.
+  ;; METHOD-FUNCTION is the documented function of the AMOP.
+  ;; METHOD-OPTIMIZED-FUNCTION is the optimized function used by PCL in actual
+  ;; method function invocation (METHOD-FUNCTION-FOR-CACHING). Its arguments are
+  ;; the actual arguments of method, and it recieves its next-methods by
+  ;; looking at the global *NEXT-METHODS*.  Alternatively, if the method's
+  ;; body contains slot-value accesses that can be optimized for caching,
+  ;; a METHOD-CLOSURE-GENERATOR is stored instead of METHOD-OPTIMIZED-FUNCTION
+  ;; to generate an optimized caching function for given parameter types.
+  ;;
+  (let ((*optimized-method-lambda* NIL))
+    (multiple-value-bind (method-lambda initargs)
+      (call-make-method-lambda
+         generic-function method lambda-expression env)
+      (let* ((optimized-method-lambda
+               *optimized-method-lambda*)
+             (store-method-function-p
+               (call-store-method-function-p generic-function method initargs))
+             (store-method-optimized-function-p
+               (call-store-method-optimized-function-p
+                 generic-function method initargs))
+             (store-closure-generator-p
+               (call-store-closure-generator-p
+                 generic-function method initargs))
+             (standard-method-lambda-p
+               (and (equal (caddr method-lambda)
+                           *standard-pcl-make-method-lambda-doc-string*)
+                    optimized-method-lambda)))
+        (when (and (not standard-method-lambda-p)
+                   store-method-optimized-function-p)
+          ;;   Somebody modified make-method-lambda, but didn't specify that
+          ;; the generic-function doesn't use method-optimized-function.  So,
+          ;; to be safe, define the optimized-method-lambda to just call the
+          ;; method-lambda code they returned with the default method lambda
+          ;; arguments of the generic-function-args and *next-methods*.
+          ;;    For efficiency, the user should redefine
+          ;; compute-discriminating-function to directly call method-function
+          ;; rather than method-function-for-caching, and optionally define
+          ;; a generic-function-uses-method-optimized-function-p method on
+          ;; the generic-function/method class to return nil so no dummy
+          ;; optimized-method-function is created.
+          ;;    Alternatively, if the new make-method-lambda returns a lambda
+          ;; with the same arguments as a normal method lambda, then the
+          ;; make-method-lambda could be designed analogous to the one on
+          ;; standard-generic-function/standard-method, and making sure that
+          ;; the CADDR of the method-lambda returned equals
+          ;; *standard-pcl-make-method-lambda-doc-string* to signify
+          ;; that it's safe to use the *optimized-method-lambda* returned.
+          (setf optimized-method-lambda
+                `(lambda (&rest generic-function-args)
+                   (method-function-funcall (function ,method-lambda)
+                                            generic-function-args
+                                            (mapcar #'method-function-method
+                                               *next-methods*)))))
+        (values (when store-method-function-p
+                  method-lambda)
+                (when store-method-optimized-function-p
+                  optimized-method-lambda)
+                (when store-closure-generator-p
+                  (call-make-closure-generator-form generic-function method
+                     optimized-method-lambda initargs))
+                initargs)))))
+
+(defun make-std-documented-method-function (optimized-function)
+  ;; Make a standard documented method-function out of optimized-function.
+  #'(lambda (args &rest next-methods)
+      (let ((*next-methods*
+              (mapcar #'(lambda (method)
+                          (or (method-optimized-function method)
+                              (method-function-for-caching
+                                method
+                                (mapcar #'pcl::wrapper-of args))))
+                      next-methods)))
+        (method-function-apply optimized-function args))))
+
+(defun early-make-method-lambda (generic-function ; will be nil
+                                 method           ; will be nil
+                                 lambda-expression
+                                 environment)
+  (multiple-value-bind (optimized-method-lambda initargs)
+      (make-optimized-standard-method-lambda generic-function method
+                                             lambda-expression environment)
+    (setf *optimized-method-lambda* optimized-method-lambda)
+    (values
+      (make-documented-standard-method-lambda
+         lambda-expression
+         environment
+         *standard-pcl-make-method-lambda-doc-string*
+         (getf initargs :identifier))
+      initargs)))
+
+(defun make-optimized-standard-method-lambda
+       (generic-function method lambda-expression environment)
+  ;; Make the standard PCL rev4b optimized method lambda from
+  ;; the old expand-method-internal.
+  (let* ((method-lambda lambda-expression)
+         (lambda-list (cadr lambda-expression))
+         (required-parameters
+           (let ((collecting NIL))
+             (dolist (parameter lambda-list collecting)
+               (if (memq parameter lambda-list-keywords)
+                   (return collecting)
+                 (setf collecting (nconc collecting (list parameter)))))))
+
+         (call-next-method-p nil)       ;flag indicating that call-next-method
                                         ;should be in the method definition
-	     (save-original-args nil)   ;flag indicating whether or not the
-				        ;original arguments to the method
-					;must be preserved.  This happens
-					;for two reasons:
-	                                ; - the method takes &mumble args,
-					;   so one of the lexical functions
-					;   might be used in a default value
-	                                ;   form
-					; - call-next-method is used without
-					;   arguments at least once in the
-					;   body of the method
-	     (original-args ())
-	     (applyp nil)		;flag indicating whether or not the
-					;method takes &mumble arguments. If
-					;it does, it means call-next-method
-					;without arguments must be APPLY'd
-					;to original-args.  If this gets set
-					;true, save-original-args is set so
-					;as well
-	     (aux-bindings ())		;Suffice to say that &aux is one of
-					;damndest things to have put in a
-					;language.
-	     (need-pv-p nil)
-	     (slots (mapcar #'list required-parameters))
-	     (walked-lambda nil))
-	(flet ((walk-function (form context env)
-		 (cond ((not (eq context ':eval)) form)
-		       ((not (listp form)) form)
-		       ((eq (car form) 'call-next-method)
-			(setq call-next-method-p 't)
-			(unless (cdr form)
-			  (setq save-original-args t))
-			form)
-		       ((eq (car form) 'next-method-p)
-			(setq next-method-p-p 't)
-			form)
-		       ((and (eq (car form) 'function)
-			     (cond ((eq (cadr form) 'call-next-method)
-				    (setq call-next-method-p 't)
-				    (setq save-original-args 't)
-				    (setq closurep t)
-				    form)
-				   ((eq (cadr form) 'next-method-p)
-				    (setq next-method-p-p 't)
-				    (setq closurep t)
-				    form)
-				   (t nil))))
-		       ((and (or (eq (car form) 'slot-value)
-				 (eq (car form) 'set-slot-value)
-				 (eq (car form) 'slot-boundp))
-			     (constantp (caddr form)))
-			(let ((parameter
-                               (can-optimize-access form
-                                                    required-parameters env)))
+         (closurep nil)                 ;flag indicating that #'call-next-method
+                                        ;or #'next-method-p was seen in the
+                                        ;body of a method
+         (next-method-p-p nil)          ;flag indicating that next-method-p
+                                        ;should be in the method definition
+         (this-method-p nil)            ;flag indicating that this-method
+                                        ;should be in the method definition
+         (save-original-args nil)       ;flag indicating whether or not the
+                                        ;original arguments to the method
+                                        ;must be preserved.  This happens
+                                        ;for two reasons:
+                                        ; - the method takes &mumble args,
+                                        ;   so one of the lexical functions
+                                        ;   might be used in a default value
+                                        ;   form
+                                        ; - call-next-method is used without
+                                        ;   arguments at least once in the
+                                        ;   body of the method
+         (original-args ())
+         (mumblep nil)                  ;flag indicating whether or not the
+                                        ;method takes &mumble arguments
+         (applyp nil)                   ;flag indicating whether or not the
+                                        ;method takes &mumble arguments --
+                                        ;and call-next-method or next-method-p
+                                        ;was seen within their defaults
+                                        ;somewhere.  If it does, it means
+                                        ;call-next-method without arguments
+                                        ;must be APPLY'd to original-args.
+                                        ;If this gets set true,
+                                        ;save-original-args is set so as well
+         (aux-bindings ())              ;Suffice to say that &aux is one of
+                                        ;damndest things to have put in a
+                                        ;language.
+         (slots (mapcar #'list required-parameters))
+
+         (real-body *expand-defmethod-internal-real-body*)
+         (constant-value-p (and real-body
+                                (null (cdr real-body))
+                                (constantp (car real-body))))
+         (constant-value (and constant-value-p
+                              (eval (car real-body))))
+         (plist (if (and constant-value-p
+                         (or (typep constant-value '(or number character))
+                             (and (symbolp constant-value)
+                                  (symbol-package constant-value))))
+                    (list :constant-value constant-value)
+                    ()))
+
+         (walked-lambda nil))
+        (labels
+             ((walk-function (form context environment)
+                 (cond ((not (eq context ':eval)) form)
+                       ((not (listp form)) form)
+                       ((eq (car form) 'call-next-method)
+                        (setq call-next-method-p 't)
+                        (unless (cdr form)
+                          (setq save-original-args t))
+                        form)
+                       ((eq (car form) 'next-method-p)
+                        (setq next-method-p-p 't)
+                        form)
+                       ((eq (car form) 'this-method)
+                        (setq this-method-p 't)
+                        form)
+                       ((and (eq (car form) 'function)
+                             (cond ((eq (cadr form) 'call-next-method)
+                                    (setq call-next-method-p 't)
+                                    (setq save-original-args 't)
+                                    (setq closurep t)
+                                    form)
+                                   ((eq (cadr form) 'next-method-p)
+                                    (setq next-method-p-p 't)
+                                    (setq closurep t)
+                                    form)
+                                   ((eq (cadr form) 'this-method)
+                                    (setq this-method-p 't)
+                                    (setq closurep t)
+                                    form)
+                                   (t nil))))
+                       ((and (or (eq (car form) 'slot-value)
+                                 (eq (car form) 'set-slot-value)
+                                 (eq (car form) 'slot-boundp))
+                             (constantp (caddr form)))
+                        (let ((parameter
+                               (can-optimize-access
+                                  form required-parameters environment)))
                           (ecase (car form)
                             (slot-value
-                             (optimize-slot-value     slots parameter form))
+                             (optimize-slot-value generic-function method
+                                                  slots parameter form))
                             (set-slot-value
-                             (optimize-set-slot-value slots parameter form))
+                             (optimize-set-slot-value generic-function method
+                                                      slots parameter form))
                             (slot-boundp
-                             (optimize-slot-boundp    slots parameter form)))))
-		       ((and (or (symbolp (car form))
-				 (and (consp (car form))
-				      (eq (caar form) 'setf)))
-			     (gboundp (car form))
-			     (if (eq *boot-state* 'complete)
-				 (standard-generic-function-p (gdefinition (car form)))
-				 (funcallable-instance-p (gdefinition (car form)))))
-			(optimize-generic-function-call form required-parameters env))
-		       (t form))))
-	  
-	  (setq walked-lambda (walk-form method-lambda env #'walk-function))
-
-	  ;;
-	  ;; Add &allow-other-keys to the lambda list as an interim
-	  ;; way of implementing lambda list congruence rules.
-	  ;;
-	  (when (and (memq '&key lambda-list)
-		     (not (memq '&allow-other-keys lambda-list)))
-	    (let* ((rll (reverse lambda-list))
-		   (aux (memq '&aux rll)))
-	      (setq lambda-list
-		    (if aux
-			(progn (setf (cdr aux)
-				     (cons '&allow-other-keys (cdr aux)))
-			       (nreverse rll))
-		        (nconc (nreverse rll) (list '&allow-other-keys))))))
-	  ;; Scan the lambda list to determine whether this method
-	  ;; takes &mumble arguments.  If it does, we set applyp and
-	  ;; save-original-args true.
-	  ;; 
-	  ;; This is also the place where we construct the original
-	  ;; arguments lambda list if there has to be one.
-	  (dolist (p lambda-list)
-	    (if (memq p lambda-list-keywords)
-		(if (eq p '&aux)
-		    (progn
-		      (setq aux-bindings (cdr (memq '&aux lambda-list)))
-		      (return nil))
-		    (progn
-		      (setq applyp t
-			    save-original-args t)
-		      (push '&rest original-args)
-		      (push (make-symbol "AMPERSAND-ARGS") original-args)
-		      (return nil)))
-		(push (make-symbol (symbol-name p)) original-args)))
-	  (setq original-args (if save-original-args
-				  (nreverse original-args)
-				  ()))
-	  
-	  (multiple-value-bind (ignore walked-declarations walked-lambda-body)
-	      (extract-declarations (cddr walked-lambda))
-	    (declare (ignore ignore))
-
-	    
-            (when (setq need-pv-p (some #'cdr slots))
-              (setq slots (slot-name-lists-from-slots slots))
-              (setq plist (list* :isl slots plist))
-              (setq walked-lambda-body 
-                    (add-pv-binding walked-lambda-body plist required-parameters)))
-            (when (or next-method-p-p call-next-method-p)
-              (setq plist (list* :needs-next-methods-p 't plist)))
+                             (optimize-slot-boundp generic-function method
+                                                   slots parameter form)))))
+                       ((and (or (symbolp (car form))
+                                 (and (consp (car form))
+                                      (eq (caar form) 'setf)))
+                             (gboundp (car form))
+                             (if (eq *boot-state* 'complete)
+                                 (standard-generic-function-p (gdefinition (car form)))
+                                 (funcallable-instance-p (gdefinition (car form)))))
+                        (optimize-generic-function-call form required-parameters
+                           environment))
+                       (t form)))
+              (need-applyp (form)
+                (if (consp form)
+                    (or (need-applyp (car form)) (need-applyp (cdr form)))
+                    (memq form '(call-next-method next-method-p this-method)))))
+          
+          (setq walked-lambda (walk-form method-lambda environment #'walk-function))
+
+          ;;
+          ;; Add &allow-other-keys to the lambda list as an interim
+          ;; way of implementing lambda list congruence rules.
+          ;;
+          (when (and (memq '&key lambda-list)
+                     (not (memq '&allow-other-keys lambda-list)))
+            (let* ((rll (reverse lambda-list))
+                   (aux (memq '&aux rll)))
+              (setq lambda-list
+                    (if aux
+                        (progn (setf (cdr aux)
+                                     (cons '&allow-other-keys (cdr aux)))
+                               (nreverse rll))
+                        (nconc (nreverse rll) (list '&allow-other-keys))))))
+          ;; Scan the lambda list to determine whether this method
+          ;; takes &mumble arguments.  If it does, we set save-original-args
+          ;; and mumblep true.  We also check to see if a call-next-method or
+          ;; next-method-p is somewhere within the argument default value
+          ;; forms.  If so, we set applyp to T.
+          ;;
+          ;; (Note:  This is an optimization of the applyp restriction of
+          ;;   March 92 and earlier, which always set it to true if there
+          ;;   were any &mumble arguments.  I can't see this causing any
+          ;;   problems. -- TL)
+          ;; 
+          ;; This is also the place where we construct the original
+          ;; arguments lambda list if there has to be one.
+          (dolist (p lambda-list)
+            (if (memq p lambda-list-keywords)
+                (if (eq p '&aux)
+                    (progn
+                      (setq aux-bindings (cdr (memq '&aux lambda-list)))
+                      (return nil))
+                    (progn
+                      (setq mumblep T
+                            applyp (need-applyp lambda-list)
+                            save-original-args t)
+                      (push '&rest original-args)
+                      (push (make-symbol "AMPERSAND-ARGS") original-args)
+                      (return nil)))
+                (push (make-symbol (symbol-name p)) original-args)))
+          (setq original-args (if save-original-args
+                                  (nreverse original-args)
+                                  ()))
+          
+          (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+              (extract-declarations (cddr walked-lambda))
+            (declare (ignore ignore))
+
+            
+            (when (some #'cdr slots)
+              (setq plist
+                    (list* :optimized-slot-indices
+                           (mapcan #'(lambda (parameter-entry)
+                                       (mapcar #'(lambda (slot-entry)
+                                                   (cons (car parameter-entry)
+                                                         slot-entry)) 
+                                               (cdr parameter-entry)))
+                                   slots)
+                           plist)))
+            (setq plist
+                  (list* :needs-next-methods-p
+                         (or next-method-p-p call-next-method-p)
+                         plist))
 
             ;;; changes are here... (mt)
             (let ((fn-body `(lambda ,lambda-list
                               ,@walked-declarations
-                              ,.walked-lambda-body)))
-              (when (or call-next-method-p next-method-p-p)
-                (setq fn-body (add-lexical-functions-to-method-lambda
-                               walked-declarations
-                               walked-lambda-body
-                               fn-body
-                               original-args
-                               lambda-list
-                               save-original-args
-                               applyp
-                               aux-bindings
-                               call-next-method-p
-                               next-method-p-p
-                               closurep)))
+                              ,.walked-lambda-body))
+                  (method-identifier
+                    (when (or this-method-p call-next-method-p)
+                      (gentemp
+                        (if method
+                            (symbol-name (class-name (class-of method)))
+                            "STANDARD-METHOD")))))
+              (when method-identifier
+                (setf plist (list* :identifier method-identifier plist)))
+              (when (or call-next-method-p next-method-p-p this-method-p)
+                (setq fn-body
+                     (add-lexical-functions-to-optimized-standard-method-lambda
+                                walked-declarations
+                                walked-lambda-body
+                                fn-body
+                                original-args
+                                lambda-list
+                                save-original-args
+                                mumblep
+                                applyp
+                                aux-bindings
+                                call-next-method-p
+                                next-method-p-p
+                                this-method-p
+                                closurep
+                                method-identifier)))
+              (when (call-store-optimized-method-lambda-p
+                       generic-function method plist)
+                (setf plist (list* :optimized-method-lambda fn-body plist)))
               (values
-               (if need-pv-p
-                   (make-pv-fn-form `(function ,fn-body) plist)
-                   `(function ,fn-body))
-               specializers
-               documentation
-               plist))))))))
-
-(defun add-lexical-functions-to-method-lambda (walked-declarations
-					       walked-lambda-body
-					       walked-lambda
-					       original-args
-					       lambda-list
-					       save-original-args
-					       applyp
-					       aux-bindings
-					       call-next-method-p
-					       next-method-p-p
-					       closurep)
+                fn-body
+                plist))))))
+
+(defmacro add-lexical-functions-to-optimized-1
+    (lambda-list walked-lambda-body call-next-method-p next-method-p-p
+     this-method-p identifier)
+   ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args,
+   ;; and all args are mandatory (else APPLYP would be true).
+   `(let (,@(when (or next-method-p-p call-next-method-p)
+              `((.next-method. (car *next-methods*))))
+           ,@(when call-next-method-p
+              `((.next-methods. (cdr *next-methods*)))))
+       (macrolet (,@(when this-method-p
+                     `((this-method ()
+                        `(get-method-from-identifier ',',identifier))))
+                  ,@(when call-next-method-p
+                     `((call-next-method ,lambda-list
+                       `(if .next-method.
+                            (let ((*next-methods* .next-methods.))
+                              (method-function-funcall
+                                  .next-method. ,,@lambda-list))
+                            (no-next-method-trap
+                               ',',identifier ,,@lambda-list)))))
+                  ,@(when next-method-p-p
+                      `((next-method-p () `(not (null .next-method.))))))
+         ,@walked-lambda-body)))
+
+(defmacro add-lexical-functions-to-optimized-2
+    (lambda-list walked-declarations walked-lambda-body original-args
+     aux-bindings call-next-method-p next-method-p-p this-method-p identifier)
+   ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
+   ;; body with zero args, so we have to save the original args.
+   `(let (,@(when (or next-method-p-p call-next-method-p)
+              `((.next-method. (car *next-methods*))))
+          ,@(when call-next-method-p
+              `((.next-methods. (cdr *next-methods*)))))
+      (macrolet (,@(when this-method-p
+                    `((this-method ()
+                       `(get-method-from-identifier ',',identifier))))
+                 ,@(when call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                        `(if .next-method.
+                             (let ((*next-methods* .next-methods.))
+                               (method-function-funcall
+                                  .next-method.
+                                  ,@(if cnm-args cnm-args ',original-args)))
+                           (no-next-method-trap ',',identifier ,@cnm-args)))))
+                 ,@(when next-method-p-p
+                     '((next-method-p ()
+                        `(not (null .next-method.))))))
+        (let* (,@(mapcar #'list lambda-list original-args)
+               ,@aux-bindings)
+          ,@walked-declarations
+          ,@walked-lambda-body))))
+
+(defmacro add-lexical-functions-to-optimized-3
+    (walked-lambda original-args call-next-method-p next-method-p-p
+     this-method-p identifier)
+  ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
+  ;; body with zero args, so we have to save the original args.
+  `(let (,@(when (or next-method-p-p call-next-method-p)
+             `((.next-method. (car *next-methods*))))
+         ,@(when call-next-method-p
+             `((.next-methods. (cdr *next-methods*)))))
+      (macrolet (,@(when this-method-p
+                    `((this-method ()
+                       `(get-method-from-identifier ',',identifier))))
+                 ,@(when call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                        `(if .next-method.
+                             (let ((*next-methods* .next-methods.))
+                               ,(if cnm-args
+                                    `(method-function-funcall
+                                       .next-method.  ,@cnm-args)
+                                  `(method-function-apply
+                                     .next-method.
+                                     ,@',(remove '&rest original-args))))
+                           (no-next-method-trap ',',identifier ,@cnm-args)))))
+                 ,@(when next-method-p-p
+                     '((next-method-p ()
+                        `(not (null .next-method.))))))
+        (method-function-apply  (function ,walked-lambda)
+                                ,@(remove '&rest original-args)))))
+
+(defmacro add-lexical-functions-to-optimized-4
+    (walked-lambda-body call-next-method-p next-method-p-p
+     this-method-p identifier)
+  ;;
+  ;; We don't have to save the original arguments.  In addition,
+  ;; this method doesn't take any &mumble arguments that have
+  ;; the lexical functions inside their default value forms.
+  ;; Closurep is true, however, so the there might be an
+  ;; (apply #'call-next-method...), so we can't use MACROLET.
+  ;;
+  ;; We can expand this into a simple lambda expression with an
+  ;; FLET to define the lexical functions.
+  ;; 
+  `(let (,@(when (or next-method-p-p call-next-method-p)
+             `((.next-method. (car *next-methods*))))
+         ,@(when call-next-method-p
+             `((.next-methods. (cdr *next-methods*)))))
+      (flet (,@(and this-method-p
+                    `((this-method ()
+                        (get-method-from-identifier ',identifier))))
+             ,@(and call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                        #+Genera
+                        (declare (dbg:invisible-frame :clos-internal))
+                        (if .next-method.
+                            (let ((*next-methods* .next-methods.))
+                              (method-function-apply .next-method. cnm-args))
+                            (apply #'no-next-method-trap
+                                   ',identifier cnm-args)))))
+             ,@(and next-method-p-p
+                    '((next-method-p ()
+                        (not (null .next-method.))))))
+        ,@walked-lambda-body)))
+
+(defmacro add-lexical-functions-to-optimized-5
+    (lambda-list walked-declarations walked-lambda-body original-args
+     aux-bindings call-next-method-p next-method-p-p this-method-p identifier)
+  ;;
+  ;; This method doesn't accept any &mumble arguments that
+  ;; might try to call call-next-method or next-method-p.  But we
+  ;; do have to save the original arguments (this is because
+  ;; call-next-method is being called with no arguments).
+  ;; Have to be careful though, there may be multiple calls to
+  ;; call-next-method, all we know is that at least one of them
+  ;; is with no arguments.
+  ;; 
+  `(let (,@(when (or next-method-p-p call-next-method-p)
+             `((.next-method. (car *next-methods*))))
+         ,@(when call-next-method-p
+             `((.next-methods. (cdr *next-methods*)))))
+      (flet (,@(and this-method-p
+                    `((this-method ()
+                        (get-method-from-identifier ',identifier))))
+             ,@(and call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                        (if .next-method.
+                            (let ((*next-methods* .next-methods.))
+                              (if cnm-args
+                                  (method-function-apply .next-method. cnm-args)
+                                  (method-function-funcall
+                                     .next-method. ,@original-args)))
+                            (apply #'no-next-method-trap
+                                   ',identifier cnm-args)))))
+             ,@(and next-method-p-p
+                    '((next-method-p ()
+                        (not (null .next-method.))))))
+        (let* (,@(mapcar #'list
+                         (remtail lambda-list (memq '&aux lambda-list))
+                         original-args)
+               ,@aux-bindings)
+          ,@walked-declarations
+          ,@walked-lambda-body))))
+
+(defmacro add-lexical-functions-to-optimized-6
+    (walked-lambda original-args call-next-method-p next-method-p-p
+     this-method-p identifier)
+  ;;
+  ;; This is the fully general case.
+  ;; We must allow for the lexical functions being used inside
+  ;; the default value forms of &mumble arguments, and if must
+  ;; allow for call-next-method being called with no arguments.
+  ;;
+  `(let (,@(when (or next-method-p-p call-next-method-p)
+             `((.next-method. (car *next-methods*))))
+         ,@(when call-next-method-p
+             `((.next-methods. (cdr *next-methods*)))))
+      (flet (,@(and this-method-p
+                    `((this-method ()
+                        (get-method-from-identifier ',identifier))))
+             ,@(and call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                        (if .next-method.
+                            (let ((*next-methods* .next-methods.))
+                              (if cnm-args
+                                  (method-function-apply .next-method. cnm-args)
+                                  (method-function-apply
+                                     .next-method. 
+                                     ,@(remove '&rest original-args))))
+                            (apply #'no-next-method-trap
+                                   ',identifier cnm-args)))))
+             ,@(and next-method-p-p
+                    '((next-method-p ()
+                        (not (null .next-method.))))))
+        (method-function-apply  (function ,walked-lambda)
+                                ,@(remove '&rest original-args)))))
+
+(defun add-lexical-functions-to-optimized-standard-method-lambda
+      (walked-declarations
+       walked-lambda-body
+       walked-lambda
+       original-args
+       lambda-list
+       save-original-args
+       mumblep
+       applyp
+       aux-bindings
+       call-next-method-p
+       next-method-p-p
+       this-method-p
+       closurep
+       identifier)
   (cond ((and (null closurep)
-	      (null applyp)
-	      (null save-original-args))
-	 ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and
-	 ;; all args are mandatory (else APPLYP would be true).
-	 `(lambda ,lambda-list
-	    ,@walked-declarations
-	    (let ((.next-method. (car *next-methods*))
-		  (.next-methods. (cdr *next-methods*)))
-	      (macrolet ((call-next-method ,lambda-list
-			   `(if .next-method.
-				(let ((*next-methods* .next-methods.))
-				  (function-funcall .next-method. ,,@lambda-list))
-				(error "No next method.")))
-			 (next-method-p () `(not (null .next-method.))))
-		,@walked-lambda-body))))
-	((and (null closurep)
-	      (null applyp)
-	      save-original-args)
-	 ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
-	 ;; body with zero args, so we have to save the original args.
-	 (if save-original-args
-	     ;; CALL-NEXT-METHOD is sometimes called with no args
-	     `(lambda ,original-args
-		(let ((.next-method. (car *next-methods*))
-		      (.next-methods. (cdr *next-methods*)))
-		  (macrolet ((call-next-method (&rest cnm-args)
-			       `(if .next-method.
-				    (let ((*next-methods* .next-methods.))
-				      (function-funcall 
-				       .next-method.
-				       ,@(if cnm-args cnm-args ',original-args)))
-				    (error "No next method.")))
-			     (next-method-p () `(not (null .next-method.))))
-		    (let* (,@(mapcar #'list lambda-list original-args)
-			     ,@aux-bindings)
-		      ,@walked-declarations
-		      ,@walked-lambda-body))))))
-	((and (null save-original-args)
-	      (null applyp))
-	 ;;
-	 ;; We don't have to save the original arguments.  In addition,
-	 ;; this method doesn't take any &mumble arguments (this means
-	 ;; that there is no way the lexical functions can be used inside
-	 ;; of the default value form for an &mumble argument).
-	 ;;
-	 ;; We can expand this into a simple lambda expression with an
-	 ;; FLET to define the lexical functions.
-	 ;; 
-	 `(lambda ,lambda-list
-	    ,@walked-declarations
-	    (let ((.next-method. (car *next-methods*))
-		  (.next-methods. (cdr *next-methods*)))
-	      (flet (,@(and call-next-method-p
-			    '((call-next-method (&rest cnm-args)
-				#+Genera
-				(declare (dbg:invisible-frame :clos-internal))
-				(if .next-method.
-				    (let ((*next-methods* .next-methods.))
-				      (function-apply .next-method. cnm-args))
-				    (error "No next method.")))))
-		     ,@(and next-method-p-p
-			    '((next-method-p ()
-				(not (null .next-method.))))))
-		,@walked-lambda-body))))
-	((null applyp)
-	 ;;
-	 ;; This method doesn't accept any &mumble arguments.  But we
-	 ;; do have to save the original arguments (this is because
-	 ;; call-next-method is being called with no arguments).
-	 ;; Have to be careful though, there may be multiple calls to
-	 ;; call-next-method, all we know is that at least one of them
-	 ;; is with no arguments.
-	 ;; 
-	 `(lambda ,original-args
-	    (let ((.next-method. (car *next-methods*))
-		  (.next-methods. (cdr *next-methods*)))
-	      (flet (,@(and call-next-method-p
-                            `((call-next-method (&rest cnm-args)
-				(if .next-method.
-				    (let ((*next-methods* .next-methods.))
-				      (if cnm-args
-					  (function-apply .next-method. cnm-args)
-					  (function-funcall .next-method.
-							    ,@original-args)))
-				    (error "No next method.")))))
-		     ,@(and next-method-p-p
-			    '((next-method-p ()
-				(not (null .next-method.))))))
-		(let* (,@(mapcar #'list
-				 (remtail lambda-list (memq '&aux lambda-list))
-				 original-args)
-		       ,@aux-bindings)
-		  ,@walked-declarations
-		  ,@walked-lambda-body)))))
-	(t
-	 ;;
-	 ;; This is the fully general case.
-	 ;; We must allow for the lexical functions being used inside
-	 ;; the default value forms of &mumble arguments, and if must
-	 ;; allow for call-next-method being called with no arguments.
-	 ;; 
-	 `(lambda ,original-args
-	    (let ((.next-method. (car *next-methods*))
-		  (.next-methods. (cdr *next-methods*)))
-	      (flet (,@(and call-next-method-p
-			    `((call-next-method (&rest cnm-args)
-				(if .next-method.
-				    (let ((*next-methods* .next-methods.))
-				      (if cnm-args
-					  (function-apply .next-method. cnm-args)
-					  (function-apply .next-method.
-							  ,@(remove '&rest
-								    original-args))))
-				    (error "No next method.")))))
-		     ,@(and next-method-p-p
-			    '((next-method-p ()
-				(not (null .next-method.))))))
-		(apply (function ,walked-lambda)
-		       ,@(remove '&rest original-args))))))))
+              (null applyp)
+              (null save-original-args))
+         ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args,
+         ;; and all args are mandatory (else APPLYP would be true).
+         `(lambda ,lambda-list
+            ,@walked-declarations
+            (add-lexical-functions-to-optimized-1
+              ,lambda-list ,walked-lambda-body ,call-next-method-p
+              ,next-method-p-p ,this-method-p ,identifier)))
+        ((and (null closurep)
+              (null mumblep)
+              (null applyp)
+              save-original-args)
+         ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
+         ;; body with zero args, so we have to save the original args.
+         `(lambda ,original-args
+            (add-lexical-functions-to-optimized-2
+              ,lambda-list ,walked-declarations ,walked-lambda-body
+              ,original-args ,aux-bindings ,call-next-method-p ,next-method-p-p
+              ,this-method-p ,identifier)))
+        ((and (null closurep)
+              (null applyp)
+              save-original-args)
+         ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
+         ;; body with zero args, so we have to save the original args.
+         `(lambda ,original-args
+            (add-lexical-functions-to-optimized-3
+              ,walked-lambda ,original-args ,call-next-method-p
+              ,next-method-p-p ,this-method-p ,identifier)))
+        ((and (null save-original-args)
+              (null mumblep))
+         ;;
+         ;; We don't have to save the original arguments.  In addition,
+         ;; this method doesn't take any &mumble arguments that have
+         ;; the lexical functions inside their default value forms.
+         ;; Closurep is true, however, so the there might be an
+         ;; (apply #'call-next-method...), so we can't use MACROLET.
+         ;;
+         ;; We can expand this into a simple lambda expression with an
+         ;; FLET to define the lexical functions.
+         ;; 
+         `(lambda ,lambda-list
+            ,@walked-declarations
+            (add-lexical-functions-to-optimized-4
+              ,walked-lambda-body ,call-next-method-p ,next-method-p-p
+              ,this-method-p ,identifier)))
+        ((null mumblep)
+         ;;
+         ;; This method doesn't accept any &mumble arguments that
+         ;; might try to call call-next-method or next-method-p.  But we
+         ;; do have to save the original arguments (this is because
+         ;; call-next-method is being called with no arguments).
+         ;; Have to be careful though, there may be multiple calls to
+         ;; call-next-method, all we know is that at least one of them
+         ;; is with no arguments.
+         ;; 
+         `(lambda ,original-args
+            (add-lexical-functions-to-optimized-5
+              ,lambda-list ,walked-declarations ,walked-lambda-body
+              ,original-args ,aux-bindings ,call-next-method-p ,next-method-p-p
+              ,this-method-p ,identifier)))
+        (t
+         ;;
+         ;; This is the fully general case.
+         ;; We must allow for the lexical functions being used inside
+         ;; the default value forms of &mumble arguments, and if must
+         ;; allow for call-next-method being called with no arguments.
+         ;; 
+         `(lambda ,original-args
+            (add-lexical-functions-to-optimized-6
+              ,walked-lambda ,original-args ,call-next-method-p
+              ,next-method-p-p ,this-method-p ,identifier)))))
+
+
+(defun make-documented-standard-method-lambda (lambda-expression
+                                               environment
+                                               &optional
+                                               documentation
+                                               method-identifier)
+  ;;   Make the lambda for the documented AMOP method-function.
+  ;; This is basically the same as make-optimized-standard-method-lambda,
+  ;; except in the form need for the documented method-functions of standard
+  ;; method lambda.  Because the documented standard method functions aren't
+  ;; normally used in PCL's method dispatch, and only exist for correspondence
+  ;; to the AMOP in case somebody needs it, the code produced here is not as
+  ;; optimized as that produced by make-optimized-standard-method-lambda.
+  ;; In particular, it does not perform any of the normal permutation-vector
+  ;; optimizations for slot-value, and doesn't do anything tricky to optimized
+  ;; call-next-methods (add-lexical-functions-to-documented-standard-method-lambda).
+  (let* ((method-lambda lambda-expression)
+         (lambda-list (cadr lambda-expression))
+         (call-next-method-p nil)       ;flag indicating that call-next-method
+                                        ;should be in the method definition
+         (closurep nil)                 ;flag indicating that #'call-next-method
+                                        ;or #'next-method-p was seen in the
+                                        ;body of a method
+         (next-method-p-p nil)          ;flag indicating that next-method-p
+                                        ;should be in the method definition
+         (this-method-p nil)            ;flag indicating that this-method
+                                        ;should be in the method definition
+         (save-original-args nil)       ;flag indicating whether or not the
+                                        ;original arguments to the method
+                                        ;must be preserved.  This happens
+                                        ;for two reasons:
+                                        ; - the method takes &mumble args,
+                                        ;   so one of the lexical functions
+                                        ;   might be used in a default value
+                                        ;   form
+                                        ; - call-next-method is used without
+                                        ;   arguments at least once in the
+                                        ;   body of the method
+         (original-args ())
+         (mumblep nil)                  ;flag indicating whether or not the
+                                        ;method takes &mumble arguments
+         (applyp nil)                   ;flag indicating whether or not the
+                                        ;method takes &mumble arguments --
+                                        ;and call-next-method or next-method-p
+                                        ;was seen within their defaults
+                                        ;somewhere.  If it does, it means
+                                        ;call-next-method without arguments
+                                        ;must be APPLY'd to original-args.
+                                        ;If this gets set true,
+                                        ;save-original-args is set so as well
+         (aux-bindings ())              ;Suffice to say that &aux is one of
+                                        ;damndest things to have put in a
+                                        ;language.
+         (plist ())
+         (walked-lambda nil))
+        (labels
+             ((walk-function (form context environment)
+                 (declare (ignore environment))
+                 (cond ((not (eq context ':eval)) form)
+                       ((not (listp form)) form)
+                       ((eq (car form) 'call-next-method)
+                        (setq call-next-method-p 't)
+                        (unless (cdr form)
+                          (setq save-original-args t))
+                        form)
+                       ((eq (car form) 'next-method-p)
+                        (setq next-method-p-p 't)
+                        form)
+                       ((eq (car form) 'this-method)
+                        (setq this-method-p 't)
+                        form)
+                       ((and (eq (car form) 'function)
+                             (cond ((eq (cadr form) 'call-next-method)
+                                    (setq call-next-method-p 't)
+                                    (setq save-original-args 't)
+                                    (setq closurep t)
+                                    form)
+                                   ((eq (cadr form) 'next-method-p)
+                                    (setq next-method-p-p 't)
+                                    (setq closurep t)
+                                    form)
+                                   ((eq (cadr form) 'this-method)
+                                    (setq this-method-p 't)
+                                    (setq closurep t)
+                                    form)
+                                   (t nil))))
+                       ;; We don't try to optimize slot values for the
+                       ;; documented method lambdas, since they're never
+                       ;; really used anyway.
+                       (t form)))
+              (need-applyp (form)
+                (if (consp form)
+                    (or (need-applyp (car form)) (need-applyp (cdr form)))
+                    (memq form '(call-next-method next-method-p this-method)))))
+          
+          (setq walked-lambda (walk-form method-lambda environment #'walk-function))
+
+          ;;
+          ;; Add &allow-other-keys to the lambda list as an interim
+          ;; way of implementing lambda list congruence rules.
+          ;;
+          (when (and (memq '&key lambda-list)
+                     (not (memq '&allow-other-keys lambda-list)))
+            (let* ((rll (reverse lambda-list))
+                   (aux (memq '&aux rll)))
+              (setq lambda-list
+                    (if aux
+                        (progn (setf (cdr aux)
+                                     (cons '&allow-other-keys (cdr aux)))
+                               (nreverse rll))
+                        (nconc (nreverse rll) (list '&allow-other-keys))))))
+          ;; Scan the lambda list to determine whether this method
+          ;; takes &mumble arguments.  If it does, we set save-original-args
+          ;; and mumblep true.  We also check to see if a call-next-method or
+          ;; next-method-p is somewhere within the argument default value
+          ;; forms.  If so, we set applyp to T.
+          ;;
+          ;; (Note:  This is an optimization of the applyp restriction of
+          ;;   Rev4b and earlier, which always set it to true if there
+          ;;   were any &mumble arguments.  I can't see this causing any
+          ;;   problems. -- TL)
+          ;; 
+          ;; This is also the place where we construct the original
+          ;; arguments lambda list if there has to be one.
+          (dolist (p lambda-list)
+            (if (memq p lambda-list-keywords)
+                (if (eq p '&aux)
+                    (progn
+                      (setq aux-bindings (cdr (memq '&aux lambda-list)))
+                      (return nil))
+                    (progn
+                      (setq mumblep T
+                            applyp (need-applyp lambda-list)
+                            save-original-args t)
+                      (push '&rest original-args)
+                      (push (make-symbol "AMPERSAND-ARGS") original-args)
+                      (return nil)))
+                (push (make-symbol (symbol-name p)) original-args)))
+          (setq original-args (if save-original-args
+                                  (nreverse original-args)
+                                  ()))
+          
+          (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+              (extract-declarations (cddr walked-lambda))
+            (declare (ignore ignore))
+
+            (setq plist
+                  (list* :needs-next-methods-p (or next-method-p-p call-next-method-p)
+                         plist))
 
+            ;;; changes are here... (mt)
+            (let ((fn-body
+                   `(lambda ,lambda-list
+                       ,@walked-declarations
+                       ,.walked-lambda-body)))
+              (if (or call-next-method-p next-method-p-p this-method-p)
+                  (setf fn-body
+                    (add-lexical-functions-to-documented-standard-method-lambda
+                        walked-declarations
+                        walked-lambda-body
+                        fn-body
+                        original-args
+                        lambda-list
+                        save-original-args
+                        mumblep
+                        applyp
+                        aux-bindings
+                        call-next-method-p
+                        next-method-p-p
+                        this-method-p
+                        closurep
+                        documentation
+                        method-identifier))
+                  (setf fn-body
+                    `(lambda (args &rest next-methods)
+                       ,@(when documentation
+                           (list documentation))
+                       (declare (ignore next-methods))
+                       (apply #',fn-body args))))
+              (values
+                fn-body
+                plist))))))
+
+(defmacro add-lexical-functions-to-documented-general
+    (walked-lambda call-next-method-p next-method-p-p this-method-p identifier)
+  ;;
+  ;; This is the fully general case.
+  ;; We must allow for the lexical functions being used inside
+  ;; the default value forms of &mumble arguments, and if must
+  ;; allow for call-next-method being called with no arguments.
+  ;; 
+  `(let (,@(when (or next-method-p-p call-next-method-p)
+             `((.next-method. (car next-methods))))
+         ,@(when call-next-method-p
+             `((.next-methods. (cdr next-methods)))))
+      (flet (,@(and this-method-p
+                    `((this-method ()
+                        (get-method-from-identifier ',identifier))))
+             ,@(and call-next-method-p
+                    `((call-next-method (&rest cnm-args)
+                        (if .next-method.
+                             (method-function-funcall
+                                (method-function .next-method.)
+                                (or cnm-args args)
+                                .next-methods.)
+                            (no-next-method-trap ',identifier cnm-args)))))
+             ,@(and next-method-p-p
+                    '((next-method-p ()
+                        (not (null .next-method.))))))
+        (method-function-apply (function ,walked-lambda) args))))
+
+(defun add-lexical-functions-to-documented-standard-method-lambda
+      (walked-declarations
+       walked-lambda-body
+       walked-lambda
+       original-args
+       lambda-list
+       save-original-args
+       mumblep
+       applyp
+       aux-bindings
+       call-next-method-p
+       next-method-p-p
+       this-method-p
+       closurep
+       documentation
+       identifier)
+  (declare (ignore walked-declarations walked-lambda-body original-args
+                   lambda-list save-original-args mumblep applyp aux-bindings
+                   closurep))
+  ;; This could produce more efficient code by using the special case tricks
+  ;; of add-lexical-functions-to-optimized-standard-method-lambda,
+  ;; but documented method lambda's aren't normally used, so it wasn't
+  ;; worth doing here.
+  ;;   NOTE: Contents of documentation must appear in the CADDR of the
+  ;; lambda list returned as shown here to keep tricks of make-method-lambda
+  ;; happy (so it knows that the make-method-lambda used the standard
+  ;; return method.)
+  (cond (t
+         ;;
+         ;; This is the fully general case.
+         ;; We must allow for the lexical functions being used inside
+         ;; the default value forms of &mumble arguments, and if must
+         ;; allow for call-next-method being called with no arguments.
+         ;; 
+         `(lambda (args &rest next-methods)
+            ,@(when documentation
+                (list documentation))
+            (add-lexical-functions-to-documented-general
+              ,walked-lambda ,call-next-method-p ,next-method-p-p
+              ,this-method-p ,identifier)))))
+
+
+
+(defun no-next-method-trap (method-identifier &rest args)
+  (let ((method (get-method-from-identifier method-identifier)))
+    (if (and method method-identifier)
+        (apply #'no-next-method (method-generic-function method) method args)
+      (error "No next method."))))
 
 (defun make-parameter-references (specialized-lambda-list
-				  required-parameters
-				  declarations
-				  generic-function-name
-				  specializers)
+                                  required-parameters
+                                  declarations
+                                  generic-function-name
+                                  specializers)
   (flet ((ignoredp (symbol)
-	   (dolist (decl (cdar declarations))
-	     (when (and (eq (car decl) 'ignore)
-			(memq symbol (cdr decl)))
-	       (return t)))))	   
+           (dolist (decl (cdar declarations))
+             (when (and (eq (car decl) 'ignore)
+                        (memq symbol (cdr decl)))
+               (return t)))))      
     (gathering ((references (collecting)))
       (iterate ((s (list-elements specialized-lambda-list))
-		(p (list-elements required-parameters)))
-	(progn p)
-	(cond ((not (listp s)))
-	      ((ignoredp (car s))
-	       (warn "In defmethod ~S ~S, there is a~%~
+                (p (list-elements required-parameters)))
+        (progn p)
+        (cond ((not (listp s)))
+              ((ignoredp (car s))
+               (warn "In defmethod ~S ~S, there is a~%~
                       redundant ignore declaration for the parameter ~S."
-		     generic-function-name
-		     specializers
-		     (car s)))
-	      (t
-	       (gather (car s) references)))))))
+                     generic-function-name
+                     specializers
+                     (car s)))
+              (t
+               (gather (car s) references)))))))
 
+(defvar *method-identifier-table* (make-hash-table :test #'eq))
+
+(defun get-method-from-identifier (identifier)
+  (gethash identifier *method-identifier-table*))
+
+(defun set-get-method-from-identifier (identifier new-method)
+  (setf (gethash identifier *method-identifier-table*) new-method))
+
+(defsetf get-method-from-identifier set-get-method-from-identifier)
+
 
 (defvar *method-function-plist* (make-hash-table :test #'eq))
 
@@ -700,171 +1411,89 @@ work during bootstrapping.
        (val method-function key)
   (setf (getf  (method-function-plist method-function) key) val))
 
+(defun method-function-method (method-function)
+  (method-function-get method-function 'method))
 
-(defun method-function-isl (method-function)
-  (method-function-get method-function :isl))
+(defun set-method-function-method (method-function new-value)
+  (setf (method-function-get method-function 'method) new-value))
 
-(defun method-function-needs-next-methods-p (method-function)
-  (method-function-get method-function :needs-next-methods-p))
+(defsetf method-function-method set-method-function-method)
 
 
 
-(defmacro method-function-closure-generator (method-function)
-  `(method-function-get ,method-function 'closure-generator))
-
 (defun load-defmethod
-       (class name quals specls ll doc isl-cache-symbol plist fn)
+       (class name quals specls ll doc function optimized-function
+        closure-generator initargs)
   (when (listp name) (do-standard-defsetf-1 (cadr name)))
   (let ((method-spec (make-method-spec name quals specls)))
     (record-definition 'method method-spec)
-    (setq fn (set-function-name fn method-spec))
+    (when function
+      (setq function
+            (set-function-name (method-function-storage-form function)
+                               method-spec)))
+    (when optimized-function
+      (setq optimized-function
+            (set-function-name
+              (method-function-storage-form optimized-function)
+              method-spec)))
+    (when closure-generator
+      (setq closure-generator (method-function-storage-form closure-generator)))
     (load-defmethod-internal
-      name quals specls ll doc isl-cache-symbol plist fn class)))
+      name quals specls ll doc function class
+      optimized-function closure-generator initargs)))
 
 (defun load-defmethod-internal
-       (gf-spec qualifiers specializers
-	lambda-list doc isl-cache-symbol plist fn method-class)
+       (gf-spec qualifiers specializers lambda-list doc fn method-class
+        optimized-function closure-generator initargs)
   (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
-  (when plist
-    (setq plist (copy-list plist))	     ;Do this to keep from affecting
-					     ;the plist that is about to be
-					     ;dumped when we are compiling.
-    (let ((uisl (getf plist :isl))
-	  (isl nil))
-      (when uisl
-	(setq isl (intern-slot-name-lists uisl))
-	(setf (getf plist :isl) isl))
-      (when isl-cache-symbol
-	(setf (getf plist :isl-cache-symbol) isl-cache-symbol)
-	(set isl-cache-symbol isl)))
-
-    (loop (when (null plist) (return nil))
-          (setf (getf (method-function-plist fn) (pop plist)) (pop plist))))
-  (let ((method (add-named-method
-		  gf-spec qualifiers specializers lambda-list fn
-		  :documentation doc
-		  :definition-source `((defmethod ,gf-spec
-						  ,@qualifiers
-						  ,specializers)
-				       ,(load-truename)))))
-    (unless (or (eq method-class 'standard-method)
-		(eq (find-class method-class nil) (class-of method)))
+
+  (let ((method (apply
+                  #'add-named-method
+                  gf-spec method-class
+                  qualifiers specializers lambda-list fn
+                  optimized-function
+                  closure-generator
+                  :documentation doc
+                  :definition-source `((defmethod ,gf-spec
+                                                  ,@qualifiers
+                                                  ,specializers)
+                                       ,(load-truename))
+                  initargs)))
+    (when (and (eq *boot-state* 'complete)
+               (neq (find-class method-class nil)
+                    (generic-function-method-class (gdefinition gf-spec))))
       (format *error-output*
-	      "At the time the method with qualifiers ~:~S and~%~
-               specializers ~:S on the generic function ~S~%~
+              "At the time the method with qualifiers: ~S and~%~
+               specializers: ~S on the generic function ~S~%~
                was compiled, the method-class for that generic function was~%~
                ~S.  But, the method class is now ~S, this~%~
                may mean that this method was compiled improperly."
-	      qualifiers specializers gf-spec
-	      method-class (class-name (class-of method))))
+              qualifiers specializers gf-spec
+              method-class (class-name (class-of method))))
     method))
 
 
+
 (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
   `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
 
-
-
-(defun analyze-lambda-list (lambda-list)
-  ;;(declare (values nrequired noptional keysp restp allow-other-keys-p
-  ;;                 keywords keyword-parameters))
-  (flet ((parse-keyword-argument (arg)
-	   (if (listp arg)
-	       (if (listp (car arg))
-		   (caar arg)
-		   (make-keyword (car arg)))
-	       (make-keyword arg))))
-    (let ((nrequired 0)
-	  (noptional 0)
-	  (keysp nil)
-	  (restp nil)
-	  (allow-other-keys-p nil)
-	  (keywords ())
-	  (keyword-parameters ())
-	  (state 'required))
-      (dolist (x lambda-list)
-	(if (memq x lambda-list-keywords)
-	    (case x
-	      (&optional         (setq state 'optional))
-	      (&key              (setq keysp 't
-				       state 'key))
-	      (&allow-other-keys (setq allow-other-keys-p 't))
-	      (&rest             (setq restp 't
-				       state 'rest))
-	      (&aux              (return t))
-	      (otherwise
-		(error "Encountered the non-standard lambda list keyword ~S." x)))
-	    (ecase state
-	      (required  (incf nrequired))
-	      (optional  (incf noptional))
-	      (key       (push (parse-keyword-argument x) keywords)
-			 (push x keyword-parameters))
-	      (rest      ()))))
-      (values nrequired noptional keysp restp allow-other-keys-p
-	      (reverse keywords)
-	      (reverse keyword-parameters)))))
-
-(defun keyword-spec-name (x)
-  (let ((key (if (atom x) x (car x))))
-    (if (atom key)
-	(intern (symbol-name key) (find-package "KEYWORD"))
-	(car key))))
-
-(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name)
-  (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
-				  keywords keyword-parameters)
-      (analyze-lambda-list lambda-list)
-    (declare (ignore keyword-parameters))
-    (let* (#+cmu (old (c::info function type name))
-	   #+cmu (old-ftype (if (c::function-type-p old) old nil))
-	   #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype)))
-	   #+cmu (old-keys (and old-ftype
-				(mapcar #'c::key-info-name
-					(c::function-type-keywords old-ftype))))
-	   #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype)))
-	   #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype)))
-	   (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keywords))
-		     #-cmu (mapcar #'keyword-spec-name keywords)))
-      `(function ,(append (make-list nrequired :initial-element 't)
-			  (when (plusp noptional)
-			    (append '(&optional)
-				    (make-list noptional :initial-element 't)))
-			  (when (or restp #+cmu old-restp)
-			    '(&rest t))
-			  (when (or keysp #+cmu old-keysp)
-			    (append '(&key)
-				    (mapcar #'(lambda (key)
-						`(,key t))
-					    keywords)
-				    (when (or allow-other-keys-p #+cmu old-allowp)
-				      '(&allow-other-keys)))))
-		 *))))
-
-(defun proclaim-defgeneric (spec lambda-list)
-  (when (consp spec)
-    (setq spec (get-setf-function-name (cadr spec))))
-  (let ((decl `(ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec)
-		      ,spec)))
-    #+cmu (proclaim decl)
-    #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
-
 ;;;; Early generic-function support
 ;;;
 ;;;
 (defvar *early-generic-functions* ())
 
 (defun ensure-generic-function (function-specifier
-				&rest all-keys
-				&key environment
-				&allow-other-keys)
+                                &rest all-keys
+                                &key environment
+                                &allow-other-keys)
   (declare (ignore environment))
-  (let ((existing (and (gboundp function-specifier)		       
-		       (gdefinition function-specifier))))
+  (let ((existing (and (gboundp function-specifier)                    
+                       (gdefinition function-specifier))))
     (if (and existing
-	     (eq *boot-state* 'complete)
-	     (null (generic-function-p existing)))
-	(generic-clobbers-function function-specifier)
-	(apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
+             (eq *boot-state* 'complete)
+             (null (generic-function-p existing)))
+        (generic-clobbers-function function-specifier)
+        (apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
 
 (defun generic-clobbers-function (function-specifier)
   #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
@@ -873,7 +1502,7 @@ work during bootstrapping.
                   will require that you decide what to do with the existing function~%~
                   definition.~%~
                   The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
-		 function-specifier))
+                 function-specifier))
 
 #+Lispm
 (zl:defflavor generic-clobbers-function (name) (si:error)
@@ -881,12 +1510,12 @@ work during bootstrapping.
 
 #+Lispm
 (zl:defmethod #+Genera (dbg:report generic-clobbers-function)
-	      #+ti (generic-clobbers-function :report)
-	      (stream)
+              #+ti (generic-clobbers-function :report)
+              (stream)
  (format stream
-	 "~S aready names a ~a"
-	 name
-	 (if (and (symbolp name) (macro-function name)) "macro" "function")))
+         "~S aready names a ~a"
+         name
+         (if (and (symbolp name) (macro-function name)) "macro" "function")))
 
 #+Genera
 (zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) ()
@@ -912,35 +1541,48 @@ work during bootstrapping.
 ;;;    CADR   -   the early discriminator code for this method
 ;;;    
 (defun ensure-generic-function-using-class (existing spec &rest keys
-					    &key (lambda-list nil lambda-list-p)
-					    &allow-other-keys)
+                                            &key (lambda-list nil lambda-list-p)
+                                            &allow-other-keys)
   (declare (ignore keys))
   (if existing
       existing
       (unless (assoc spec *generic-function-fixups* :test #'equal)
-	(pushnew spec *early-generic-functions* :test #'equal)
-	(let ((fin (allocate-funcallable-instance-1)))
-	  (when (eq spec 'print-object)
-	    (set-funcallable-instance-function
-	     fin #'(lambda (instance stream)
-		     (printing-random-thing (instance stream)
-		       (format stream "std-instance")))))
-	  (setf (gdefinition spec) fin)
-	  (when lambda-list-p
-	    (proclaim-defgeneric spec lambda-list))
-	  (setf (fsc-instance-slots fin) (list nil nil spec))
-	  (set-function-name fin spec)
-	  fin))))
+        (pushnew spec *early-generic-functions* :test #'equal)
+        (let ((fin (allocate-funcallable-instance-1)))
+          (when (eq spec 'print-object)
+            (set-funcallable-instance-function
+             fin #'(lambda (instance stream)
+                     (printing-random-thing (instance stream)
+                       (format stream "std-instance")))))
+          (setf (gdefinition spec) fin)
+          (when lambda-list-p
+            (proclaim-defgeneric spec lambda-list))
+          (setf (fsc-instance-slots fin) (list nil nil spec))
+          (set-function-name fin spec)
+          fin))))
 
 (defun early-gf-p (x)
   (and (fsc-instance-p x)
        (listp (fsc-instance-slots x))))
 
-(defmacro early-gf-methods (early-gf)		;These are macros so that
-  `(car (fsc-instance-slots ,early-gf)))	;they can be setf'd.
-						;
-(defmacro early-gf-discriminator-code (early-gf);
-  `(cadr (fsc-instance-slots ,early-gf)))	;
+(defmacro early-gf-methods (early-gf)
+  `(let ((fsc-slots (fsc-instance-slots ,early-gf)))
+     (if (listp fsc-slots)
+         (car fsc-slots)
+         ;; This only happens when pcl is loaded on top of itself.
+         (slot-value ,early-gf 'methods))))
+
+(defmacro set-early-gf-methods (early-gf new-value)
+  `(let ((fsc-slots (fsc-instance-slots ,early-gf)))
+     (if (listp fsc-slots)
+         (setf (car fsc-slots) ,new-value)
+         ;; This only happens when pcl is loaded on top of itself.
+         (setf (slot-value ,early-gf 'methods) ,new-value))))
+
+(defsetf early-gf-methods set-early-gf-methods)
+
+(defmacro early-gf-discriminator-code (early-gf);These are macros so that
+  `(cadr (fsc-instance-slots ,early-gf)))       ;they can be setf'd.
 
 (defun early-gf-name (early-gf)
   (caddr (fsc-instance-slots early-gf)))
@@ -949,33 +1591,32 @@ work during bootstrapping.
 (defmacro real-ensure-gf-internal (gf-class all-keys env)
   `(progn
      (cond ((symbolp ,gf-class)
-	    (setq ,gf-class (find-class ,gf-class t ,env)))
-	   ((classp ,gf-class))
-	   (t
-	    (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
+            (setq ,gf-class (find-class ,gf-class t ,env)))
+           ((classp ,gf-class))
+           (t
+            (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
                     class nor a symbol that names a class."
-		   ,gf-class)))
+                   ,gf-class)))
      (remf ,all-keys :generic-function-class)
      (remf ,all-keys :environment)
      (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
        (unless (eq combin '.shes-not-there.)
-	 (setf (getf ,all-keys :method-combination)
-	       (find-method-combination (class-prototype ,gf-class)
-					(car combin)
-					(cdr combin)))))
+         (setf (getf ,all-keys :method-combination)
+               (find-method-combination (class-prototype ,gf-class)
+                                        (car combin)
+                                        (cdr combin)))))
      ))
      
 (defun real-ensure-gf-using-class--generic-function
        (existing
-	function-specifier
-	&rest all-keys
-	&key environment (lambda-list nil lambda-list-p)
-	     (generic-function-class 'standard-generic-function gf-class-p)
-	&allow-other-keys)
-  (declare (ignore function-specifier))
+        function-specifier
+        &rest all-keys
+        &key environment (lambda-list nil lambda-list-p)
+             (generic-function-class 'standard-generic-function gf-class-p)
+        &allow-other-keys)
   (real-ensure-gf-internal generic-function-class all-keys environment)
   (unless (or (null gf-class-p)
-	      (eq (class-of existing) generic-function-class))
+              (eq (class-of existing) generic-function-class))
     (change-class existing generic-function-class))
   (prog1
       (apply #'reinitialize-instance existing all-keys)
@@ -984,26 +1625,28 @@ work during bootstrapping.
 
 (defun real-ensure-gf-using-class--null
        (existing
-	function-specifier
-	&rest all-keys
-	&key environment (lambda-list nil lambda-list-p)
-	     (generic-function-class 'standard-generic-function)
-	&allow-other-keys)
+        function-specifier
+        &rest all-keys
+        &key environment (lambda-list nil lambda-list-p)
+             (generic-function-class 'standard-generic-function)
+        &allow-other-keys)
   (declare (ignore existing))
   (real-ensure-gf-internal generic-function-class all-keys environment)
   (prog1
       (setf (gdefinition function-specifier)
-	    (apply #'make-instance generic-function-class 
-		   :name function-specifier all-keys))
+            (apply #'make-instance generic-function-class 
+                   :name function-specifier all-keys))
     (when lambda-list-p
       (proclaim-defgeneric function-specifier lambda-list))))
 
+
 
 
-(defun early-make-a-method (class qualifiers arglist specializers function doc
-			    &optional slot-name)
+(defun early-make-a-method
+   (class qualifiers arglist specializers function optimized-function
+    closure-generator doc &optional slot-name other-initargs)
   (let ((parsed ())
-	(unparsed ()))
+        (unparsed ()))
     ;; Figure out whether we got class objects or class names as the
     ;; specializers and set parsed and unparsed appropriately.  If we
     ;; got class objects, then we can compute unparsed, but if we got
@@ -1012,44 +1655,57 @@ work during bootstrapping.
     ;; Note that the use of not symbolp in this call to every should be
     ;; read as 'classp' we can't use classp itself because it doesn't
     ;; exist yet.
+    (setf function           (method-function-storage-form function))
+    (setf optimized-function (method-function-storage-form optimized-function))
+    (setf closure-generator  (method-function-storage-form closure-generator))
     (if (every #'(lambda (s) (not (symbolp s))) specializers)
-	(setq parsed specializers
-	      unparsed (mapcar #'(lambda (s)
-				   (if (eq s 't) 't (class-name s)))
-			       specializers))
-	(setq unparsed specializers
-	      parsed ()))
-    (list :early-method		  ;This is an early method dammit!
-	  
-	  function                ;Function is here for the benefit
-				  ;of early-lookup-method.
-	  
-	  parsed                  ;The parsed specializers.  This is used
-				  ;by early-method-specializers to cache
-				  ;the parse.  Note that this only comes
-				  ;into play when there is more than one
-				  ;early method on an early gf.
-	  
-	  (list class             ;A list to which real-make-a-method
-		qualifiers        ;can be applied to make a real method
-		arglist           ;corresponding to this early one.
-		unparsed
-		function
-		doc
-		slot-name)
-	  )))
+        (setq parsed specializers
+              unparsed (mapcar #'(lambda (s)
+                                   (if (eq s 't) 't (class-name s)))
+                               specializers))
+        (setq unparsed specializers
+              parsed ()))
+    (list :early-method           ;This is an early method dammit!
+          
+          (or optimized-function
+              (make-not-for-caching-method-function closure-generator))
+                                  ;Function is here for the benefit
+                                  ;of early-lookup-method.
+          
+          parsed                  ;The parsed specializers.  This is used
+                                  ;by early-method-specializers to cache
+                                  ;the parse.  Note that this only comes
+                                  ;into play when there is more than one
+                                  ;early method on an early gf.
+          
+          (list class             ;A list to which real-make-a-method
+                qualifiers        ;can be applied to make a real method
+                arglist           ;corresponding to this early one.
+                unparsed
+                function
+                optimized-function
+                closure-generator
+                doc
+                slot-name
+                other-initargs)
+          )))
 
 (defun real-make-a-method
-       (class qualifiers lambda-list specializers function doc
-	&optional slot-name)
+  (class qualifiers lambda-list specializers function optimized-function
+   closure-generator doc &optional slot-name other-initargs)
   (setq specializers (parse-specializers specializers))
-  (make-instance class :qualifiers qualifiers
-		       :lambda-list lambda-list
-		       :specializers specializers
-		       :function function
-		       :documentation doc
-		       :slot-name slot-name
-		       :allow-other-keys t))
+  (apply #'make-instance
+         class
+         :qualifiers qualifiers
+         :lambda-list lambda-list
+         :specializers specializers
+         :function           (method-function-storage-form function)
+         :optimized-function (method-function-storage-form optimized-function)
+         :closure-generator  (method-function-storage-form closure-generator)
+         :documentation doc
+         :slot-name slot-name
+         :allow-other-keys t
+         other-initargs))
 
 (defun early-method-function (early-method)
   (cadr early-method))
@@ -1076,37 +1732,43 @@ work during bootstrapping.
 ;;;  
 (defun early-method-specializers (early-method &optional objectsp)
   (if (and (listp early-method)
-	   (eq (car early-method) :early-method))
+           (eq (car early-method) :early-method))
       (cond ((eq objectsp 't)
-	     (or (caddr early-method)
-		 (setf (caddr early-method)
-		       (mapcar #'find-class (cadddr (cadddr early-method))))))
-	    (t
-	     (cadddr (cadddr early-method))))
+             (or (caddr early-method)
+                 (setf (caddr early-method)
+                       (mapcar #'find-class (cadddr (cadddr early-method))))))
+            (t
+             (cadddr (cadddr early-method))))
       (error "~S is not an early-method." early-method)))
 
 (defun early-method-qualifiers (early-method)
   (cadr (cadddr early-method)))
 
 (defun early-add-named-method (generic-function-name
-			       qualifiers
-			       specializers
-			       arglist
-			       function
-			       &rest options)
-  (declare (ignore options))
+                               method-class
+                               qualifiers
+                               specializers
+                               arglist
+                               function
+                               optimized-function
+                               closure-generator
+                               &rest other-initargs)
   (let* ((gf (ensure-generic-function generic-function-name))
-	 (existing
-	   (dolist (m (early-gf-methods gf))
-	     (when (and (equal (early-method-specializers m) specializers)
-			(equal (early-method-qualifiers m) qualifiers))
-	       (return m))))
-	 (new (make-a-method 'standard-method
-			     qualifiers
-			     arglist
-			     specializers
-			     function
-			     ())))
+         (existing
+           (dolist (m (early-gf-methods gf))
+             (when (and (equal (early-method-specializers m) specializers)
+                        (equal (early-method-qualifiers m) qualifiers))
+               (return m))))
+         (new (make-a-method method-class
+                             qualifiers
+                             arglist
+                             specializers
+                             function
+                             optimized-function
+                             closure-generator
+                             ()
+                             ()
+                             other-initargs)))
     (when existing (remove-method gf existing))
     (add-method gf new)))
 
@@ -1132,102 +1794,102 @@ work during bootstrapping.
   (when (not (and (listp method) (eq (car method) :early-method)))
     (error "Early remove-method didn't get an early method."))
   (setf (early-gf-methods generic-function)
-	(remove method (early-gf-methods generic-function)))
+        (remove method (early-gf-methods generic-function)))
   (early-update-discriminator-code generic-function))
 
 ;;;
 ;;; And the early version of get-method.
 ;;;
 (defun get-method (generic-function qualifiers specializers
-				    &optional (errorp t))
+                                    &optional (errorp t))
   (if (early-gf-p generic-function)
       (or (dolist (m (early-gf-methods generic-function))
-	    (when (and (or (equal (early-method-specializers m nil)
-				  specializers)
-			   (equal (early-method-specializers m 't)
-				  specializers))
-		       (equal (early-method-qualifiers m) qualifiers))
-	      (return m)))
-	  (if errorp
-	      (error "Can't get early method.")
-	      nil))
+            (when (and (or (equal (early-method-specializers m nil)
+                                  specializers)
+                           (equal (early-method-specializers m 't)
+                                  specializers))
+                       (equal (early-method-qualifiers m) qualifiers))
+              (return m)))
+          (if errorp
+              (error "Can't get early method.")
+              nil))
       (real-get-method generic-function qualifiers specializers errorp)))
 
 (defun early-update-discriminator-code (generic-function)
   (let* ((methods (early-gf-methods generic-function))
-	 (early-dfun
-	   (cond ((null methods)
-		  #'(lambda (&rest ignore)
-		      (declare (ignore ignore))
-		      (error "Called an early generic-function that ~
+         (early-dfun
+           (cond ((null methods)
+                  #'(lambda (&rest ignore)
+                      (declare (ignore ignore))
+                      (error "Called an early generic-function that ~
                               has no methods?")))
-		 ((null (cdr methods))
-		  ;; If there is only one method, just use that method's
-		  ;; function.  This corresponds to the important fact
-		  ;; that early generic-functions with only one method
-		  ;; always call that method when they are called.  If
-		  ;; there is more than one method, we have to install
-		  ;; a simple little discriminator-code for this generic
-		  ;; function.
-		  (cadr (car methods)))
-		 (t
-		  (set-function-name 
-		   #'(lambda (&rest args) (early-dfun methods args))
-		   (early-gf-name generic-function))))))
+                 ((null (cdr methods))
+                  ;; If there is only one method, just use that method's
+                  ;; function.  This corresponds to the important fact
+                  ;; that early generic-functions with only one method
+                  ;; always call that method when they are called.  If
+                  ;; there is more than one method, we have to install
+                  ;; a simple little discriminator-code for this generic
+                  ;; function.
+                  (cadr (car methods)))
+                 (t
+                  (set-function-name 
+                   #'(lambda (&rest args) (early-dfun methods args))
+                   (early-gf-name generic-function))))))
     (set-funcallable-instance-function generic-function early-dfun)
     (setf (early-gf-discriminator-code generic-function) early-dfun)))
 
 (defun early-get-cpl (object)
   (bootstrap-get-slot 'std-class
-		      (class-of object)
-		      'class-precedence-list))
+                      (class-of object)
+                      'class-precedence-list))
 
 (defun early-sort-methods (list args)
   (if (null (cdr list))
       list
       (sort list
-	    #'(lambda (specls-1 specls-2)
-		(iterate ((s1 (list-elements specls-1))
-			  (s2 (list-elements specls-2))
-			  (a (list-elements args)))
-		  (cond ((eq s1 s2))
-			((eq s2 *the-class-t*) (return t))
-			((eq s1 *the-class-t*) (return nil))
-			(t (return (memq s2 (memq s1 (early-get-cpl a))))))))
-	    :key #'(lambda (em) (early-method-specializers em t)))))
+            #'(lambda (specls-1 specls-2)
+                (iterate ((s1 (list-elements specls-1))
+                          (s2 (list-elements specls-2))
+                          (a (list-elements args)))
+                  (cond ((eq s1 s2))
+                        ((eq s2 *the-class-t*) (return t))
+                        ((eq s1 *the-class-t*) (return nil))
+                        (t (return (memq s2 (memq s1 (early-get-cpl a))))))))
+            :key #'(lambda (em) (early-method-specializers em t)))))
 
 (defun early-dfun (methods args)
   (let ((primary ())
-	(before ())
-	(after ())
-	(around ()))
+        (before ())
+        (after ())
+        (around ()))
     (dolist (method methods)
       (let* ((specializers (early-method-specializers method t))
-	     (qualifiers (early-method-qualifiers method))
-	     (args args)
-	     (specs specializers))
-	(when (loop
-		(when (or (null args)
-			  (null specs))
-		  ;; If we are out of specs, then we must be in the optional,
-		  ;; rest or keywords arguments.  This method is applicable
-		  ;; to these arguments.  Return T.
-		  (return t))
-		(let ((arg (pop args))
-		      (spec (pop specs)))
-		  (unless (or (eq spec *the-class-t*)
-			      (memq spec (early-get-cpl arg)))
-		    (return nil))))
-	  (cond ((null qualifiers) (push method primary))
-		((equal qualifiers '(:before)) (push method before))
-		((equal qualifiers '(:after))  (push method after))
-		((equal qualifiers '(:around)) (push method around))
-		(t
-		 (error "Unrecognized qualifer in early method."))))))
+             (qualifiers (early-method-qualifiers method))
+             (args args)
+             (specs specializers))
+        (when (loop
+                (when (or (null args)
+                          (null specs))
+                  ;; If we are out of specs, then we must be in the optional,
+                  ;; rest or keywords arguments.  This method is applicable
+                  ;; to these arguments.  Return T.
+                  (return t))
+                (let ((arg (pop args))
+                      (spec (pop specs)))
+                  (unless (or (eq spec *the-class-t*)
+                              (memq spec (early-get-cpl arg)))
+                    (return nil))))
+          (cond ((null qualifiers) (push method primary))
+                ((equal qualifiers '(:before)) (push method before))
+                ((equal qualifiers '(:after))  (push method after))
+                ((equal qualifiers '(:around)) (push method around))
+                (t
+                 (error "Unrecognized qualifier in early method."))))))
     (setq primary (early-sort-methods primary args)
-	  before  (early-sort-methods before  args)
-	  after   (early-sort-methods after   args)
-	  around  (early-sort-methods around  args))
+          before  (early-sort-methods before  args)
+          after   (early-sort-methods after   args)
+          around  (early-sort-methods around  args))
     (flet ((do-main-combined-method (&rest arguments)
              (dolist (m before) (apply (cadr m) arguments))
              (multiple-value-prog1
@@ -1245,115 +1907,124 @@ work during bootstrapping.
 
 (defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
   (allocate-instance (find-class 'standard-generic-function)) ;Be sure this
-					                      ;class has an
-					                      ;instance.
+                                                              ;class has an
+                                                              ;instance.
   (let* ((class (find-class 'standard-generic-function))
-	 (wrapper (class-wrapper class))
-	 (n-static-slots (class-no-of-instance-slots class))
-	 (default-initargs (default-initargs class ()))
-	 #+Lucid
-	 (lucid::*redefinition-action* nil))
+         (wrapper (class-wrapper class))
+         (statics-slots-copy
+           (wrapper-allocate-static-slot-storage-copy wrapper))
+         (default-initargs
+           (default-initargs class () (class-default-initargs class)))
+         #+Lucid
+         (lucid::*redefinition-action* nil))
     (flet ((fix-structure (gf)
-	     (let ((static-slots
-		    (%allocate-static-slot-storage--class n-static-slots)))
-	       (setf (fsc-instance-wrapper gf) wrapper
-		     (fsc-instance-slots gf) static-slots))))
-      ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions.
+             (let ((static-slots
+                    (%allocate-static-slot-storage--class statics-slots-copy)))
+               (setf (fsc-instance-wrapper gf) wrapper
+                     (fsc-instance-slots gf) static-slots))))
       (let ((accessors nil))
-	(dolist (early-gf-spec *early-generic-functions*)
-	  (when (every #'early-method-standard-accessor-p
-		       (early-gf-methods (gdefinition early-gf-spec)))
-	    (push early-gf-spec accessors)))
-	(dolist (spec (nconc accessors
-			     '(accessor-method-slot-name
-			       generic-function-methods
-			       method-specializers
-			       specializerp
-			       specializer-type
-			       specializer-class
-			       slot-definition-location
-			       slot-definition-name
-			       class-slots
-			       gf-arg-info
-			       class-precedence-list
-			       slot-boundp-using-class
-			       (setf slot-value-using-class)
-			       slot-value-using-class)))
-	  (setq *early-generic-functions* 
-		(cons spec (delete spec *early-generic-functions* :test #'equal)))))
+        (dolist (early-gf-spec *early-generic-functions*)
+          (when (every #'early-method-standard-accessor-p
+                       (early-gf-methods (gdefinition early-gf-spec)))
+            (push early-gf-spec accessors)))
+        (dolist (spec (nconc accessors
+                             '(slot-boundp-using-class
+                               (setf slot-value-using-class)
+                               slot-value-using-class)))
+          (setq *early-generic-functions* 
+                (cons spec (delete spec *early-generic-functions*
+                                   :test #'equal)))))
       (dolist (early-gf-spec *early-generic-functions*)
-	(when noisyp (format t "~&~S..." early-gf-spec))
-	(let* ((early-gf (gdefinition early-gf-spec))
-	       (early-static-slots
-		(fsc-instance-slots early-gf))
-	       (early-discriminator-code nil)
-	       (early-methods nil)
-	       (aborted t))
-	  (flet ((trampoline (&rest args)
-		   (apply early-discriminator-code args)))
-	    (if (not (listp early-static-slots))
-		(when noisyp (format t "already fixed?"))
-		(unwind-protect
-		     (progn
-		       (setq early-discriminator-code
-			     (early-gf-discriminator-code early-gf))
-		       (setq early-methods
-			     (early-gf-methods early-gf))
-		       (setf (gdefinition early-gf-spec) #'trampoline)
-		       (when noisyp (format t "trampoline..."))
-		       (fix-structure early-gf)
-		       (when noisyp (format t "fixed..."))
-		       (apply #'initialize-instance early-gf
-			      :name early-gf-spec default-initargs)
-		       (loop
-			(when (null early-methods) (return nil))
-			(let ((early-method (pop early-methods)))
-			  (destructuring-bind
-				(class quals lambda-list specs fn doc slot-name)
-			      (cadddr early-method)
-			    (setq specs (early-method-specializers early-method t))
-			    (let ((method (real-make-a-method class
-							      quals
-							      lambda-list
-							      specs
-							      fn
-							      doc
-							      slot-name)))
-			      (real-add-method early-gf method)
-			      (when noisyp (format t "m"))))))
-		       (setf (generic-function-name early-gf) early-gf-spec)
-		       (setq aborted nil))
-		  (setf (gdefinition early-gf-spec) early-gf)
-		  (when noisyp (format t "."))
-		  (when aborted
-		    (setf (fsc-instance-slots early-gf)
-			  early-static-slots))))))))
-	  
+        (when noisyp (format t "~&~S..." early-gf-spec))
+        (let* ((early-gf (gdefinition early-gf-spec))
+               (early-static-slots
+                (fsc-instance-slots early-gf))
+               (early-discriminator-code nil)
+               (early-methods nil)
+               (aborted t))
+          (flet ((trampoline (&rest args)
+                   (apply early-discriminator-code args)))
+            (if (not (listp early-static-slots))
+                (when noisyp (format t "already fixed?"))
+                (unwind-protect
+                     (progn
+                       (setq early-discriminator-code
+                             (early-gf-discriminator-code early-gf))
+                       (setq early-methods
+                             (early-gf-methods early-gf))
+                       (setf (gdefinition early-gf-spec) #'trampoline)
+                       (when noisyp (format t "trampoline..."))
+                       (fix-structure early-gf)
+                       (when noisyp (format t "fixed..."))
+                       (apply #'initialize-instance early-gf
+                              :name early-gf-spec default-initargs)
+                       (loop
+                        (when (null early-methods) (return nil))
+                        (let ((early-method (pop early-methods)))
+                          (destructuring-bind
+                             (class quals lambda-list specs fn
+                              optimized-function closure-generator doc
+                              slot-name other-initargs)
+                              (cadddr early-method)
+                            (setq specs
+                                  (early-method-specializers early-method t))
+                            (let ((method (real-make-a-method
+                                              class
+                                              quals
+                                              lambda-list
+                                              specs
+                                              fn
+                                              optimized-function
+                                              closure-generator
+                                              doc
+                                              slot-name
+                                              other-initargs)))
+                              (real-add-method early-gf method)
+                              (when noisyp (format t "m"))))))
+                       (setf (generic-function-name early-gf) early-gf-spec)
+                       (setq aborted nil))
+                  (setf (gdefinition early-gf-spec) early-gf)
+                  (when noisyp (format t "."))
+                  (when aborted
+                    (setf (fsc-instance-slots early-gf)
+                          early-static-slots))))))))
+          
     (dolist (fns *early-functions*)
       (setf (symbol-function (car fns)) (symbol-function (caddr fns))))
       
     (dolist (fixup *generic-function-fixups*)
       (let ((fspec (car fixup))
-	    (methods (cdr fixup))
-	    (gf (make-instance 'standard-generic-function)))
-	(set-function-name gf fspec)
-	(setf (generic-function-name gf) fspec)
-	(loop 
-	 (when (null methods) (return nil))
-	 (let ((method (pop methods)))
-	   (destructuring-bind (lambda-list specializers method-fn-name)
-	       method
-	     (let* ((fn (if method-fn-name
-			    (symbol-function method-fn-name)
-			    (symbol-function fspec)))
-		    (method (make-a-method 'standard-method
-					   ()
-					   lambda-list
-					   specializers
-					   fn
-					   nil)))
-	       (real-add-method gf method)))))
-	(setf (gdefinition fspec) gf)))))
+            (methods (cdr fixup))
+            (gf (make-instance 'standard-generic-function)))
+        (set-function-name gf fspec)
+        (setf (generic-function-name gf) fspec)
+        (loop 
+         (when (null methods) (return nil))
+         (let ((method (pop methods)))
+           (destructuring-bind (lambda-list specializers method-fn-name)
+               method
+              (let*
+                ((optimized-function
+                   (if method-fn-name
+                       (symbol-function method-fn-name)
+                       (symbol-function fspec)))
+                 (function
+                   (when (call-store-method-function-p
+                           gf
+                           (class-prototype *the-class-standard-method*)
+                           nil)
+                      (make-std-documented-method-function
+                        optimized-function)))
+                 (method (make-a-method 'standard-method
+                                        ()
+                                        lambda-list
+                                        specializers
+                                        function
+                                        optimized-function
+                                        nil
+                                        nil)))
+               (real-add-method gf method)))))
+        (setf (gdefinition fspec) gf)))))
 
 
 ;;;
@@ -1362,32 +2033,32 @@ work during bootstrapping.
 ;;; implemented.
 ;;; 
 (defun parse-defmethod (cdr-of-form)
-  ;;(declare (values name qualifiers specialized-lambda-list body))
+  (declare (values name qualifiers specialized-lambda-list body))
   (let ((name (pop cdr-of-form))
-	(qualifiers ())
-	(spec-ll ()))
+        (qualifiers ())
+        (spec-ll ()))
     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
-	      (push (pop cdr-of-form) qualifiers)
-	      (return (setq qualifiers (nreverse qualifiers)))))
+              (push (pop cdr-of-form) qualifiers)
+              (return (setq qualifiers (nreverse qualifiers)))))
     (setq spec-ll (pop cdr-of-form))
     (values name qualifiers spec-ll cdr-of-form)))
 
 (defun parse-specializers (specializers)
   (flet ((parse (spec)
-	   (let ((result (specializer-from-type spec)))
-	     (if (specializerp result)
-		 result
-		 (if (symbolp spec)
-		     (error "~S used as a specializer,~%~
+           (let ((result (specializer-from-type spec)))
+             (if (specializerp result)
+                 result
+                 (if (symbolp spec)
+                     (error "~S used as a specializer,~%~
                              but is not the name of a class."
-			    spec)
-		     (error "~S is not a legal specializer." spec))))))
+                            spec)
+                     (error "~S is not a legal specializer." spec))))))
     (mapcar #'parse specializers)))
 
 (defun unparse-specializers (specializers-or-method)
   (if (listp specializers-or-method)
       (flet ((unparse (spec)
-	       (if (specializerp spec)
+               (if (specializerp spec)
                    (let ((type (specializer-type spec)))
                      (if (and (consp type)
                               (eq (car type) 'class))
@@ -1397,41 +2068,10 @@ work during bootstrapping.
                                class-name
                                type))
                          type))
-		   (error "~S is not a legal specializer." spec))))
-	(mapcar #'unparse specializers-or-method))
+                   (error "~S is not a legal specializer." spec))))
+        (mapcar #'unparse specializers-or-method))
       (unparse-specializers (method-specializers specializers-or-method))))
 
-(defun parse-method-or-spec (spec &optional (errorp t))
-  ;;(declare (values generic-function method method-name))
-  (let (gf method name temp)
-    (if (method-p spec)	
-	(setq method spec
-	      gf (method-generic-function method)
-	      temp (and gf (generic-function-name gf))
-	      name (if temp
-		       (intern-function-name
-			 (make-method-spec temp
-					   (method-qualifiers method)
-					   (unparse-specializers
-					     (method-specializers method))))
-		       (make-symbol (format nil "~S" method))))
-	(multiple-value-bind (gf-spec quals specls)
-	    (parse-defmethod spec)
-	  (and (setq gf (and (or errorp (gboundp gf-spec))
-			     (gdefinition gf-spec)))
-	       (let ((nreq (compute-discriminating-function-arglist-info gf)))
-		 (setq specls (append (parse-specializers specls)
-				      (make-list (- nreq (length specls))
-						 :initial-element
-						 *the-class-t*)))
-		 (and 
-		   (setq method (get-method gf quals specls errorp))
-		   (setq name
-			 (intern-function-name (make-method-spec gf-spec
-								 quals
-								 specls))))))))
-    (values gf method name)))
-
 
 
 (defun extract-parameters (specialized-lambda-list)
@@ -1459,150 +2099,145 @@ work during bootstrapping.
     required-parameters))
 
 (defun parse-specialized-lambda-list (arglist &optional post-keyword)
-  ;;(declare (values parameters lambda-list specializers required-parameters))
+  (declare (values parameters lambda-list specializers required-parameters))
   (let ((arg (car arglist)))
     (cond ((null arglist) (values nil nil nil nil))
-	  ((eq arg '&aux)
-	   (values nil arglist nil))
-	  ((memq arg lambda-list-keywords)
-	   (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
-	     ;; Warn about non-standard lambda-list-keywords, but then
-	     ;; go on to treat them like a standard lambda-list-keyword
-	     ;; what with the warning its probably ok.
-	     (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
+          ((eq arg '&aux)
+           (values nil arglist nil nil))
+          ((memq arg lambda-list-keywords)
+           (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
+             ;; Warn about non-standard lambda-list-keywords, but then
+             ;; go on to treat them like a standard lambda-list-keyword
+             ;; what with the warning its probably ok.
+             (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
                     Assuming that the symbols following it are parameters,~%~
                     and not allowing any parameter specializers to follow~%~
                     to follow it."
-		   arg))
-	   ;; When we are at a lambda-list-keyword, the parameters don't
-	   ;; include the lambda-list-keyword; the lambda-list does include
-	   ;; the lambda-list-keyword; and no specializers are allowed to
-	   ;; follow the lambda-list-keywords (at least for now).
-	   (multiple-value-bind (parameters lambda-list)
-	       (parse-specialized-lambda-list (cdr arglist) t)
-	     (values parameters
-		     (cons arg lambda-list)
-		     ()
-		     ())))
-	  (post-keyword
-	   ;; After a lambda-list-keyword there can be no specializers.
-	   (multiple-value-bind (parameters lambda-list)
-	       (parse-specialized-lambda-list (cdr arglist) t)	       
-	     (values (cons (if (listp arg) (car arg) arg) parameters)
-		     (cons arg lambda-list)
-		     ()
-		     ())))
-	  (t
-	   (multiple-value-bind (parameters lambda-list specializers required)
-	       (parse-specialized-lambda-list (cdr arglist))
-	     (values (cons (if (listp arg) (car arg) arg) parameters)
-		     (cons (if (listp arg) (car arg) arg) lambda-list)
-		     (cons (if (listp arg) (cadr arg) 't) specializers)
-		     (cons (if (listp arg) (car arg) arg) required)))))))
+                   arg))
+           ;; When we are at a lambda-list-keyword, the parameters don't
+           ;; include the lambda-list-keyword; the lambda-list does include
+           ;; the lambda-list-keyword; and no specializers are allowed to
+           ;; follow the lambda-list-keywords (at least for now).
+           (multiple-value-bind (parameters lambda-list)
+               (parse-specialized-lambda-list (cdr arglist) t)
+             (declare (type list parameters lambda-list))
+             (values parameters
+                     (cons arg lambda-list)
+                     ()
+                     ())))
+          (post-keyword
+           ;; After a lambda-list-keyword there can be no specializers.
+           (multiple-value-bind (parameters lambda-list)
+               (parse-specialized-lambda-list (cdr arglist) t)         
+             (values (cons (if (listp arg) (car arg) arg) parameters)
+                     (cons arg lambda-list)
+                     ()
+                     ())))
+          (t
+           (multiple-value-bind (parameters lambda-list specializers required)
+               (parse-specialized-lambda-list (cdr arglist))
+             (values (cons (if (listp arg) (car arg) arg) parameters)
+                     (cons (if (listp arg) (car arg) arg) lambda-list)
+                     (cons (if (listp arg) (cadr arg) 't) specializers)
+                     (cons (if (listp arg) (car arg) arg) required)))))))
 
 
 (eval-when (load eval)
   (setq *boot-state* 'early))
 
 
-#-cmu ;; CMUCL Has a real symbol-macrolet
-(progn
+#-cmu
 (defmacro symbol-macrolet (bindings &body body &environment env)
   (let ((specs (mapcar #'(lambda (binding)
-			   (list (car binding)
-				 (variable-lexical-p (car binding) env)
-				 (cadr binding)))
-		       bindings)))
+                           (list (car binding)
+                                 (variable-lexical-p (car binding) env)
+                                 (cadr binding)))
+                       bindings)))
     (walk-form `(progn ,@body)
-	       env
-	       #'(lambda (f c e)
-		   (expand-symbol-macrolet-internal specs f c e)))))
+               env
+               #'(lambda (f c e)
+                   (expand-symbol-macrolet-internal specs f c e)))))
 
+#-cmu
 (defun expand-symbol-macrolet-internal (specs form context env)
   (let ((entry nil))
     (cond ((not (eq context :eval)) form)
-	  ((symbolp form)
-	   (if (and (setq entry (assoc form specs))
-		    (eq (cadr entry) (variable-lexical-p form env)))
-	       (caddr entry)
-	       form))
-	  ((not (listp form)) form)
-	  ((member (car form) '(setq setf))
-	   ;; Have to be careful.  We must only convert the form to a SETF
-	   ;; form when we convert one of the 'logical' variables to a form
-	   ;; Otherwise we will get looping in implementations where setf
-	   ;; is a macro which expands into setq.
-	   (let ((kind (car form)))
-	     (labels ((scan-setf (tail)
-			(if (null tail)
-			    nil
-			    (walker::relist*
-			      tail
-			      (if (and (setq entry (assoc (car tail) specs))
-				       (eq (cadr entry)
-					   (variable-lexical-p (car tail)
-							       env)))
-				  (progn (setq kind 'setf)
-					 (caddr entry))
-				  (car tail))
-			      (cadr tail)
-			      (scan-setf (cddr tail))))))
-	       (let (new-tail)
-		 (setq new-tail (scan-setf (cdr form)))
-		 (walker::recons form kind new-tail)))))
-	  ((eq (car form) 'multiple-value-setq)
-	   (let* ((vars (cadr form))
-		  (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym))
-				   vars)))
-	     `(multiple-value-bind ,gensyms 
-		  ,(caddr form)
-		.,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g))
-				   vars
-				   gensyms)))))
-	  (t form))))
-)
+          ((symbolp form)
+           (if (and (setq entry (assoc form specs))
+                    (eq (cadr entry) (variable-lexical-p form env)))
+               (caddr entry)
+               form))
+          ((not (listp form)) form)
+          ((member (car form) '(setq setf))
+           ;; Have to be careful.  We must only convert the form to a SETF
+           ;; form when we convert one of the 'logical' variables to a form
+           ;; Otherwise we will get looping in implementations where setf
+           ;; is a macro which expands into setq.
+           (let ((kind (car form)))
+             (labels ((scan-setf (tail)
+                        (if (null tail)
+                            nil
+                            (walker::relist*
+                              tail
+                              (if (and (setq entry (assoc (car tail) specs))
+                                       (eq (cadr entry)
+                                           (variable-lexical-p (car tail)
+                                                               env)))
+                                  (progn (setq kind 'setf)
+                                         (caddr entry))
+                                  (car tail))
+                              (cadr tail)
+                              (scan-setf (cddr tail))))))
+               (let (new-tail)
+                 (setq new-tail (scan-setf (cdr form)))
+                 (walker::recons form kind new-tail)))))
+          ((eq (car form) 'multiple-value-setq)
+           (let* ((vars (cadr form))
+                  (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym))
+                                   vars)))
+             `(multiple-value-bind ,gensyms 
+                  ,(caddr form)
+                .,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g))
+                                   vars
+                                   gensyms)))))
+          (t form))))
 
 (defmacro with-slots (slots instance &body body)
   (let ((in (gensym)))
     `(let ((,in ,instance))
-       #+cmu (declare (ignorable ,in))
-       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
-                             (third instance)
-                             instance)))
-	   (and (symbolp instance)
+       #+cmu (declare (ext::ignorable ,in))
+       ,@(let ((instance (un-the instance)))
+           (and (symbolp instance)
                 `((declare (variable-rebinding ,in ,instance)))))
        ,in
        (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
-				     (let ((variable-name 
-					    (if (symbolp slot-entry)
-						slot-entry
-						(car slot-entry)))
-					   (slot-name
-					    (if (symbolp slot-entry)
-						slot-entry
-						(cadr slot-entry))))
-				       `(,variable-name
-					  (slot-value ,in ',slot-name))))
-				 slots)
-			,@body))))
+                                     (let ((variable-name 
+                                            (if (symbolp slot-entry)
+                                                slot-entry
+                                                (car slot-entry)))
+                                           (slot-name
+                                            (if (symbolp slot-entry)
+                                                slot-entry
+                                                (cadr slot-entry))))
+                                       `(,variable-name
+                                          (slot-value ,in ',slot-name))))
+                                 slots)
+                        ,@body))))
 
 (defmacro with-accessors (slots instance &body body)
   (let ((in (gensym)))
     `(let ((,in ,instance))
-       #+cmu (declare (ignorable ,in))
-       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
-                             (third instance)
-                             instance)))
-	   (and (symbolp instance)
+       #+cmu (declare (ext::ignorable ,in))
+       ,@(let ((instance (un-the instance)))
+           (and (symbolp instance)
                 `((declare (variable-rebinding ,in ,instance)))))
        ,in
        (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
-				   (let ((variable-name (car slot-entry))
-					 (accessor-name (cadr slot-entry)))
-				     `(,variable-name
-				        (,accessor-name ,in))))
-			       slots)
+                                   (let ((variable-name (car slot-entry))
+                                         (accessor-name (cadr slot-entry)))
+                                     `(,variable-name
+                                        (,accessor-name ,in))))
+                               slots)
           ,@body))))
 
 
-
diff --git a/pcl/braid.lisp b/pcl/braid.lisp
index 246dc9015..5fcc5d00a 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -44,7 +44,7 @@
   (getf canonical-slot :name))
 
 (defun early-collect-inheritance (class-name)
-  ;;(declare (values slots cpl default-initargs direct-subclasses))
+  (declare (values slots cpl default-initargs direct-subclasses))
   (let ((cpl (early-collect-cpl class-name)))
     (values (early-collect-slots cpl)
 	    cpl
@@ -125,11 +125,12 @@
 	     (push a *early-class-slots*)
 	     a))))
 
-(defun early-class-size (class-name)
-  (length (early-class-slots class-name)))
+(defun early-class-original-static-slot-storage-copy (class-name)
+  (%allocate-origional-static-slot-storage-copy
+    (length (the list (early-class-slots class-name)))))
 
 (defun bootstrap-slot-index (class-name slot-name)
-  (or (position slot-name (early-class-slots class-name))
+  (or (posq slot-name (the list (early-class-slots class-name)))
       (error "~S not found" slot-name)))
 
 
@@ -139,17 +140,21 @@
 ;;; This function builds the base metabraid from the early class definitions.
 ;;;   
 (defun bootstrap-meta-braid ()
-  (let* ((slot-class-size      (early-class-size 'slot-class))
-	 (standard-class-size  (early-class-size 'standard-class))
-	 (built-in-class-size  (early-class-size 'built-in-class))
-	 (structure-class-size (early-class-size 'structure-class))
-         (slot-class      (%allocate-instance--class standard-class-size))
-         (standard-class  (%allocate-instance--class standard-class-size))
-         (built-in-class  (%allocate-instance--class standard-class-size))
-         (structure-class (%allocate-instance--class standard-class-size))
-	 (direct-slotd    (%allocate-instance--class standard-class-size))
-	 (effective-slotd (%allocate-instance--class standard-class-size))
-	 (class-eq        (%allocate-instance--class standard-class-size))
+  (let* ((slot-class-original-slot-copy
+           (early-class-original-static-slot-storage-copy 'slot-class))
+	 (standard-class-original-slot-copy
+           (early-class-original-static-slot-storage-copy 'standard-class))
+	 (built-in-class-original-slot-copy
+           (early-class-original-static-slot-storage-copy 'built-in-class))
+	 (structure-class-original-slot-copy
+           (early-class-original-static-slot-storage-copy 'structure-class))
+         (slot-class      (%allocate-instance--class standard-class-original-slot-copy))
+         (standard-class  (%allocate-instance--class standard-class-original-slot-copy))
+         (built-in-class  (%allocate-instance--class standard-class-original-slot-copy))
+         (structure-class (%allocate-instance--class standard-class-original-slot-copy))
+	 (direct-slotd    (%allocate-instance--class standard-class-original-slot-copy))
+	 (effective-slotd (%allocate-instance--class standard-class-original-slot-copy))
+	 (class-eq        (%allocate-instance--class standard-class-original-slot-copy))
 	 (slot-class-wrapper      (make-wrapper slot-class))
 	 (standard-class-wrapper  (make-wrapper standard-class))
 	 (built-in-class-wrapper  (make-wrapper built-in-class))
@@ -165,11 +170,12 @@
     (dolist (definition *early-class-definitions*)
       (let* ((name (ecd-class-name definition))
 	     (meta (ecd-metaclass definition))
-	     (size (ecase meta
-		     (slot-class slot-class-size)
-		     (standard-class standard-class-size)
-		     (built-in-class built-in-class-size)
-		     (structure-class structure-class-size)))
+	     (original-slot-copy
+               (ecase meta
+		 (slot-class slot-class-original-slot-copy)
+		 (standard-class standard-class-original-slot-copy)
+		 (built-in-class built-in-class-original-slot-copy)
+		 (structure-class structure-class-original-slot-copy)))
              (class (case name
 		      (slot-class                         slot-class)
                       (standard-class                     standard-class)
@@ -178,7 +184,7 @@
 		      (built-in-class                     built-in-class)
 		      (structure-class                    structure-class)
 		      (class-eq-specializer               class-eq)
-                      (otherwise (%allocate-instance--class size)))))
+                      (otherwise (%allocate-instance--class original-slot-copy)))))
 	(when (eq meta 'standard-class)
 	  (inform-type-system-about-class class name))
 	(setf (std-instance-wrapper class)
@@ -202,6 +208,7 @@
 		(getf other-initargs :default-initargs)))
 	  (multiple-value-bind (slots cpl default-initargs direct-subclasses)
 	      (early-collect-inheritance name)
+            (declare (type list slots cpl default-initargs direct-subclasses))
 	    (let* ((class (find-class name))
 		   (wrapper
 		     (cond
@@ -213,7 +220,12 @@
 		       ((eq class structure-class) structure-class-wrapper)
 		       ((eq class class-eq)        class-eq-wrapper)
 		       (t (make-wrapper class))))
-		   (proto nil))
+		   (proto nil)
+                   (slot-names
+		    (mapcar #'canonical-slot-name slots))
+                   (static-slot-copy
+                    (%allocate-origional-static-slot-storage-copy (length slot-names))))
+              (declare (type list slot-names))
 	      (cond ((eq name 't)
 		     (setq *the-wrapper-of-t* wrapper
 			   *the-class-t* class))
@@ -225,6 +237,7 @@
 				  standard-class
 				  funcallable-standard-class
 				  structure-class
+				  standard-direct-slot-definition
 				  standard-effective-slot-definition))
 		     (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
 				  *the-pcl-package*)
@@ -233,12 +246,13 @@
 		(unless (eq (getf slot :allocation :instance) :instance)
 		  (error "Slot allocation ~S not supported in bootstrap.")))
 	      
-	      (setf (wrapper-instance-slots-layout wrapper)
-		    (mapcar #'canonical-slot-name slots))
+	      (setf (wrapper-instance-slots-layout wrapper) slot-names)
+	      (setf (wrapper-allocate-static-slot-storage-copy wrapper)
+                    static-slot-copy)
 	      (setf (wrapper-class-slots wrapper)
 		    ())
 	      
-	      (setq proto (%allocate-instance--class (length slots)))
+	      (setq proto (%allocate-instance--class static-slot-copy))
 	      (setf (std-instance-wrapper proto) wrapper)
 	    
 	      (setq direct-slots
@@ -253,20 +267,23 @@
 		 (bootstrap-initialize-standard-class
 		  class name class-eq-wrapper source
 		  direct-supers direct-subclasses cpl wrapper
-		  direct-slots slots direct-default-initargs default-initargs
-		  proto))
+		  direct-slots slots direct-default-initargs
+		  default-initargs proto))
 		(built-in-class ; *the-class-t*
 		 (bootstrap-initialize-built-in-class
 		  class name class-eq-wrapper source
 		  direct-supers direct-subclasses cpl wrapper
-		  proto))
+		  proto nil))
 		(slot-class ; *the-class-slot-object*
 		 (bootstrap-initialize-built-in-class
 		  class name class-eq-wrapper source
 		  direct-supers direct-subclasses cpl wrapper
-		  proto)
+		  proto nil)
 		 (bootstrap-set-slot 'slot-class class 'direct-slots nil)
-		 (bootstrap-set-slot 'slot-class class 'slots nil))
+		 (bootstrap-set-slot 'slot-class class 'slots nil)
+		 (bootstrap-set-slot 'slot-class class 'internal-slotds nil)
+		 (bootstrap-set-slot 'slot-class class
+                                     'side-effect-internal-slotds nil))
 		(structure-class ; *the-class-structure-object*
 		 (bootstrap-initialize-structure-class
 		  class name class-eq-wrapper source
@@ -282,30 +299,47 @@
 
 (defun bootstrap-accessor-definitions (class-name slot-name readers writers)
   (flet ((do-reader-definition (reader)
-	   (add-method
-	     (ensure-generic-function reader)
-	     (make-a-method
-	       'standard-reader-method
-	       ()
-	       (list class-name)
-	       (list class-name)
-	       (make-internal-reader-method-function slot-name)
-	       "automatically generated reader method"
-	       slot-name)))
-	 (do-writer-definition (writer)
-	   (add-method
-	     (ensure-generic-function writer)
-	     (make-a-method
-	       'standard-writer-method
-	       ()
-	       (list 'new-value class-name)
-	       (list 't class-name)
-	       (make-std-writer-method-function slot-name)
-	       "automatically generated writer method"
-	       slot-name))))
+           (let ((optimized-method-function
+                   (make-std-reader-method-function slot-name))
+                 (generic-function
+                   (ensure-generic-function reader)))
+             (add-method
+               generic-function
+               (make-a-method
+                 'standard-reader-method
+                 ()
+                 (list class-name)
+                 (list class-name)
+                 (when (call-store-method-function-p generic-function nil nil)
+                   (make-documented-std-reader-method-function slot-name))
+                 optimized-method-function
+                 NIL
+                 "automatically generated reader method"
+                 slot-name
+                 `(:needs-next-methods-p NIL)))))
+         (do-writer-definition (writer)
+           (let ((optimized-method-function
+                   (make-std-writer-method-function slot-name))
+                 (generic-function
+                   (ensure-generic-function writer)))
+             (add-method
+               generic-function
+               (make-a-method
+                 'standard-writer-method
+                 ()
+                 (list 'new-value class-name)
+                 (list 't class-name)
+                 (when (call-store-method-function-p generic-function nil nil)
+                   (make-documented-std-writer-method-function slot-name))
+                 optimized-method-function
+                 NIL
+                 "automatically generated writer method"
+                 slot-name
+                 `(:needs-next-methods-p NIL))))))
     (dolist (reader readers) (do-reader-definition reader))
     (dolist (writer writers) (do-writer-definition writer))))
 
+
 ;;;
 ;;; Initialize a standard class metaobject.
 ;;;
@@ -313,80 +347,114 @@
        (class
 	name class-eq-wrapper definition-source direct-supers direct-subclasses cpl
 	wrapper direct-slots slots direct-default-initargs default-initargs proto)
+  (declare (type list direct-slots slots))
   (flet ((classes (names) (mapcar #'find-class names))
 	 (set-slot (slot-name value)
 	   (bootstrap-set-slot 'standard-class class slot-name value)))
+    (let ((class-precedence-list (classes cpl)))
     
-    (set-slot 'name name)
-    (set-slot 'source definition-source)
-    (set-slot 'type `(class ,class))
-    (set-slot 'class-eq-specializer 
-	      (let* ((spec-size (early-class-size 'class-eq-specializer))
-		     (spec (%allocate-instance--class spec-size)))
-		(setf (std-instance-wrapper spec) class-eq-wrapper)
-		(bootstrap-set-slot 'class-eq-specializer spec 'type 
-				    `(class-eq ,class))
-		(bootstrap-set-slot 'class-eq-specializer spec 'object
-				    class)
-		spec))
-    (set-slot 'class-precedence-list (classes cpl))
-    (set-slot 'can-precede-list (classes (cdr cpl)))
-    (set-slot 'incompatible-superclass-list nil)
-    (set-slot 'direct-superclasses (classes direct-supers))
-    (set-slot 'direct-subclasses (classes direct-subclasses))
-    (set-slot 'direct-methods (cons nil nil))
-    (set-slot 'wrapper wrapper)
-    (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
-				  (make-class-predicate-name name)))
-    (set-slot 'plist
-	      `(,@(and direct-default-initargs
-		       `(direct-default-initargs ,direct-default-initargs))
-		,@(and default-initargs
-		       `(default-initargs ,default-initargs))))
-
-    (set-slot 'direct-slots direct-slots)
-    (set-slot 'no-of-instance-slots (length slots))
-    (set-slot 'slots slots)
-    (set-slot 'prototype proto)
-    ))
+      (set-slot 'default-initargs default-initargs)
+      (set-slot 'direct-slots direct-slots)
+      (set-slot 'direct-default-initargs direct-default-initargs)
+      (set-slot 'direct-subclasses (classes direct-subclasses))
+      (set-slot 'direct-superclasses (classes direct-supers))
+      (set-slot 'finalized-p T)
+      (set-slot 'name name)
+      (set-slot 'class-precedence-list class-precedence-list)
+      (set-slot 'prototype proto)
+      (set-slot 'slots slots)
+
+      (set-slot 'cached-in-generic-functions ())
+      (set-slot 'can-precede-list (classes (cdr cpl)))
+      (set-slot 'class-eq-specializer 
+	        (let ((spec (%allocate-instance--class
+                              (early-class-original-static-slot-storage-copy
+                                'class-eq-specializer))))
+		  (setf (std-instance-wrapper spec) class-eq-wrapper)
+		  (bootstrap-set-slot 'class-eq-specializer spec 'type 
+				      `(class-eq ,class))
+		  (bootstrap-set-slot 'class-eq-specializer spec 'object
+				      class)
+		  spec))
+      (set-slot 'direct-methods (cons nil nil))
+      (set-slot 'incompatible-superclass-list nil)
+      (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
+				    (make-class-predicate-name name)))
+      (set-slot 'wrapper wrapper)
+
+      (set-slot 'plist nil)
+      (set-slot 'source definition-source)
+      (set-slot 'type `(class ,class))
+      (set-slot 'documentation NIL)
+
+      (let ((internal-slotds ())
+            (side-effect-internal-slotds ()))
+        (dolist (slot slots)
+          (let ((internal-slotd
+                  (bootstrap-get-slot 'standard-effective-slot-definition
+                                      slot 'internal-slotd)))
+            (push internal-slotd internal-slotds)
+            (unless (bootstrap-get-slot 'standard-effective-slot-definition
+                                        slot
+                                        'initfunction-side-effect-free-p)
+              (push internal-slotd side-effect-internal-slotds))))
+        (set-slot 'internal-slotds (nreverse internal-slotds))
+        (set-slot 'side-effect-internal-slotds
+                  (nreverse side-effect-internal-slotds)))
+      (setf (wrapper-allocate-static-slot-storage-copy wrapper)
+            (%allocate-origional-static-slot-storage-copy (length slots)))
+    )))
 
 ;;;
 ;;; Initialize a built-in-class metaobject.
 ;;;
 (defun bootstrap-initialize-built-in-class
        (class name class-eq-wrapper source direct-supers direct-subclasses cpl 
-	wrapper proto)
+	wrapper proto predicate-name)
   (flet ((classes (names) (mapcar #'find-class names))
 	 (set-slot (slot-name value)
 	   (bootstrap-set-slot 'built-in-class class slot-name value)))
+
+    (set-slot 'default-initargs ())
+    (set-slot 'direct-default-initargs ())
+    (set-slot 'direct-slots ())
+    (set-slot 'direct-subclasses (classes direct-subclasses))
+    (set-slot 'direct-superclasses (classes direct-supers))
     (set-slot 'name name)
+    (set-slot 'finalized-p T)
+    (set-slot 'class-precedence-list (classes cpl))
+    (set-slot 'prototype
+              (or proto
+		  (let* ((proto (%allocate-instance--class *empty-vector*)))
+		           (setf (std-instance-wrapper proto) wrapper)
+		           proto)))
+    (set-slot 'slots ())
+
     (set-slot 'source source)
     (set-slot 'type (if (eq class (find-class 't))
 			t
 			`(class ,class)))
     (set-slot 'class-eq-specializer 
-	       (let* ((spec-size (early-class-size 'class-eq-specializer))
-		      (spec (%allocate-instance--class spec-size)))
+	       (let ((spec (%allocate-instance--class
+                             (early-class-original-static-slot-storage-copy
+                                'class-eq-specializer))))
 		 (setf (std-instance-wrapper spec) class-eq-wrapper)
 		 (bootstrap-set-slot 'class-eq-specializer spec 'type 
 				     `(class-eq ,class))
 		 (bootstrap-set-slot 'class-eq-specializer spec 'object 
 				     class)
 		 spec))
-    (set-slot 'direct-superclasses (classes direct-supers))
-    (set-slot 'direct-subclasses (classes direct-subclasses))
+
     (set-slot 'direct-methods (cons nil nil))
-    (set-slot 'class-precedence-list (classes cpl))
     (set-slot 'can-precede-list (classes (cdr cpl)))
     (set-slot 'incompatible-superclass-list nil)
+    (set-slot 'internal-slotds nil)
     (set-slot 'wrapper wrapper)
     (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
+				  predicate-name
 				  (make-class-predicate-name name)))
     (set-slot 'plist nil)
-    (set-slot 'prototype (or proto
-			     (let* ((proto (%allocate-instance--class 0)))
-			       (setf (std-instance-wrapper proto) wrapper)
-			       proto)))))
+    (set-slot 'documentation (format nil "Built-in-class ~S" name))))
 
 (defun bootstrap-initialize-structure-class
     (class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper)
@@ -395,38 +463,47 @@
 	 (set-slot (slot-name value)
 	   (bootstrap-set-slot 'structure-class class slot-name value)))
     (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
+
+      (set-slot 'default-initargs nil)
+      (set-slot 'direct-default-initargs nil)
+      (set-slot 'direct-slots nil)
+      (set-slot 'direct-subclasses (classes direct-subclasses))
+      (set-slot 'direct-superclasses (classes direct-supers))
+      (set-slot 'finalized-p T)
       (set-slot 'name name)
+      (set-slot 'class-precedence-list (classes cpl))
+      (set-slot 'prototype (funcall (symbol-function constructor-sym)))
+      (set-slot 'slots nil)
+
       (set-slot 'source source)
       (set-slot 'type `(class ,class))
       (set-slot 'class-eq-specializer 
-		(let* ((spec-size (early-class-size 'class-eq-specializer))
-		       (spec (%allocate-instance--class spec-size)))
+		(let ((spec (%allocate-instance--class
+                              (early-class-original-static-slot-storage-copy
+                                 'class-eq-specializer))))
 		  (setf (std-instance-wrapper spec) class-eq-wrapper)
 		  (bootstrap-set-slot 'class-eq-specializer spec 'type 
 				      `(class-eq ,class))
 		  (bootstrap-set-slot 'class-eq-specializer spec 'object
 				      class)
 		  spec))
-      (set-slot 'direct-superclasses (classes direct-supers))
-      (set-slot 'direct-subclasses (classes direct-subclasses))
       (set-slot 'direct-methods (cons nil nil))
-      (set-slot 'class-precedence-list (classes cpl))
       (set-slot 'can-precede-list (classes (cdr cpl)))
       (set-slot 'incompatible-superclass-list nil)
       (set-slot 'wrapper wrapper)
-      (set-slot 'direct-slots nil)
       (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
 				    (make-class-predicate-name name)))
-      (set-slot 'slots nil)
-      (set-slot 'defstruct-form 
-		`(defstruct (structure-object (:constructor ,constructor-sym))))
+      (set-slot 'internal-slotds nil)
+      (set-slot 'side-effect-internal-slotds nil)
+      (set-slot 'defstruct-conc-name "|STRUCTURE-OBJECT class ")
       (set-slot 'defstruct-constructor constructor-sym)
       (set-slot 'from-defclass-p t)    
       (set-slot 'plist nil)
-      (set-slot 'prototype (funcall constructor-sym)))))
+      (set-slot 'documentation NIL))))
 
 (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
   (let ((index -1))
+    (declare (type fixnum index))
     (mapcar #'(lambda (slot)
 		(incf index)
 		(bootstrap-make-slot-definition
@@ -436,41 +513,57 @@
 (defvar *early-slot-names* (make-hash-table :test 'eq))
 
 (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index)  
+  (declare (ignore name))
   (let* ((slotd-class-name (if effective-p
 			       'standard-effective-slot-definition
 			       'standard-direct-slot-definition))
-	 (slotd (%allocate-instance--class (early-class-size slotd-class-name)))
+	 (slotd (%allocate-instance--class
+                  (early-class-original-static-slot-storage-copy slotd-class-name)))
 	 (slot-name (getf slot :name)))
     (setf (std-instance-wrapper slotd) wrapper)
     (flet ((get-val (name) (getf slot name))
 	   (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val)))
-      (set-val 'name         slot-name)
-      (set-val 'initform     (get-val :initform))
-      (set-val 'initfunction (get-val :initfunction))      
-      (set-val 'initargs     (get-val :initargs))
-      (set-val 'readers      (get-val :readers))
-      (set-val 'writers      (get-val :writers))
-      (set-val 'allocation   :instance)
-      (set-val 'type         (or (get-val :type) t))
-      (set-val 'documentation (or (get-val :documentation) ""))
-      (set-val 'class        class)
-      (when effective-p
-	(set-val 'location index)
-	(let ((fsc-p nil))
-	  (set-val 'reader-function (make-optimized-std-reader-method-function 
-				     fsc-p slot-name index))
-	  (set-val 'writer-function (make-optimized-std-writer-method-function 
-				     fsc-p slot-name index))
-	  (set-val 'boundp-function (make-optimized-std-boundp-method-function 
-				     fsc-p slot-name index)))
-	(set-val 'accessor-flags 7)
-	(push (cons class slotd) (gethash slot-name *early-slot-names*)))
-      (when (and (eq name 'standard-class)
-		 (eq slot-name 'slots) effective-p)
-	(setq *the-eslotd-standard-class-slots* slotd))
-      (when (and (eq name 'funcallable-standard-class)
-		 (eq slot-name 'slots) effective-p)
-	(setq *the-eslotd-funcallable-standard-class-slots* slotd))
+      (let ((initfunction (get-val :initfunction))
+            (initargs     (get-val :initargs)))
+        (set-val 'name         slot-name)
+        (set-val 'initform     (get-val :initform))
+        (set-val 'initfunction initfunction)
+        (set-val 'initargs     initargs)
+        (set-val 'readers      (get-val :readers))
+        (set-val 'writers      (get-val :writers))
+        (set-val 'allocation   :instance)
+        (set-val 'type         (get-val :type))
+        (set-val 'class        class)
+        (set-val 'documentation (get-val :documentation))
+        (set-val 'initfunction-side-effect-free-p
+                 (get-val :initfunction-side-effect-free-p))
+        (when effective-p
+	  (set-val 'location index)
+	  (let* ((instance-type 'std-instance)
+                 (reader-function
+                   (make-optimized-std-reader-method-function 
+	             instance-type slot-name index))
+                 (writer-function
+                   (make-optimized-std-writer-method-function 
+	             instance-type slot-name index))
+                 (boundp-function
+                   (make-optimized-std-boundp-method-function 
+	             instance-type slot-name index)))
+	    (set-val 'reader-function reader-function)
+	    (set-val 'writer-function writer-function)
+	    (set-val 'boundp-function boundp-function)
+	    (set-val 'accessor-flags 7)
+            (let ((internal-slotd
+                    (make-internal-slotd :name            slot-name
+                                         :slot-definition slotd
+                                         :location        index
+                                         :initargs        initargs
+                                         :initfunction    initfunction
+                                         :reader-function reader-function
+                                         :writer-function writer-function
+                                         :boundp-function boundp-function)))
+              (set-val 'internal-slotd internal-slotd)))
+	    (push (cons class slotd) (gethash slot-name *early-slot-names*))))
       slotd)))
 
 (defun early-initialize-slot-gfs ()
@@ -479,8 +572,13 @@
 				(setf (gethash name *name->class->slotd-table*)
 				      (make-hash-table :test 'eq :size 5)))))
 		 (dolist (c+s class+slotd-list)
-		   (setf (gethash (car c+s) table) (cdr c+s))))
-	       (initialize-internal-slot-gfs name))
+		   (setf (gethash (car c+s) table) (cdr c+s)))
+                 (unless *safe-to-use-slot-value-wrapper-optimizations-p*
+                   (initialize-internal-slot-reader-gfs name))
+                 (unless *safe-to-use-set-slot-value-wrapper-optimizations-p*
+                   (initialize-internal-slot-writer-gfs name))
+                 (unless *safe-to-use-slot-boundp-wrapper-optimizations-p*
+                   (initialize-internal-slot-boundp-gfs name))))
 	   *early-slot-names*)
   (clrhash *early-slot-names*))
 
@@ -489,12 +587,15 @@
     (let* ((name (ecd-class-name definition))
 	   (class (find-class name)))
       (setf (find-class-predicate name)
-	    (make-class-predicate class (class-predicate-name class)))))
+	    (make-class-predicate class))))
   (dolist (e *built-in-classes*)
     (let* ((name (car e))
-	   (class (find-class name)))
+	   (class (find-class name))
+	   (predicate-name (class-predicate-name class)))
       (setf (find-class-predicate name)
-	    (make-class-predicate class (class-predicate-name class))))))
+	    (if (fboundp predicate-name)
+		(symbol-function predicate-name)
+		(make-class-predicate class))))))
 
 (defun bootstrap-built-in-classes ()
   ;;
@@ -516,9 +617,10 @@
   ;;
   (let* ((built-in-class (find-class 'built-in-class))
 	 (built-in-class-wrapper (class-wrapper built-in-class))
-	 (built-in-class-size (early-class-size 'built-in-class)))
+	 (built-in-class-original-slot-copy
+           (early-class-original-static-slot-storage-copy 'built-in-class)))
     (dolist (e *built-in-classes*)
-      (let ((class (%allocate-instance--class built-in-class-size)))
+      (let ((class (%allocate-instance--class built-in-class-original-slot-copy)))
 	(setf (std-instance-wrapper class) built-in-class-wrapper)
 	(setf (find-class (car e)) class))))
 
@@ -527,116 +629,98 @@
   ;;
   (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
     (dolist (e *built-in-classes*)
-      (destructuring-bind (name supers subs cpl prototype) e
+      (destructuring-bind (name supers subs cpl prototype predicate-name) e
 	(let* ((class (find-class name))
 	       (wrapper (make-wrapper class)))
 	  (set (get-built-in-class-symbol name) class)
 	  (set (get-built-in-wrapper-symbol name) wrapper)
 
 	  (setf (wrapper-instance-slots-layout wrapper) ()
-		(wrapper-class-slots wrapper) ())
+	        (wrapper-class-slots wrapper) ()
+                (wrapper-allocate-static-slot-storage-copy wrapper) *empty-vector*)
 
 	  (bootstrap-initialize-built-in-class class
 					  name class-eq-wrapper nil
 					  supers subs
 					  (cons name cpl)
-					  wrapper prototype))))))
+					  wrapper prototype predicate-name))))))
 
 
 ;;;
 ;;;
 ;;;
 
-(defvar *built-in-or-structure-wrapper-table*
-  (make-hash-table :test 'eq))
-
-(defvar wft-type1 nil)
-(defvar wft-wrapper1 nil)
-(defvar wft-type2 nil)
-(defvar wft-wrapper2 nil)
-
-(defun wrapper-for-structure (x)
-  (let ((type (structure-type x)))
-    (when (symbolp type)
-      (cond ((eq type 'std-instance) 
-	     (return-from wrapper-for-structure (std-instance-wrapper x)))
-	    ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1))
-	    ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2))
-	    (t (setq wft-type2 wft-type1  wft-wrapper2 wft-wrapper1))))
-    (let* ((cell (find-class-cell type))
-	   (class (or (find-class-cell-class cell)
-		      (let* (#+lucid 
-			     (*structure-type* type)
-			     #+lucid
-			     (*structure-length* (structure-length x type)))
-			(find-class-from-cell type cell))))
-	   (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
-      (when (symbolp type)
-	(setq wft-type1 type  wft-wrapper1 wrapper))
-      wrapper)))
-
-(defun built-in-or-structure-wrapper1 (x)
-  (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*)))
-    (or (and (eq biw *the-wrapper-of-t*)
-	     (structurep x)
-	     (let* ((type (type-of x))
-		    #+lucid 
-		    (*structure-type* type)
-		    #+lucid
-		    (*structure-length* (structure-length x type))
-		    (class (find-class type nil)))
-	       (and class (class-wrapper class))))
-	biw)))
-
-#|| ; moved to low.lisp
-(defmacro built-in-or-structure-wrapper (x)
-  (once-only (x)
-    (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
-	`(if (structurep ,x)
-	     (wrapper-for-structure ,x)
-	     (if (symbolp ,x)
-		 (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
-		 (built-in-wrapper-of ,x)))
-	`(or (and (symbolp ,x)
-		  (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*))
-	     (built-in-or-structure-wrapper1 ,x)))))
-||#
-
-(defun class-of (x) (wrapper-class (wrapper-of x)))
-
 (defun wrapper-of (x) 
-  (or (and (std-instance-p x)
-	   (std-instance-wrapper x))
-      (and (fsc-instance-p x)
-	   (fsc-instance-wrapper x))
-      (built-in-or-structure-wrapper x)))
+  (fast-wrapper-of x))
+
+(defun class-of (x) (wrapper-class (fast-wrapper-of x)))
 
 (defun structure-wrapper (x)
   (class-wrapper (find-class (structure-type x))))
 
 (defvar find-structure-class nil)
 
-(defun find-structure-class (symbol)
-  (if (structure-type-p symbol)
-      (unless (eq find-structure-class symbol)
-	(let ((find-structure-class symbol))
-	  (ensure-class symbol
-			:metaclass 'structure-class
-			:name symbol
-			:direct-superclasses
-			(when (structure-type-included-type-name symbol)
-			  (list (structure-type-included-type-name symbol)))
-			:direct-slots
-			(mapcar #'(lambda (slotd)
-				    `(:name ,(structure-slotd-name slotd)
-				      :defstruct-accessor-symbol 
-				      ,(structure-slotd-accessor-symbol slotd)
-				      :internal-reader-function 
-				      ,(structure-slotd-reader-function slotd)
-				      :internal-writer-function 
-				      ,(structure-slotd-writer-function slotd)))
-				(structure-type-slot-description-list symbol)))))
-      (error "~S is not a legal structure class name." symbol)))
+(defun make-defclass-direct-slots-from-defstruct (structure-name)
+  ;; Make the slot descriptions for defclass for structure STRUCTURE-NAME.
+  ;;   If the structure was defined with PCL's redefined Defstruct macro,
+  ;; build them from its trapped source.
+  ;;   Otherwise hope that the lisp's low file redefined
+  ;; Structure-type-slot-description-list et al. to get the info about
+  ;; the structure from the lisp's internal record.  If not, then oh well...
+  (let* ((defstruct-form (defstruct-form structure-name))
+         (conc-name (defstruct-form-conc-name defstruct-form)))
+    (declare (type simple-string conc-name))
+    (if defstruct-form
+        (mapcar
+          #'(lambda (descrip)
+              (let* ((name
+                       (if (listp descrip) (car descrip) descrip))
+                     (accessor-symbol
+                      (intern
+                        (concatenate 'simple-string
+                                     conc-name (symbol-name name))
+                        (symbol-package structure-name))))
+                (if (listp descrip)
+                    `(:name ,name
+                      :initform ,(second descrip)
+                      ,@(when (memq :type descrip)
+                          `(:type ,(cadr (memq :type descrip))))
+                      :defstruct-accessor-symbol ,accessor-symbol)
+                    `(:name ,name
+                      :initform NIL
+                      :defstruct-accessor-symbol ,accessor-symbol))))
+          (cdr defstruct-form))
+        (if (known-structure-type-p structure-name)
+	    (mapcar #'(lambda (slotd)
+		        `(:name ,(structure-slotd-name slotd)
+		          :defstruct-accessor-symbol 
+		          ,(structure-slotd-accessor-symbol slotd)
+		          :internal-reader-function 
+		          ,(structure-slotd-reader-function slotd)
+		          :internal-writer-function 
+		          ,(structure-slotd-writer-function slotd)))
+		    (structure-type-slot-description-list structure-name))
+           NIL))))
+
+(defun find-structure-class (symbol &key warn)
+  (when warn
+    (if (safe-subtypep symbol 'structure)
+        (warn "Creating class for structure ~S even though don't know anything about it.~%Class will likely have incorrect slots and superclass information"
+              symbol)
+        (warn "Guessing that ~S is a structure-class, even though don't know anything about it.~%Class will likely have incorrect slots and superclass information."
+              symbol)))
+  (unless (eq find-structure-class symbol)
+    (let ((find-structure-class symbol))
+       (ensure-class-using-class
+           symbol
+           NIL
+	   :metaclass 'structure-class
+	   :name symbol
+	   :direct-superclasses
+	   (when (structure-type-included-type-name symbol)
+	     (list (structure-type-included-type-name symbol)))
+	   :direct-slots
+             (make-defclass-direct-slots-from-defstruct symbol)))))
 
 (eval-when (compile eval)
 
@@ -738,9 +822,9 @@
 ;;;
 (defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key)
   (declare (ignore slot-names))
-  (with-slots (allocation class)
-    slotd
-    (setq allocation (if (eq allocation :class) class allocation))))
+  (if (eq (slot-value slotd 'allocation) :class)
+      (setf (slot-value slotd 'allocation)
+            (slot-value slotd 'class))))
 
 (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names 
 				     &key (allocation :instance))
@@ -748,5 +832,7 @@
   (unless (eq allocation :instance)
     (error "structure slots must have :instance allocation")))
 
+
 (defmethod inform-type-system-about-class ((class structure-class) name)
-  nil)
+  (inform-type-system-about-std-class name))
+
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index 1bb89821d..e702439a1 100644
--- a/pcl/cache.lisp
+++ b/pcl/cache.lisp
@@ -73,7 +73,29 @@
 ;;; sizes, the space that would be wasted by reserving line 0 to hold the
 ;;; lock count is more significant.
 ;;;
-
+
+(declaim (ftype (function () index)
+		get-wrapper-cache-number))
+(declaim (ftype (function (T T T) (values index index index index))
+                compute-cache-parameters))
+(declaim (ftype (function (T T T) index)
+		compute-primary-cache-location
+		compute-primary-cache-location-from-location))
+(declaim (ftype (function (T) index)
+		cache-count))
+(declaim (ftype (function (T T T T) boolean)
+		fill-cache-p
+		fill-cache-from-cache-p))
+(declaim (ftype (function (T T &optional T) (values T boolean))
+		find-free-cache-line))
+(declaim (ftype (function (index) index)
+		compute-line-size
+		default-limit-fn
+		power-of-two-ceiling))
+(declaim (ftype (function (T) boolean)
+		free-cache-vector))
+
+
 ;;;
 ;;; Caches
 ;;;
@@ -100,26 +122,29 @@
   `(array-dimension (the simple-vector ,cache-vector) 0))
 
 (defun allocate-cache-vector (size)
+  (declare (type index size))
   (make-array size :adjustable nil))
 
 (defmacro cache-vector-lock-count (cache-vector)
   `(cache-vector-ref ,cache-vector 0))
 
 (defun flush-cache-vector-internal (cache-vector)
-  (without-interrupts  
+  (without-interrupts-simple
     (fill (the simple-vector cache-vector) nil)
     (setf (cache-vector-lock-count cache-vector) 0))
   cache-vector)
 
 (defmacro modify-cache (cache-vector &body body)
-  `(without-interrupts
+  `(without-interrupts-simple
      (multiple-value-prog1
        (progn ,@body)
        (let ((old-count (cache-vector-lock-count ,cache-vector)))
-	 (declare (fixnum old-count))
+	 (declare (type index old-count))
 	 (setf (cache-vector-lock-count ,cache-vector)
-	       (if (= old-count most-positive-fixnum)
-		   1 (the fixnum (1+ old-count))))))))
+               (the index
+	            (if (= old-count most-positive-fixnum)
+		        1
+                        (the index (1+ old-count)))))))))
 
 (deftype field-type ()
   '(integer 0    ;#.(position 'number wrapper-layout)
@@ -127,9 +152,9 @@
 
 (eval-when (compile load eval)
 (defun power-of-two-ceiling (x)
-  (declare (fixnum x))
+  (declare (type index x))
   ;;(expt 2 (ceiling (log x 2)))
-  (the fixnum (ash 1 (integer-length (1- x)))))
+  (the index (ash 1 (integer-length (1- x)))))
 
 (defconstant *nkeys-limit* 256)
 )
@@ -139,14 +164,14 @@
 	     (:constructor make-cache ())
 	     (:copier copy-cache-internal))
   (nkeys 1 :type (integer 1 #.*nkeys-limit*))
-  (valuep nil :type (member nil t))
-  (nlines 0 :type fixnum)
+  (valuep nil :type boolean)
+  (nlines 0 :type index)
   (field 0 :type field-type)
-  (limit-fn #'default-limit-fn :type function)
-  (mask 0 :type fixnum)
-  (size 0 :type fixnum)
+  (limit-fn #'default-limit-fn :type real-function)
+  (mask 0 :type index)
+  (size 0 :type index)
   (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*))))
-  (max-location 0 :type fixnum)
+  (max-location 0 :type index)
   (vector #() :type simple-vector)
   (overflow nil :type list))
 
@@ -172,18 +197,18 @@
 (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
 
 ;;;
-;;; Return a cache that has had flush-cache-vector-internal called on it.  This
+;;; Return a cache that has had flush-cache-internal called on it.  This
 ;;; returns a cache of exactly the size requested, it won't ever return a
 ;;; larger cache.
 ;;; 
 (defun get-cache-vector (size)
   (let ((entry (gethash size *free-cache-vectors*)))
-    (without-interrupts
+    (without-interrupts-simple
       (cond ((null entry)
 	     (setf (gethash size *free-cache-vectors*) (cons 0 nil))
 	     (get-cache-vector size))
 	    ((null (cdr entry))
-	     (incf (car entry))
+             (setf (car entry) (the fixnum (1+ (the fixnum (car entry)))))
 	     (flush-cache-vector-internal (allocate-cache-vector size)))
 	    (t
 	     (let ((cache (cdr entry)))
@@ -192,7 +217,7 @@
 
 (defun free-cache-vector (cache-vector)
   (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
-    (without-interrupts
+    (without-interrupts-simple
       (if (null entry)
 	  (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.")
 	  (let ((thread (cdr entry)))
@@ -218,6 +243,7 @@
 	     (allocated (car entry))
 	     (head (cdr entry))
 	     (free 0))
+        (declare (type index allocated free))
 	(loop (when (null head) (return t))
 	      (setq head (cache-vector-ref head 0))
 	      (incf free))
@@ -257,16 +283,16 @@
 (defconstant wrapper-cache-number-mask
 	     (1- (expt 2 wrapper-cache-number-length)))
 
-
 (defvar *get-wrapper-cache-number* (make-random-state))
 
 (defun get-wrapper-cache-number ()
   (let ((n 0))
-    (declare (fixnum n))
+    (declare (type index n))
     (loop
       (setq n
-	    (logand wrapper-cache-number-mask
-		    (random most-positive-fixnum *get-wrapper-cache-number*)))
+	    (logand (the index wrapper-cache-number-mask)
+		    (the index (random most-positive-fixnum
+                                       *get-wrapper-cache-number*))))
       (unless (zerop n) (return n)))))
 
 
@@ -300,8 +326,18 @@
 ;;; cache numbers on machines where the addressing modes make that a good
 ;;; idea.
 ;;; 
+;;; For May 92, the wrapper field UNRESERVED-FIELD, accessable by macro
+;;; WRAPPER-UNRESERVED-FIELD, has been created to allow a programmer to
+;;; store his own items in the wrapper if so desired.  (Since there is
+;;; only one wrapper per class, this could be added at minimal cost).
+;;; It would be nice for this kind of low level hook to be part of the
+;;; MOP.  -- TL.
+
+(defconstant *temporary-static-slot-storage-copy* (make-array 1))
+
 #-structure-wrapper
 (progn
+
 (eval-when (compile load eval)
 (defconstant wrapper-layout
 	     '(number
@@ -312,24 +348,34 @@
 	       number
 	       number
 	       number
+               wrapper-identifier
 	       state
 	       instance-slots-layout
 	       class-slots
-	       class))
+	       class
+               allocate-static-slot-storage-copy
+               unreserved-field))
+
+(defconstant wrapper-length (length wrapper-layout))
+
+(deftype wrapper () `(simple-vector 15)) ; #.(length wrapper-layout)
 )
 
 (eval-when (compile load eval)
 
+(declaim (ftype (function (T) index) wrapper-field))
 (defun wrapper-field (type)
   (posq type wrapper-layout))
 
+(declaim (ftype (function (index) (or index null)) next-wrapper-field))
 (defun next-wrapper-field (field-number)
+  (declare (type index field-number))
   (position (nth field-number wrapper-layout)
 	    wrapper-layout
 	    :start (1+ field-number)))
 
 (defmacro first-wrapper-cache-number-index ()
-  `(wrapper-field 'number))
+  `(the field-type (wrapper-field 'number)))
 
 (defmacro next-wrapper-cache-number-index (field-number)
   `(next-wrapper-field ,field-number))
@@ -342,37 +388,65 @@
 (defmacro cache-number-vector-ref (cnv n)
   `(svref ,cnv ,n))
 
+(defconstant *wrapper-identifier-symbol* (gensym "WRAPPER-IDENTIFIER"))
 
 (defmacro wrapper-ref (wrapper n)
-  `(svref ,wrapper ,n))
+  `(svref (the wrapper ,wrapper) (the index ,n)))
 
 (defun emit-wrapper-ref (wrapper-operand field-operand)
   (operand :iref wrapper-operand field-operand))
 
-	      
+
+(defmacro wrapper-p (x)
+  (once-only (x)
+    `(locally (declare #.*optimize-speed*)
+       (and (simple-vector-p ,x)
+            (= (the index (length (the simple-vector ,x)))
+               wrapper-length)
+            (eq (wrapper-ref ,x ,(wrapper-field 'wrapper-identifier))
+                *wrapper-identifier-symbol*)))))
+
 (defmacro wrapper-state (wrapper)
   `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
 
 (defmacro wrapper-instance-slots-layout (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
+  `(the list
+        (wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))))
 
 (defmacro wrapper-class-slots (wrapper)
-  `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots)))
+  `(the list
+        (wrapper-ref ,wrapper ,(wrapper-field 'class-slots))))
 
 (defmacro wrapper-class (wrapper)
   `(wrapper-ref ,wrapper ,(wrapper-field 'class)))
 
+(defmacro wrapper-allocate-static-slot-storage-copy (wrapper)
+  `(the simple-vector
+        (wrapper-ref ,wrapper ,(wrapper-field 'allocate-static-slot-storage-copy))))
+
+(defmacro wrapper-unreserved-field (wrapper)
+  "Field unreserved by PCL.  May be used by user programs."
+  `(wrapper-ref ,wrapper ,(wrapper-field 'unreserved-field)))
+
+
 (defmacro make-wrapper-internal ()
-  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
+  `(let ((wrapper (make-array ,(length (the list wrapper-layout)) :adjustable nil)))
+     (declare (type wrapper wrapper))
      ,@(gathering1 (collecting)
 	 (iterate ((i (interval :from 0))
 		   (desc (list-elements wrapper-layout)))
 	   (ecase desc
+             (wrapper-identifier
+              (gather1 `(setf (wrapper-ref wrapper ,i)
+                              *wrapper-identifier-symbol*)))
 	     (number
 	      (gather1 `(setf (wrapper-ref wrapper ,i)
-			      (get-wrapper-cache-number))))
-	     ((state instance-slots-layout class-slots class)))))
-     (setf (wrapper-state wrapper) 't)     
+			      (the index (get-wrapper-cache-number)))))
+             (allocate-static-slot-storage-copy
+              (gather1 `(setf (wrapper-ref wrapper ,i)
+                              *temporary-static-slot-storage-copy*)))
+	     ((state instance-slots-layout class-slots class unreserved-field)))))
+     (setf (wrapper-state wrapper) 't)
      wrapper))
 
 (defun make-wrapper (class)
@@ -380,7 +454,8 @@
     (setf (wrapper-class wrapper) class)
     wrapper))
 
-)
+) ;#-structure-wrapper
+
 
 ; In CMUCL we want to do type checking as early as possible; structures help this.
 #+structure-wrapper
@@ -400,8 +475,7 @@
 (progn
 
 (defun make-wrapper-cache-number-vector ()
-  (let ((cnv (make-array #.wrapper-cache-number-vector-length
-			 :element-type 'fixnum)))
+  (let ((cnv (make-array wrapper-cache-number-vector-length)))
     (dotimes (i #.wrapper-cache-number-vector-length)
       (setf (svref cnv i) (get-wrapper-cache-number)))
     cnv))
@@ -414,7 +488,13 @@
   (state t :type (or (member t) cons)) ; a cons whose car is one of: flush or obsolete
   (instance-slots-layout nil :type list)
   (class-slots nil :type list)
-  (class *the-class-t* :type class))
+  (class *the-class-t* :type class)
+  (allocate-static-slot-storage-copy *temporary-static-slot-storage-copy*
+                                     :type simple-vector)
+  (unreserved-field nil))
+
+#+akcl
+(si::freeze-defstruct 'cache)
 
 (defun print-wrapper (wrapper stream depth)
   (declare (ignore depth))
@@ -425,8 +505,8 @@
   0)
 
 (defmacro next-wrapper-cache-number-index (field-number)
-  `(and (< ,field-number #.(1- wrapper-cache-number-vector-length))
-        (1+ ,field-number)))
+  `(and (< (the index ,field-number) #.(1- wrapper-cache-number-vector-length))
+        (1+ (the index ,field-number))))
 
 (defmacro cache-number-vector-ref (cnv n)
   `(svref ,cnv ,n))
@@ -437,12 +517,66 @@
 (defun emit-cache-number-vector-ref (cnv-operand field-operand)
   (operand :iref cnv-operand field-operand))
 
-)
+) ;#+structure-wrapper
 
 (defmacro wrapper-cache-number-vector-ref (wrapper n)
   `(svref (wrapper-cache-number-vector ,wrapper) ,n))
 
 
+;;;
+;;;
+;;;
+
+(defvar *built-in-or-structure-wrapper-table*
+  (make-hash-table :test 'eq))
+
+(defvar wft-type1 nil)
+(defvar wft-wrapper1 nil)
+(defvar wft-type2 nil)
+(defvar wft-wrapper2 nil)
+
+(defun wrapper-for-structure (x)
+  (let ((type (structure-type x)))
+    (when (symbolp type)
+      (cond ((eq type wft-type1)
+             (return-from wrapper-for-structure wft-wrapper1))
+            ((eq type wft-type2)
+             (return-from wrapper-for-structure wft-wrapper2))
+            (t (setq wft-type2 wft-type1  wft-wrapper2 wft-wrapper1))))
+    (let* ((cell (find-class-cell type))
+           (class (or (find-class-cell-class cell)
+                      (let* (#+lucid
+                             (*structure-type* type)
+                             #+lucid
+                             (*structure-length* (structure-length x type)))
+                        (find-class-from-cell type cell))))
+           (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
+     (when (symbolp type)
+        (setq wft-type1 type  wft-wrapper1 wrapper))
+      wrapper)))
+
+(defmacro built-in-or-structure-wrapper (x)
+  (once-only (x)
+    `(if (structurep ,x)
+         (wrapper-for-structure ,x)
+         (if (symbolp ,x)
+	     (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
+	     (built-in-wrapper-of ,x)))))
+
+(defun built-in-or-structure-wrapper-fun (x)
+  (built-in-or-structure-wrapper x))
+
+(defmacro fast-wrapper-of (x)
+  (once-only (x)
+    `(or (and (std-instance-p ,x)
+	      (std-instance-wrapper ,x))
+         (and (fsc-instance-p ,x)
+	      (fsc-instance-wrapper ,x))
+         #+pcl-user-instances
+         (and (get-user-instance-p ,x)
+	      (get-user-instance-wrapper ,x))
+         (built-in-or-structure-wrapper ,x))))
+
 ;;;
 ;;; The wrapper cache machinery provides general mechanism for trapping on
 ;;; the next access to any instance of a given class.  This mechanism is
@@ -490,51 +624,42 @@
        (setf (gethash owrapper *previous-nwrappers*) ()
 	     (gethash nwrapper *previous-nwrappers*) new-previous)))))
 
+(defun wrapper-state-trap (wrapper object)
+  (let ((state (wrapper-state wrapper)))
+    (ecase (car state)
+      (flush
+        (flush-cache-trap wrapper (cadr state) object))
+      (obsolete
+        (obsolete-instance-trap wrapper (cadr state) object)))))
+
+(defmacro fast-check-wrapper-validity (object
+                                       &optional (wrapper-fn 'fast-wrapper-of))
+  (let ((owrapper (gensym "OWRAPPER")))
+    (once-only (object)
+      `(let ((,owrapper (,wrapper-fn ,object)))
+         (if (eq 't (wrapper-state ,owrapper))
+	     ,owrapper
+	     (wrapper-state-trap ,owrapper ,object))))))
+
 (defun check-wrapper-validity (instance)
-  (let* ((owrapper (wrapper-of instance))
-	 (state (wrapper-state owrapper)))
-    (if (eq state  't)
-	owrapper
-	(let ((nwrapper
-		(ecase (car state)
-		  (flush
-		    (flush-cache-trap owrapper (cadr state) instance))
-		  (obsolete
-		    (obsolete-instance-trap owrapper (cadr state) instance)))))
-	  ;;
-	  ;; This little bit of error checking is superfluous.  It only
-	  ;; checks to see whether the person who implemented the trap
-	  ;; handling screwed up.  Since that person is hacking internal
-	  ;; PCL code, and is not a user, this should be needless.  Also,
-	  ;; since this directly slows down instance update and generic
-	  ;; function cache refilling, feel free to take it out sometime
-	  ;; soon.
-	  ;; 
-	  (cond ((neq nwrapper (wrapper-of instance))
-		 (error "Wrapper returned from trap not wrapper of instance."))
-		((invalid-wrapper-p nwrapper)
-		 (error "Wrapper returned from trap invalid.")))
-	  nwrapper))))
-
-(defmacro check-wrapper-validity1 (object)
-  (let ((owrapper (gensym)))
-    `(let ((,owrapper (cond ((std-instance-p ,object)
-			     (std-instance-wrapper ,object))
-			    ((fsc-instance-p ,object)
-			     (fsc-instance-wrapper ,object))
-			    (t (wrapper-of ,object)))))
-       (if (eq 't (wrapper-state ,owrapper))
-	   ,owrapper
-	   (check-wrapper-validity ,object)))))
+  (fast-check-wrapper-validity instance wrapper-of))
+
+
 
 
 (defvar *free-caches* nil)
 
 (defun get-cache (nkeys valuep limit-fn nlines)
-  (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+  (declare (type index         nkeys)
+           (type boolean       valuep)
+           (type real-function limit-fn)
+           (type index         nlines))
+  (let ((cache (or (without-interrupts-simple (pop *free-caches*))
+                   (make-cache))))
     (declare (type cache cache))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
 	(compute-cache-parameters nkeys valuep nlines)
+      (declare (type index cache-mask actual-size line-size nlines))
       (setf (cache-nkeys cache) nkeys
 	    (cache-valuep cache) valuep
 	    (cache-nlines cache) nlines
@@ -543,25 +668,31 @@
 	    (cache-mask cache) cache-mask
 	    (cache-size cache) actual-size
 	    (cache-line-size cache) line-size
-	    (cache-max-location cache) (let ((line (1- nlines)))
-					 (if (= nkeys 1)
-					     (* line line-size)
-					     (1+ (* line line-size))))
+	    (cache-max-location cache)
+              (the index (let ((line (1- nlines)))
+                            (declare (type index line))
+			    (if (= nkeys 1)
+			        (the index (* line line-size))
+			        (the index (1+ (the index (* line line-size)))))))
 	    (cache-vector cache) (get-cache-vector actual-size)
 	    (cache-overflow cache) nil)
       cache)))
 
 (defun get-cache-from-cache (old-cache new-nlines 
 			     &optional (new-field (first-wrapper-cache-number-index)))
+  (declare (type index new-nlines) (type field-type new-field))
   (let ((nkeys (cache-nkeys old-cache))
 	(valuep (cache-valuep old-cache))
-	(cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
-    (declare (type cache cache))
+	(cache (or (without-interrupts-simple (pop *free-caches*))
+                   (make-cache))))
+    (declare (type cache cache) (type index nkeys)
+             (type boolean valuep))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
 	(if (= new-nlines (cache-nlines old-cache))
 	    (values (cache-mask old-cache) (cache-size old-cache) 
 		    (cache-line-size old-cache) (cache-nlines old-cache))
 	    (compute-cache-parameters nkeys valuep new-nlines))
+      (declare (type index cache-mask actual-size line-size nlines))
       (setf (cache-nkeys cache) nkeys
 	    (cache-valuep cache) valuep
 	    (cache-nlines cache) nlines
@@ -570,10 +701,12 @@
 	    (cache-mask cache) cache-mask
 	    (cache-size cache) actual-size
 	    (cache-line-size cache) line-size
-	    (cache-max-location cache) (let ((line (1- nlines)))
-					 (if (= nkeys 1)
-					     (* line line-size)
-					     (1+ (* line line-size))))
+	    (cache-max-location cache)
+              (the index (let ((line (1- nlines)))
+                            (declare (type index line))
+			    (if (= nkeys 1)
+			        (the index (* line line-size))
+			        (the index (1+ (the index (* line line-size)))))))
 	    (cache-vector cache) (get-cache-vector actual-size)
 	    (cache-overflow cache) nil)
       cache)))
@@ -583,7 +716,8 @@
 	 (size (cache-size old-cache))
 	 (old-vector (cache-vector old-cache))
 	 (new-vector (get-cache-vector size)))
-    (declare (simple-vector old-vector new-vector))
+    (declare (type simple-vector old-vector new-vector)
+             (type index         size))
     (dotimes (i size)
       (setf (svref new-vector i) (svref old-vector i)))
     (setf (cache-vector new-cache) new-vector)
@@ -596,38 +730,38 @@
   nil)
 
 (defun compute-line-size (x)
+  (declare (type index x))
   (power-of-two-ceiling x))
 
 (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
-  ;;(declare (values cache-mask actual-size line-size nlines))
-  (declare (fixnum nkeys))
+  (declare (values cache-mask actual-size line-size nlines))
+  (declare (type index nkeys))
   (if (= nkeys 1)
       (let* ((line-size (if valuep 2 1))
 	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the fixnum 
+			     (the index
 				  (* line-size
-				     (the fixnum 
-					  (power-of-two-ceiling 
-					    nlines-or-cache-vector))))
+				     (power-of-two-ceiling 
+					(the index nlines-or-cache-vector))))
 			     (cache-vector-size nlines-or-cache-vector))))
-	(declare (fixnum line-size cache-size))
-	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+	(declare (type index line-size cache-size))
+	(values (logxor (the index (1- cache-size)) (the index (1- line-size)))
 		cache-size
 		line-size
-		(the fixnum (floor cache-size line-size))))
+		(the index (floor cache-size line-size))))
       (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
 	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the fixnum
+			     (the index
 				  (* line-size
-				     (the fixnum
+				     (the index
 					  (power-of-two-ceiling 
 					    nlines-or-cache-vector))))
 			     (1- (cache-vector-size nlines-or-cache-vector)))))
-	(declare (fixnum line-size cache-size))
-	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
-		(the fixnum (1+ cache-size))
+	(declare (type index line-size cache-size))
+	(values (logxor (the index (1- cache-size)) (the index (1- line-size)))
+		(the index (1+ cache-size))
 		line-size
-		(the fixnum (floor cache-size line-size))))))
+		(the index (floor cache-size line-size))))))
 
 
 
@@ -651,20 +785,21 @@
 ;;; compute the primary location of an entry.  
 ;;;
 (defun compute-primary-cache-location (field mask wrappers)
-  (declare (type field-type field) (fixnum mask))
+  (declare (type field-type field) (type index mask))
   (if (not (listp wrappers))
-      (logand mask (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
+      (the index
+          (logand mask (the index (wrapper-cache-number-vector-ref wrappers field))))
       (let ((location 0) (i 0))
-	(declare (fixnum location i))
+	(declare (type index location i))
 	(dolist (wrapper wrappers)
 	  ;;
 	  ;; First add the cache number of this wrapper to location.
 	  ;; 
 	  (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper field)))
-	    (declare (fixnum wrapper-cache-number))
+	    (declare (type index wrapper-cache-number))
 	    (if (zerop wrapper-cache-number)
 		(return-from compute-primary-cache-location 0)
-		(setq location (the fixnum (+ location wrapper-cache-number)))))
+		(setq location (the index (+ location wrapper-cache-number)))))
 	  ;;
 	  ;; Then, if we are working with lots of wrappers, deal with
 	  ;; the wrapper-cache-number-mask stuff.
@@ -672,9 +807,9 @@
 	  (when (and (not (zerop i))
 		     (zerop (mod i wrapper-cache-number-adds-ok)))
 	    (setq location
-		  (logand location wrapper-cache-number-mask)))
-	  (incf i))
-	(the fixnum (1+ (logand mask location))))))
+		  (the index (logand location wrapper-cache-number-mask))))
+	  (setf i (the index (1+ i))))
+	(the index (1+ (the index (logand mask location)))))))
 
 ;;;
 ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
@@ -689,23 +824,23 @@
 ;;; the cache line in question.
 ;;;
 (defun compute-primary-cache-location-from-location (field cache location)
-  (declare (type field-type field) (fixnum location))
+  (declare (type field-type field) (type index location))
   (let ((result 0)
 	(cache-vector (cache-vector cache))
 	(mask (cache-mask cache))
 	(nkeys (cache-nkeys cache)))
-    (declare (fixnum result mask nkeys) (simple-vector cache-vector))
+    (declare (type index result mask nkeys) (simple-vector cache-vector))
     (dotimes (i nkeys)
       (let* ((wrapper (cache-vector-ref cache-vector (+ i location)))
 	     (wcn (wrapper-cache-number-vector-ref wrapper field)))
-	(declare (fixnum wcn))
-	(setq result (+ result wcn)))
+	(declare (type index wcn))
+	(setq result (the index (+ result wcn))))
       (when (and (not (zerop i))
 		 (zerop (mod i wrapper-cache-number-adds-ok)))
-	(setq result (logand result wrapper-cache-number-mask))))    
+	(setq result (the index (logand result wrapper-cache-number-mask)))))
     (if (= nkeys 1)
 	(logand mask result)
-	(the fixnum (1+ (logand mask result))))))
+	(the index (1+ (the index (logand mask result)))))))
 
 (defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
   (with-lap-registers ((mask index) 
@@ -743,7 +878,8 @@
 			     wrapper-cache-no)
 		     (opcode :izerop wrapper-cache-no miss-label)
 		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
-		     (when (zerop (mod i wrapper-cache-number-adds-ok))
+		     (when (zerop (the index (mod (the index i)
+                                                  wrapper-cache-number-adds-ok)))
 		       (opcode :move (operand :ilogand primary mask) primary))))))))))
       (flatten-lap
        (opcode :move (operand :constant 0) primary)
@@ -806,12 +942,25 @@
       (ecase metatype
 	(standard-instance
 	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
+                #+pcl-user-instances
+		(get-user-inst-wrapper (make-symbol "get-user-inst-wrapper")))
 	    (flatten-lap
 	      (opcode :move (operand :arg argument) arg)
 	      (opcode :std-instance-p arg get-std-inst-wrapper)	   ;is it a std wrapper?
 	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)	   ;is it a fsc wrapper?
+              #+pcl-user-instances
+	      (opcode :user-instance-p arg get-user-inst-wrapper)  ;is it a user wrapper?
 	      (opcode :go miss-label)
+              #+pcl-user-instances
+	      (opcode :label get-user-inst-wrapper)
+              #+pcl-user-instances
+	      (opcode :move (operand :user-wrapper arg) dest)	   ;get user wrapper
+              #+pcl-user-instances
+	      (and slot
+		   (opcode :move (operand :user-slots arg) slot))
+              #+pcl-user-instances
+	      (opcode :go exit-emit-fetch-wrapper)
 	      (opcode :label get-fsc-inst-wrapper)
 	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
 	      (and slot
@@ -825,13 +974,23 @@
 	(class
 	  (when slot (error "Can't do a slot reg for this metatype."))
 	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
-		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))
+                #+pcl-user-instances
+		(get-user-inst-wrapper (make-symbol "get-user-inst-wrapper")))
 	    (flatten-lap
 	      (opcode :move (operand :arg argument) arg)
 	      (opcode :std-instance-p arg get-std-inst-wrapper)
 	      (opcode :fsc-instance-p arg get-fsc-inst-wrapper)
+              #+pcl-user-instances
+	      (opcode :user-instance-p arg get-user-inst-wrapper)
 	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
 	      (opcode :go exit-emit-fetch-wrapper)
+              #+pcl-user-instances
+	      (opcode :label get-user-inst-wrapper)
+              #+pcl-user-instances
+	      (opcode :move (operand :user-wrapper arg) dest)
+              #+pcl-user-instances
+	      (opcode :go exit-emit-fetch-wrapper)
 	      (opcode :label get-fsc-inst-wrapper)
 	      (opcode :move (operand :fsc-wrapper arg) dest)
 	      (opcode :go exit-emit-fetch-wrapper)
@@ -858,12 +1017,14 @@
 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
 
 (defun dfun-arg-symbol (arg-number)
+  (declare (type index arg-number))
   (or (nth arg-number (the list *dfun-arg-symbols*))
       (intern (format nil ".ARG~A." arg-number) *the-pcl-package*)))
 
 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
 
 (defun slot-vector-symbol (arg-number)
+  (declare (type index arg-number))
   (or (nth arg-number (the list *slot-vector-symbols*))
       (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*)))
 
@@ -894,8 +1055,8 @@
 	      (progn s)
 	      (gather1 (dfun-arg-symbol i))))))
     (if applyp
-	`(function-apply   ,fn-variable ,@required .dfun-rest-arg.)
-	`(function-funcall ,fn-variable ,@required))))
+	`(method-function-apply   ,fn-variable ,@required .dfun-rest-arg.)
+	`(method-function-funcall ,fn-variable ,@required))))
 
 
 ;;;
@@ -932,12 +1093,12 @@
     ;; this is true is for line number 0 of an nkeys=1 cache.  
     ;;
     (line-reserved-p (line)
-      (declare (fixnum line))
+      (declare (type index line))
       (and (= (nkeys) 1)
            (= line 0)))
     ;;
     (location-reserved-p (location)
-      (declare (fixnum location))
+      (declare (type index location))
       (and (= (nkeys) 1)
            (= location 0)))
     ;;
@@ -947,21 +1108,21 @@
     ;; by line size.  
     ;; 	  
     (line-location (line)
-      (declare (fixnum line))
+      (declare (type index line))
       (when (line-reserved-p line)
         (error "line is reserved"))
       (if (= (nkeys) 1)
-	  (the fixnum (* line (line-size)))
-	  (the fixnum (1+ (the fixnum (* line (line-size)))))))
+	  (the index (* line (line-size)))
+	  (the index (1+ (the index (* line (line-size)))))))
     ;;
     ;; Given a cache location, return the line.  This is the inverse
     ;; of LINE-LOCATION.
     ;; 	  
     (location-line (location)
-      (declare (fixnum location))
+      (declare (type index location))
       (if (= (nkeys) 1)
 	  (floor location (line-size))
-	  (floor (the fixnum (1- location)) (line-size))))
+	  (floor (the index (1- location)) (line-size))))
     ;;
     ;; Given a line number, return the wrappers stored at that line.
     ;; As usual, if nkeys=1, this returns a single value.  Only when
@@ -969,12 +1130,12 @@
     ;; line is reserved.
     ;;
     (line-wrappers (line)
-      (declare (fixnum line))
+      (declare (type index line))
       (when (line-reserved-p line) (error "Line is reserved."))
       (location-wrappers (line-location line)))
     ;;
     (location-wrappers (location) ; avoid multiplies caused by line-location
-      (declare (fixnum location))
+      (declare (type index location))
       (if (= (nkeys) 1)
 	  (cache-vector-ref (vector) location)
 	  (let ((list (make-list (nkeys)))
@@ -987,12 +1148,12 @@
     ;; wrappers are the same as wrappers.
     ;;
     (line-matches-wrappers-p (line wrappers)
-      (declare (fixnum line))
+      (declare (type index line))
       (and (not (line-reserved-p line))
            (location-matches-wrappers-p (line-location line) wrappers)))
     ;;
     (location-matches-wrappers-p (loc wrappers) ; must not be reserved
-      (declare (fixnum loc))
+      (declare (type index loc))
       (let ((cache-vector (vector)))
 	(declare (simple-vector cache-vector))
 	(if (= (nkeys) 1)
@@ -1006,12 +1167,12 @@
     ;; an error is signalled if the line is reserved.
     ;; 
     (line-value (line)
-      (declare (fixnum line))
+      (declare (type index line))
       (when (line-reserved-p line) (error "Line is reserved."))
       (location-value (line-location line)))
     ;;
     (location-value (loc)
-      (declare (fixnum loc))
+      (declare (type index loc))
       (and (valuep)
            (cache-vector-ref (vector) (+ loc (nkeys)))))
     ;;
@@ -1028,12 +1189,12 @@
     ;; An error is signalled if the line is reserved.
     ;;
     (line-valid-p (line wrappers)
-      (declare (fixnum line))
+      (declare (type index line))
       (when (line-reserved-p line) (error "Line is reserved."))
       (location-valid-p (line-location line) wrappers))
     ;;
     (location-valid-p (loc wrappers)
-      (declare (fixnum loc))
+      (declare (type index loc))
       (let ((cache-vector (vector))
 	    (wrappers-mismatch-p (null wrappers)))
 	(declare (simple-vector cache-vector))
@@ -1050,9 +1211,9 @@
     ;; How many unreserved lines separate line-1 and line-2.
     ;;
     (line-separation (line-1 line-2)
-     (declare (fixnum line-1 line-2))
+     (declare (type index line-1 line-2))
      (let ((diff (the fixnum (- line-2 line-1))))
-       (declare (fixnum diff))
+       (declare (type fixnum diff))
        (when (minusp diff)
 	 (setq diff (+ diff (nlines)))
 	 (when (line-reserved-p 0)
@@ -1063,18 +1224,18 @@
     ;; return a reserved line.
     ;; 
     (next-line (line)
-     (declare (fixnum line))
-     (if (= line (the fixnum (1- (nlines))))
+     (declare (type index line))
+     (if (= line (the index (1- (nlines))))
 	 (if (line-reserved-p 0) 1 0)
-	 (the fixnum (1+ line))))
+	 (the index (1+ line))))
     ;;
     (next-location (loc)
-      (declare (fixnum loc))
+      (declare (type index loc))
       (if (= loc (max-location))
 	  (if (= (nkeys) 1)
 	      (line-size)
 	      1)
-	  (the fixnum (+ loc (line-size)))))
+	  (the index (+ loc (line-size)))))
     ;;
     ;; Given a line which has a valid entry in it, this will return
     ;; the primary cache line of the wrappers in that line.  We just
@@ -1082,11 +1243,11 @@
     ;; easier packaging up of the call to it.
     ;; 
     (line-primary (field line)
-      (declare (fixnum field line))
+      (declare (type index field line))
       (location-line (line-primary-location field line)))
     ;;
     (line-primary-location (field line)
-     (declare (fixnum field line))
+     (declare (type index field line))
      (compute-primary-cache-location-from-location
        field (cache) (line-location line)))
     ))
@@ -1103,7 +1264,7 @@
 			*local-cache-functions*)
        ,@body)))
 
-)
+) ;eval-when
 
 ;;;
 ;;; Here is where we actually fill, recache and expand caches.
@@ -1124,25 +1285,46 @@
 ;;;
 (defvar *cache-expand-threshold* 1.25)
 
+(defun cache-count (cache)
+  (with-local-cache-functions (cache)
+    (let ((count 0)(location (if (= (nkeys) 1) (line-size) 1)))
+      (declare (type index count))
+      (dotimes (i (nlines) count)
+	(unless (or (location-reserved-p location)
+		    (not (location-valid-p location nil)))
+	  (setq count (the index (1+ count))))
+	(setq location (next-location location))))))
+
+#|
+(defun entry-in-cache-p (cache wrappers value)
+  (declare (ignore value))
+  (with-local-cache-functions (cache)
+    (dotimes (i (nlines))
+      (unless (line-reserved-p i)
+	(when (equal (line-wrappers i) wrappers)
+	  (return t))))))
+|#
+
 (defun fill-cache (cache wrappers value &optional free-cache-p)
-  ;;(declare (values cache))
+  (declare (values cache))
   (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check.
     (error "fill-cache: wrappers arg is NIL!"))
   (or (fill-cache-p nil cache wrappers value)
-      (and (< (ceiling (* (cache-count cache) 1.25))
-	      (if (= (cache-nkeys cache) 1)
-		  (1- (cache-nlines cache))
-		  (cache-nlines cache)))
+      (and (< (the index (ceiling (* (cache-count cache) 1.25)))
+	      (the index
+                   (if (= (cache-nkeys cache) 1)
+		       (1- (cache-nlines cache))
+		       (cache-nlines cache))))
 	   (adjust-cache cache wrappers value free-cache-p))
       (expand-cache cache wrappers value free-cache-p)))
 
 (defun probe-cache (cache wrappers &optional default)
-  ;;(declare (values value))
+  (declare (values value))
   (unless wrappers (error "probe-cache: wrappers arg is NIL!"))
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
-	   (limit (funcall (limit-fn) (nlines))))
-      (declare (fixnum location limit))
+	   (limit (funcall-function (limit-fn) (nlines))))
+      (declare (type index location limit))
       (when (location-reserved-p location)
 	(setq location (next-location location)))
       (dotimes (i limit default)
@@ -1151,6 +1333,7 @@
 	(setq location (next-location location))))))
 
 (defun map-cache (function cache &optional set-p)
+  (declare (type real-function function))
   (with-local-cache-functions (cache)
     (let ((set-p (and set-p (valuep))))
       (dotimes (i (nlines) cache)
@@ -1160,32 +1343,16 @@
 	      (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
 		    value))))))))
 
-(defun cache-count (cache)
-  (with-local-cache-functions (cache)
-    (let ((count 0)(location (if (= (nkeys) 1) (line-size) 1)))
-      (declare (fixnum count))
-      (dotimes (i (nlines) count)
-	(unless (or (location-reserved-p location)
-		    (not (location-valid-p location nil)))
-	  (setq count (the fixnum (1+ count))))
-	(setq location (next-location location))))))
-
-(defun entry-in-cache-p (cache wrappers value)
-  (declare (ignore value))
-  (with-local-cache-functions (cache)
-    (dotimes (i (nlines))
-      (unless (line-reserved-p i)
-	(when (equal (line-wrappers i) wrappers)
-	  (return t))))))
 
 ;;;
 ;;; returns T or NIL
 ;;;
+
 (defun fill-cache-p (forcep cache wrappers value)
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
 	   (primary (location-line location)))
-      (declare (fixnum location primary))
+      (declare (type index location primary))
       (multiple-value-bind (free emptyp)
 	  (find-free-cache-line primary cache wrappers)
 	(when (or forcep emptyp)
@@ -1194,32 +1361,32 @@
 		  (cache-overflow cache)))
 	  ;;(fill-line free wrappers value)
 	  (let ((line free))
-	    (declare (fixnum line))
+	    (declare (type index line))
 	    (when (line-reserved-p line)
 	      (error "Attempt to fill a reserved line."))
 	    (let ((loc (line-location line))
 		  (cache-vector (vector)))
-	      (declare (fixnum loc) (simple-vector cache-vector))
+	      (declare (type index loc) (simple-vector cache-vector))
 	      (cond ((= (nkeys) 1)
 		     (setf (cache-vector-ref cache-vector loc) wrappers)
 		     (when (valuep)
 		       (setf (cache-vector-ref cache-vector (1+ loc)) value)))
 		    (t
 		     (let ((i 0))
-		       (declare (fixnum i))
+		       (declare (type index i))
 		       (dolist (w wrappers)
 			 (setf (cache-vector-ref cache-vector (+ loc i)) w)
-			 (setq i (the fixnum (1+ i)))))
+			 (setq i (the index (1+ i)))))
 		     (when (valuep)
 		       (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
 			     value))))))
 	  cache)))))
 
 (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
-  (declare (fixnum from-line))
+  (declare (type index from-line))
   (with-local-cache-functions (from-cache)
     (let ((primary (line-primary (field) from-line)))
-      (declare (fixnum primary))
+      (declare (type index primary))
       (multiple-value-bind (free emptyp)
 	  (find-free-cache-line primary cache)
 	(when (or forcep emptyp)
@@ -1230,12 +1397,12 @@
 	  (let ((from-cache-vector (vector))
 		(to-cache-vector (cache-vector cache))
 		(to-line free))
-	    (declare (fixnum to-line))
+	    (declare (type index to-line))
 	    (if (line-reserved-p to-line)
 		(error "transfering something into a reserved cache line.")
 		(let ((from-loc (line-location from-line))
 		      (to-loc (line-location to-line)))
-		  (declare (fixnum from-loc to-loc))
+		  (declare (type index from-loc to-loc))
 		  (modify-cache to-cache-vector
 				(dotimes (i (line-size))
 				  (setf (cache-vector-ref to-cache-vector
@@ -1245,7 +1412,7 @@
 	  cache)))))
 
 ;;;
-;;; Returns NIL or (values <field> <cache-vector>)
+;;; Returns NIL or (values <field> <cache>)
 ;;; 
 ;;; This is only called when it isn't possible to put the entry in the cache
 ;;; the easy way.  That is, this function assumes that FILL-CACHE-P has been
@@ -1260,7 +1427,7 @@
     (let ((ncache (get-cache-from-cache cache (nlines) (field))))
       (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
 	  ((null nfield) (free-cache ncache) nil)
-	(setf (cache-field ncache) nfield)
+	(setf (cache-field ncache) (the index nfield))
 	(labels ((try-one-fill-from-line (line)
 		   (fill-cache-from-cache-p nil ncache cache line))
 		 (try-one-fill (wrappers value)
@@ -1282,9 +1449,9 @@
 ;;; returns: (values <cache>)
 ;;;
 (defun expand-cache (cache wrappers value free-old-cache-p)
-  ;;(declare (values cache))
+  (declare (values cache))
   (with-local-cache-functions (cache)
-    (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
+    (let ((ncache (get-cache-from-cache cache (the index (* (nlines) 2)))))
       (labels ((do-one-fill-from-line (line)
 		 (unless (fill-cache-from-cache-p nil ncache cache line)
 		   (do-one-fill (line-wrappers line) (line-value line))))
@@ -1305,7 +1472,7 @@
 	(when free-old-cache-p (free-cache cache))
 	ncache))))
 
-
+
 ;;;
 ;;; This is the heart of the cache filling mechanism.  It implements the decisions
 ;;; about where entries are placed.
@@ -1316,26 +1483,27 @@
 ;;;   <empty?>           is <line> in fact empty?
 ;;;
 (defun find-free-cache-line (primary cache &optional wrappers)
-  ;;(declare (values line empty?))
-  (declare (fixnum primary))
+  (declare (values line empty?))
+  (declare (type index primary))
   (with-local-cache-functions (cache)
     (when (line-reserved-p primary) (setq primary (next-line primary)))
-    (let ((limit (funcall (limit-fn) (nlines)))
+    (let ((limit (funcall-function (limit-fn) (nlines)))
 	  (field (field))
 	  (wrappedp nil)
 	  (lines nil)
 	  (p primary) (s primary)
 	  (successp nil))
-      (declare (fixnum p s limit) (type field-type field))
+      (declare (type index p s limit) (type field-type field)
+               (type boolean wrappedp successp))
       (block find-free
 	(loop
 	 ;; Try to find a free line starting at <s>.  <p> is the
 	 ;; primary line of the entry we are finding a free
 	 ;; line for, it is used to compute the seperations.
 	 (do* ((line s (next-line line))
-	       (nsep (line-separation p s) (1+ nsep)))
+	       (nsep (line-separation p s) (the index (1+ nsep))))
 	      (())
-	   (declare (fixnum line nsep))
+	   (declare (type index line nsep))
 	   (when (null (line-valid-p line wrappers)) ;If this line is empty or
 	     (push line lines)		;invalid, just use it.
 	     (return-from find-free (setq successp t)))
@@ -1345,29 +1513,29 @@
 	       (push line lines)
 	       (return-from find-free (setq successp nil)))
 	     (when (cond ((= nsep limit) t)
-			 ((= nsep osep) (zerop (random 2)))
+			 ((= nsep osep) (zerop (the index (random 2))))
 			 ((> nsep osep) t)
 			 (t nil))
 	       ;; See if we can displace what is in this line so that we
 	       ;; can use the line.
-	       (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
+	       (when (= line (the index (1- (nlines)))) (setq wrappedp t))
 	       (setq p (line-primary field line))
 	       (setq s (next-line line))
 	       (push line lines)
 	       (return nil)))
-	   (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
+	   (when (= line (the index (1- (nlines)))) (setq wrappedp t)))))
       ;; Do all the displacing.
       (loop 
        (when (null (cdr lines)) (return nil))
        (let ((dline (pop lines))
 	     (line (car lines)))
-	 (declare (fixnum dline line))
+	 (declare (type index dline line))
 	 (when successp
 	   ;;Copy from line to dline (dline is known to be free).
 	   (let ((from-loc (line-location line))
 		 (to-loc (line-location dline))
 		 (cache-vector (vector)))
-	     (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
+	     (declare (type index from-loc to-loc) (simple-vector cache-vector))
 	     (modify-cache cache-vector
 			   (dotimes (i (line-size))
 			     (setf (cache-vector-ref cache-vector (+ to-loc i))
@@ -1377,12 +1545,16 @@
       (values (car lines) successp))))
 
 (defun default-limit-fn (nlines)
+  (declare (type index nlines))
   (case nlines
     ((1 2 4) 1)
     ((8 16)  4)
     (otherwise 6)))
 
+(declaim (type cache *empty-cache*))
 (defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
+
+
 
 ;;;
 ;;; pre-allocate generic function caches.  The hope is that this will put
diff --git a/pcl/cmu-low.lisp b/pcl/cmu-low.lisp
index c5299bf5a..2c0b1a5ff 100644
--- a/pcl/cmu-low.lisp
+++ b/pcl/cmu-low.lisp
@@ -29,9 +29,16 @@
 
 (in-package 'pcl)
 
+(defun function-ftype-declaimed-p (name)
+  "Returns whether the function given by name already has its ftype declaimed."
+  (multiple-value-bind (ftype-info recorded-p)
+      (extensions:info function type name)
+    (declare (ignore ftype-info))
+    recorded-p))
+
 (defmacro dotimes ((var count &optional (result nil)) &body body)
-  `(lisp:dotimes (,var (the fixnum ,count) ,result)
-     (declare (fixnum ,var))
+  `(lisp:dotimes (,var (the index ,count) ,result)
+     (declare (type index ,var))
      ,@body))
 
 ;;; Just use our without-interrupts.  We don't have the INTERRUPTS-ON/OFF local
@@ -105,28 +112,27 @@
 
 ;;From compiler/ir1util
 (def-source-context pcl::defmethod (name &rest stuff)
+  (declare (type list stuff))
   (let ((arg-pos (position-if #'listp stuff)))
+    (declare (type (or null index) arg-pos))
     (if arg-pos
 	`(pcl::defmethod ,name ,@(subseq stuff 0 arg-pos)
 	   ,(nth-value 2 (pcl::parse-specialized-lambda-list
 			  (elt stuff arg-pos))))
 	`(pcl::defmethod ,name "<illegal syntax>"))))
 
+
 (in-package 'pcl)
 
 (pushnew :structure-wrapper *features*)
+(pushnew :structure-functions *features*)
 
-(defun structure-functions-exist-p ()
-  t)
-
-(defun structure-instance-p (x)
-  (and (structurep x)
-       (not (eq (kernel:structure-ref x 0) 'std-instance))))
+(import 'ext:structurep)
 
-(defun structure-type (x)
-  (kernel:structure-ref x 0))
+(defmacro structure-type (x)
+  `(kernel:structure-ref ,x 0))
 
-(defun structure-type-p (type)
+(defun known-structure-type-p (type)
   (not (null (ext:info c::type c::defined-structure-info type))))
 
 (defun structure-type-included-type-name (type)
@@ -136,8 +142,9 @@
 	include)))
 
 (defun structure-type-slot-description-list (type)
-  (nthcdr (length (let ((include (structure-type-included-type-name type)))
-		    (and include (structure-type-slot-description-list include))))
+  (nthcdr (length (the list
+                       (let ((include (structure-type-included-type-name type)))
+		         (and include (structure-type-slot-description-list include)))))
 	  (c::dd-slots (ext:info c::type c::defined-structure-info type))))
 
 (defun structure-slotd-name (slotd)
diff --git a/pcl/combin.lisp b/pcl/combin.lisp
index fe62da68f..60215f20b 100644
--- a/pcl/combin.lisp
+++ b/pcl/combin.lisp
@@ -27,22 +27,35 @@
 
 (in-package 'pcl)
 
+(defun null-wrappers-method-function (&rest args)
+  ;; Function returned when get-method-function passed no wrappers for
+  ;; caching.  I'm not exactly sure why get-method-function gets called
+  ;; with null wrappers when a generic function is first created, but
+  ;; they do.  However, the method-function returned never seemed to
+  ;; get called, so to save a bunch of unneed closure-generation
+  ;; and other muckity-muck, this function is just returned instead.
+  (error "Internal PCL error:  Calling method-function created by
+          get-method-function with wrappers NIL.  Called with args: ~S"
+         args))
+
 (defun get-method-function (method &optional method-alist wrappers)
-  (or (cadr (assoc method method-alist))
+  (or (cadr (assq method method-alist))
       (if wrappers
 	  (method-function-for-caching method wrappers)
-	  (method-function method))))
+	  (or (method-optimized-function method)
+              #'null-wrappers-method-function))))
 
 (defun make-effective-method-function (generic-function form &optional 
 				       method-alist wrappers)
-  (funcall (make-effective-method-function1 generic-function form)
-	   method-alist wrappers))
+  (funcall-function (make-effective-method-function1 generic-function form)
+	            method-alist wrappers))
 
 (defun make-effective-method-function1 (generic-function form)
   (if (and (listp form)
 	   (eq (car form) 'call-method)
 	   (method-p (cadr form))
-	   (every #'method-p (caddr form)))
+	   (or (every #'method-p (caddr form))
+	       (not (method-needs-next-methods-p (cadr form)))))
       (make-effective-method-function-simple generic-function form)
       ;;
       ;; We have some sort of `real' effective method.  Go off and get a
@@ -64,13 +77,14 @@
   ;; or aren't to prevent the leaky next methods bug.
   ;; 
   (let ((method (cadr form)))
-    (if (not (method-function-needs-next-methods-p (method-function method)))
+    (if (not (method-needs-next-methods-p method))
 	#'(lambda (method-alist wrappers)
 	    (get-method-function method method-alist wrappers))
 	(let* ((arg-info (gf-arg-info generic-function))
 	       (metatypes (arg-info-metatypes arg-info))
 	       (applyp (arg-info-applyp arg-info))
 	       (next-methods (caddr form)))
+	  (declare (type boolean applyp))
 	  (multiple-value-bind (cfunction constants)
 	      (get-function1
 	       `(lambda ,(make-dfun-lambda-list metatypes applyp)
@@ -92,7 +106,7 @@
 	    #'(lambda (method-alist wrappers)
 		(flet ((fix-meth (meth)
 			 (get-method-function meth method-alist wrappers)))
-		  (function-apply cfunction
+		  (apply-function cfunction
 				  (mapcar #'(lambda (constant)
 					      (cond ((atom constant)
 						     constant)
@@ -103,6 +117,7 @@
 						    (t constant)))
 					  constants)))))))))
 
+(declaim (type list *global-effective-method-gensyms*))
 (defvar *global-effective-method-gensyms* ())
 (defvar *rebound-effective-method-gensyms*)
 
@@ -118,13 +133,12 @@
 (let ((*rebound-effective-method-gensyms* ()))
   (dotimes (i 10) (get-effective-method-gensym)))
 
-#+lcl3.0 (dont-use-production-compiler)
-
 (defun make-effective-method-function-internal (generic-function effective-method)
   (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
 	 (arg-info (gf-arg-info generic-function))
 	 (metatypes (arg-info-metatypes arg-info))
 	 (applyp (arg-info-applyp arg-info)))
+    (declare (type boolean applyp))
     (labels ((test-converter (form)
 	       (if (and (consp form) (eq (car form) 'call-method))
 		   (if (caddr form)
@@ -175,8 +189,8 @@
 	    (flet ((fix-meth (meth)
 		     (if (method-p meth)
 			 (get-method-function meth method-alist wrappers)
-			 (funcall meth method-alist wrappers))))
-	      (function-apply cfunction
+			 (funcall-function meth method-alist wrappers))))
+	      (apply-function cfunction
 			      (mapcar #'(lambda (constant)
 					  (cond ((atom constant)
 						 constant)
@@ -187,8 +201,6 @@
 						(t constant)))
 				      constants))))))))
 
-#+lcl3.0 (use-previous-compiler)
-
 
 
 (defvar *invalid-method-error*
@@ -248,6 +260,7 @@
 (defclass method-combination (metaobject) ()
   (:predicate-name method-combination-p))
 
+
 (mapc
  #'proclaim-incompatible-superclasses
  '(;; superclass metaobject
@@ -256,11 +269,9 @@
    ))
 
 (defclass standard-method-combination
-	  (definition-source-mixin method-combination)
+	  (documentation-mixin definition-source-mixin method-combination)
      ((type          :reader method-combination-type
 	             :initarg :type)
-      (documentation :reader method-combination-documentation
-		     :initarg :documentation)
       (options       :reader method-combination-options
 	             :initarg :options)))
 
@@ -300,9 +311,9 @@
 	(around ()))
     (dolist (m applicable-methods)
       (let ((qualifiers (method-qualifiers m)))
-	(cond ((member ':before qualifiers)  (push m before))
-	      ((member ':after  qualifiers)  (push m after))
-	      ((member ':around  qualifiers) (push m around))
+	(cond ((memq ':before qualifiers)  (push m before))
+	      ((memq ':after  qualifiers)  (push m after))
+	      ((memq ':around  qualifiers) (push m around))
 	      (t
 	       (push m primary)))))
     (setq before  (reverse before)
diff --git a/pcl/construct.lisp b/pcl/construct.lisp
index d1ef1f034..edbbc238a 100644
--- a/pcl/construct.lisp
+++ b/pcl/construct.lisp
@@ -424,9 +424,9 @@
            (compute-applicable-methods #'make-instance (list class)))
 	 (supplied-initarg-names
 	   (constructor-supplied-initarg-names constructor))
-         (default
-	   (compute-applicable-methods #'default-initargs
-				       (list class supplied-initarg-names))) ;?
+;         (default
+;	   (compute-applicable-methods #'default-initargs
+;				       (list class supplied-initarg-names))) ;?
          (allocate
            (compute-applicable-methods #'allocate-instance (list class)))
          (initialize
@@ -441,7 +441,7 @@
 		 (error "No FALLBACK generator?")))
 	     (funcall generator class wrapper defaults initialize shared)))
       (if (or (cdr make)
-	      (cdr default)
+;	      (cdr default)
 	      (cdr allocate)
 	      (check-initargs class
 			      supplied-initarg-names
@@ -465,8 +465,10 @@
 ;;; 
 
 (defun map-constructors (fn)
+  (declare (type real-function fn))
   (let ((nclasses 0)
 	(nconstructors 0))
+    (declare (type index nclasses nconstructors))
     (labels ((recurse (class)
 	       (incf nclasses)
 	       (dolist (constructor (class-constructors class))
@@ -573,11 +575,12 @@
 ;;;    t              there is at least one non-constant initform
 ;;; 
 (defun compute-constant-vector (class)
-  ;;(declare (values constants flag))
+  (declare (values constants flag))
   (let* ((wrapper (class-wrapper class))
 	 (layout (wrapper-instance-slots-layout wrapper))
 	 (flag :unsupplied)
 	 (constants ()))
+    (declare (list layout))
     (dolist (slotd (class-slots class))
       (let ((name (slot-definition-name slotd))
 	    (initform (slot-definition-initform slotd))
@@ -624,6 +627,7 @@
 			     (or (cdr (assq (slot-definition-name slotd) positions))
 				 ':class)))
 		   (class-slots class))))
+    (declare (list layout positions slot-initargs))
     ;; Go through each of the initargs, and figure out what position
     ;; it fills by replacing the entries in slot-initargs it fills.
     (dolist (initarg initarg-names)
@@ -749,6 +753,7 @@
 	   (supplied-initarg-positions ())
 	   (constant-initargs ())
 	   (used-positions ()))
+      (declare (list layout))
 					       
       ;;
       ;; Go through each of the supplied initargs for three reasons.
@@ -899,6 +904,7 @@
 	   (initfns-and-positions ())
 	   (supplied-initarg-positions ())
 	   (used-positions ()))
+      (declare (list layout))
       ;;
       ;; Go through each of the supplied initargs for three reasons.
       ;;
@@ -1031,6 +1037,7 @@
 						(mapcar #'car defaults))))
 	   (supplied-initarg-positions ())
 	   (used-positions ()))
+      (declare (list layout))
       ;;
       ;; Go through each of the supplied initargs for three reasons.
       ;;
diff --git a/pcl/cpatch.lisp b/pcl/cpatch.lisp
index 23641de54..0cde7bfcf 100644
--- a/pcl/cpatch.lisp
+++ b/pcl/cpatch.lisp
@@ -5,6 +5,11 @@
 ;; copyright (c) 1990 Franz Inc.
 ;;
 
+#+pcl-user-instances
+(eval-when (compile load eval)
+(error "Cannot use user-instances in EXCL on Sun4 with cpatch.lisp and
+        quadlap.lisp optimizations (see low.lisp).")
+)
 (in-package :comp)
 
 (def-quad-op tail-funcall qp-end-block
diff --git a/pcl/cpl.lisp b/pcl/cpl.lisp
index ff05e951e..6947fca9a 100644
--- a/pcl/cpl.lisp
+++ b/pcl/cpl.lisp
@@ -95,7 +95,7 @@
   (cpd-class  nil)
   (cpd-supers ())
   (cpd-after  ())
-  (cpd-count  0))
+  (cpd-count  0 :type fixnum))
 
 (defun compute-std-cpl (class supers)
   (cond ((null supers)				;First two branches of COND
@@ -112,12 +112,13 @@
 
 (defvar *compute-std-cpl-class->entry-table-size* 60)
 
+(declaim (ftype (function (T T) (values list index)) compute-std-cpl-phase-1))
 (defun compute-std-cpl-phase-1 (class supers)
   (let ((nclasses 0)
 	(all-cpds ())
 	(table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
 				:test #'eq)))
-    (declare (fixnum nclasses))
+    (declare (type index nclasses))
     (labels ((get-cpd (c)
 	       (or (gethash c table)
 		   (setf (gethash c table) (make-cpd))))
@@ -149,6 +150,7 @@
 	  (push (car t2) (cpd-after (car t1))))))))
 
 (defun compute-std-cpl-phase-3 (class all-cpds nclasses)
+  (declare (type index nclasses))
   (let ((candidates ())
 	(next-cpd nil)
 	(rcpl ()))
@@ -195,7 +197,7 @@
       (decf nclasses)
       (push (cpd-class next-cpd) rcpl)
       (dolist (after (cpd-after next-cpd))
-	(when (zerop (decf (cpd-count after)))
+	(when (zerop (the fixnum (decf (cpd-count after))))
 	  (push after candidates))))))
 
 ;;;
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index d9aebbbf1..aee35dec1 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -99,6 +99,7 @@
     #+kcl
     (let* ((*print-pretty* nil)
            (thunk-name (gensym (definition-name))))
+      (gensym "G") ; set the prefix back to something less confusing.
       `(eval-when ,times
          (defun ,thunk-name ()
            ,form)
@@ -136,7 +137,7 @@
   (expand-defclass name direct-superclasses direct-slots options))
 
 (defun expand-defclass (name supers slots options)
-  (declare (special *defclass-times*))
+  (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
   (setq supers  (copy-tree supers)
 	slots   (copy-tree slots)
 	options (copy-tree options))
@@ -158,32 +159,32 @@
           (*readers* ())                           ;to have it to live nicely.
           (*writers* ()))
       (declare (special *initfunctions* *accessors* *readers* *writers*))
-      (let ((canonical-slots
-	      (mapcar #'(lambda (spec)
-			  (canonicalize-slot-specification name spec))
-		      slots))
-	    (other-initargs
-	      (mapcar #'(lambda (option)
-			  (canonicalize-defclass-option name option))
-		      options))
-	    (defstruct-p (and (eq *boot-state* 'complete)
-			      (let ((mclass (find-class metaclass nil)))
-				(and mclass
-				     (*subtypep mclass 
-						*the-class-structure-class*))))))
+      (let* ((canonical-slots
+	       (mapcar #'(lambda (spec)
+			   (canonicalize-slot-specification name spec))
+		       slots))
+	     (other-initargs
+	       (mapcar #'(lambda (option)
+			   (canonicalize-defclass-option name option))
+		       options))
+	      (defstruct-p (and (eq *boot-state* 'complete)
+			        (let ((mclass (find-class metaclass nil)))
+				  (and mclass
+				       (*subtypep mclass 
+						  *the-class-structure-class*))))))
 	(do-standard-defsetfs-for-defclass *accessors*)
         (let ((defclass-form 
                  (make-top-level-form `(defclass ,name)
-                   (if defstruct-p '(load eval) *defclass-times*)
+                   *defclass-times*
 		   `(progn
 		      ,@(mapcar #'(lambda (x)
-				    `(declaim (ftype (function (t) t) ,x)))
-				#+cmu *readers* #-cmu nil)
+                                    `(proclaim-defgeneric ',x '(self)))
+				*readers*)
 		      ,@(mapcar #'(lambda (x)
 				    #-setf (when (consp x)
 					     (setq x (get-setf-function-name (cadr x))))
-				    `(declaim (ftype (function (t t) t) ,x)))
-				#+cmu *writers* #-cmu nil)
+                                    `(proclaim-defgeneric ',x '(new self)))
+				*writers*)
 		      (let ,(mapcar #'cdr *initfunctions*)
 			(load-defclass ',name
 				       ',metaclass
@@ -194,17 +195,10 @@
 							'(:from-defclass-p t))
 						      other-initargs))
 				       ',*accessors*))))))
-          (if defstruct-p
-              (progn
-                (eval defclass-form) ; define the class now, so that
-                `(progn              ; the defstruct can be compiled.
-                   ,(class-defstruct-form (find-class name))
-                   ,defclass-form))
-	      (progn
-		(when (and (eq *boot-state* 'complete)
-			   (not (member 'compile *defclass-times*)))
-		  (inform-type-system-about-std-class name))
-		defclass-form)))))))
+          defclass-form)))))
+
+(defun float-zero ()
+  0.0)
 
 (defun make-initfunction (initform)
   (declare (special *initfunctions*))
@@ -217,12 +211,17 @@
 	((or (eql initform '0)
 	     (equal initform ''0))
 	 '(function zero))
+	((or (eql initform '0.0)
+	     (equal initform ''0.0))
+	 '(function float-zero))
 	(t
 	 (let ((entry (assoc initform *initfunctions* :test #'equal)))
 	   (unless entry
-	     (setq entry (list initform
-			       (gensym)
-			       `(function (lambda () ,initform))))
+	     (setq entry
+                   (list initform
+			 (gensym)
+                         `(slot-initfunction-storage-form
+                            (function (lambda () ,initform)))))
 	     (push entry *initfunctions*))
 	   (cadr entry)))))
 
@@ -268,8 +267,10 @@
 			',spec))
 	   (if (eq initform unsupplied)
 	       `(list* ,@spec)
-	       `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
-						
+	       `(list* :initfunction ,(make-initfunction initform)
+                       :initfunction-side-effect-free-p ,(simple-eval-access-p initform)
+                       ,@spec))))))
+
 (defun canonicalize-defclass-option (class-name option)  
   (declare (ignore class-name))
   (case (car option)
@@ -281,6 +282,8 @@
 		      val (pop tail))
 		(push ``(,',key ,,(make-initfunction val) ,',val) canonical))
 	  `(':direct-default-initargs (list ,@(nreverse canonical))))))
+    (:documentation
+      `(:documentation ',(cadr option)))
     (otherwise
       `(',(car option) ',(cdr option)))))
 
@@ -296,6 +299,7 @@
 ;;; Each entry in *early-class-definitions* is an early-class-definition.
 ;;; 
 ;;;
+(declaim (type list *early-class-definitions*))
 (defparameter *early-class-definitions* ())
 
 (defun make-early-class-definition
@@ -334,3 +338,234 @@
 	  (cons ecd (remove existing *early-class-definitions*)))
     ecd))
 
+;;;
+;;; FIND-CLASS
+;;;
+;;; This is documented in the CLOS specification.
+;;;
+(defvar *find-class* (make-hash-table :test #'eq))
+
+(defmacro find-class-cell-class (cell)
+  `(car ,cell))
+
+(defmacro find-class-cell-predicate (cell)
+  `(cdr ,cell))
+
+(defun find-class-cell (symbol &optional dont-create-p)
+  (or (gethash symbol *find-class*)
+      (unless dont-create-p
+	(unless (legal-class-name-p symbol)
+	  (error "~S is not a legal class name." symbol))
+	(setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
+
+(defun found-unknown-class (symbol errorp)
+  (cond ((null errorp) nil)
+        ((legal-class-name-p symbol)
+         (error "No class named: ~S." symbol))
+        (t
+         (error "~S is not a legal class name." symbol))))
+
+(defmacro find-class-from-cell (symbol cell &optional (errorp t))
+  `(or (find-class-cell-class ,cell)
+       (if (known-structure-type-p ,symbol)
+           (find-structure-class ,symbol)
+           #+structure-functions
+           (found-unknown-class ,symbol ,errorp)
+           #-structure-functions
+           (find-maybe-structure-class ,symbol ,errorp))))
+
+#-structure-functions
+(defun likely-to-name-structure-p (symbol)
+  ;; Returns whether Symbol is likely to name an already-defined
+  ;; structure by whether it can find the default make or predicate
+  ;; functions that would have been created by Defstruct.  This
+  ;; obviously may fail.
+  (let ((name (symbol-name symbol)))
+    (declare (type simple-string name))
+    (and (fboundp (intern (concatenate 'simple-string "MAKE-" name)
+                          (symbol-package symbol)))
+         (fboundp (intern (concatenate 'simple-string name "-P")
+                          (symbol-package symbol))))))
+
+#-structure-functions
+(defun find-maybe-structure-class (symbol errorp)
+  (if symbol
+      (multiple-value-bind (structurep surep)
+           (safe-subtypep symbol 'structure)
+        (declare (type boolean structurep surep))
+        (if structurep
+            (find-structure-class symbol :warn T)
+            (if surep
+                (found-unknown-class symbol errorp)
+                (if (likely-to-name-structure-p symbol)
+                    (find-structure-class symbol :warn T)
+                    (found-unknown-class symbol errorp)))))
+     (found-unknown-class symbol errorp)))
+
+(defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
+  (unless (find-class-cell-class cell)
+    (find-class-from-cell symbol cell errorp))
+  (find-class-cell-predicate cell))
+
+(defun legal-class-name-p (x)
+  (and (symbolp x)
+       (not (keywordp x))))
+
+(defun find-class (symbol &optional (errorp t) environment)
+  (declare (ignore environment))
+  (find-class-from-cell symbol (gethash symbol *find-class*) errorp))
+
+(defun find-class-predicate (symbol &optional (errorp t) environment)
+  (declare (ignore environment))
+  (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp))
+
+#-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)
+  (if (legal-class-name-p symbol)
+      (setf (find-class-cell-class (find-class-cell symbol)) new-value)
+      (error "~S is not a legal class name." symbol)))
+
+#-setf
+(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
+  (declare (ignore errorp environment))
+  `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
+
+(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
+          (new-value symbol)
+  (if (legal-class-name-p symbol)
+      (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
+      (error "~S is not a legal class name." symbol)))
+
+(defun make-find-class-cell (class-name)
+  (cons nil
+        #'(lambda (x)
+            (let* ((class (find-class class-name))
+                   (class-predicate (make-class-predicate class)))
+              (declare (type compiled-function class-predicate))
+              (setf (find-class-predicate class-name) class-predicate)
+              (funcall class-predicate x)))))
+
+(defun find-wrapper (symbol)
+  (class-wrapper (find-class symbol)))
+
+
+
+
+(declaim (ftype (function (T)
+                  (values index index boolean boolean boolean list list))
+                analyze-lambda-list))
+(defun analyze-lambda-list (lambda-list)
+  (declare (values nrequired noptional keysp restp allow-other-keys-p
+                   keywords keyword-parameters))
+  (flet ((parse-keyword-argument (arg)
+	   (if (listp arg)
+	       (if (listp (car arg))
+		   (caar arg)
+		   (make-keyword (car arg)))
+	       (make-keyword arg))))
+    (let ((nrequired 0)
+	  (noptional 0)
+	  (keysp nil)
+	  (restp nil)
+	  (allow-other-keys-p nil)
+	  (keywords ())
+	  (keyword-parameters ())
+	  (state 'required))
+      (declare (type index   nrequired noptional)
+               (type boolean keysp restp allow-other-keys-p)
+               (type list    keywords keyword-parameters))
+      (dolist (x lambda-list)
+	(if (memq x lambda-list-keywords)
+	    (case x
+	      (&optional         (setq state 'optional))
+	      (&key              (setq keysp 't
+				       state 'key))
+	      (&allow-other-keys (setq allow-other-keys-p 't))
+	      (&rest             (setq restp 't
+				       state 'rest))
+	      (&aux              (return t))
+	      (otherwise
+		(error "Encountered the non-standard lambda list keyword ~S." x)))
+	    (ecase state
+	      (required  (incf nrequired))
+	      (optional  (incf noptional))
+	      (key       (push (parse-keyword-argument x) keywords)
+			 (push x keyword-parameters))
+	      (rest      ()))))
+      (values nrequired noptional keysp restp allow-other-keys-p
+	      (reverse keywords)
+	      (reverse keyword-parameters)))))
+
+(defun keyword-spec-name (x)
+  (let ((key (if (atom x) x (car x))))
+    (if (atom key)
+	(intern (symbol-name key) (find-package "KEYWORD"))
+	(car key))))
+
+(defun ftype-declaration-from-lambda-list (lambda-list #+cmu name)
+  (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
+				  keys keyword-parameters)
+      (analyze-lambda-list lambda-list)
+    (declare (type index   nrequired noptional)
+             (type boolean keysp restp #+cmu allow-other-keys-p)
+             (type list    keys))
+    (declare (ignore keyword-parameters #-cmu allow-other-keys-p))
+    (let* (#+cmu (old (c::info function type name))
+	   #+cmu (old-ftype (if (c::function-type-p old) old nil))
+	   #+cmu (old-restp (and old-ftype (c::function-type-rest old-ftype)))
+	   #+cmu (old-keys (and old-ftype
+				(mapcar #'c::key-info-name
+					(c::function-type-keywords old-ftype))))
+	   #+cmu (old-keysp (and old-ftype (c::function-type-keyp old-ftype)))
+	   #+cmu (old-allowp (and old-ftype (c::function-type-allowp old-ftype)))
+	   (keywords #+cmu (union old-keys (mapcar #'keyword-spec-name keys))
+		     #-cmu (mapcar #'keyword-spec-name keys)))
+      (declare (type list keywords))
+      `(function ,(append (make-list nrequired :initial-element 't)
+			  (when (plusp noptional)
+			    (append '(&optional)
+				    (make-list noptional :initial-element 't)))
+			  (when (or restp #+cmu old-restp)
+			    '(&rest t))
+			  (when (or keysp #+cmu old-keysp)
+                            #+cmu
+			    (append '(&key)
+				    (mapcar #'(lambda (key)
+						`(,key t))
+					    keywords)
+				    (when (or allow-other-keys-p #+cmu old-allowp)
+				      '(&allow-other-keys)))
+                            #-cmu
+			    (append '(&key)
+                                     (make-list (length keywords)
+                                                :initial-element T))))
+		 #-(or cmu kcl) T
+		 #+(or cmu kcl) *))))
+
+(defun proclaim-function (name lambda-list
+                          &optional (return-type #+(or cmu kcl) '*
+                                                 #-(or cmu kcl) T))
+  (unless (function-ftype-declaimed-p name)
+    (eval `(declaim (ftype (function
+                              ,(mapcar #'(lambda (param)
+                                           (if (memq param lambda-list-keywords)
+                                               param
+                                               T))
+                                       lambda-list)
+                              ,return-type)
+                            ,name)))
+    #+kcl (setf (get name 'compiler::proclaimed-closure) t)))
+
+(defun proclaim-defgeneric (spec lambda-list)
+  (when (consp spec)
+    (setq spec (get-setf-function-name (cadr spec))))
+  (unless (function-ftype-declaimed-p spec)
+    (eval
+      `(declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list #+cmu spec)
+                       ,spec)))
+    #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
+
diff --git a/pcl/defcombin.lisp b/pcl/defcombin.lisp
index 7d1434526..2e60df97e 100644
--- a/pcl/defcombin.lisp
+++ b/pcl/defcombin.lisp
@@ -107,10 +107,19 @@
 	    :qualifiers ()
 	    :specializers specializers
 	    :lambda-list '(generic-function type options)
-	    :function #'(lambda (gf type options)
-			  (declare (ignore gf))
-			  (do-short-method-combination
-			    type options operator ioa new-method doc))
+            :function
+                #'(lambda (args next-methods)
+                    (declare (ignore next-methods))
+                    (apply #'(lambda (gf type options)
+		               (declare (ignore gf))
+		                 (do-short-method-combination
+		                   type options operator ioa new-method doc))
+                           args))
+	    :optimized-function
+                #'(lambda (gf type options)
+		    (declare (ignore gf))
+		      (do-short-method-combination
+		        type options operator ioa new-method doc))
 	    :definition-source `((define-method-combination ,type) ,truename)))
     (when old-method
       (remove-method #'find-method-combination old-method))
@@ -222,12 +231,23 @@
 	     :qualifiers ()
 	     :specializers specializers
 	     :lambda-list '(generic-function type options)
-	     :function #'(lambda (generic-function type options)
-			   (declare (ignore generic-function))
-			   (make-instance 'long-method-combination
-			     :type type
-			     :documentation doc
-			     :options options))
+	     :function
+               #'(lambda (args next-methods)
+                   (declare (ignore next-methods))
+                   (apply  #'(lambda (generic-function type options)
+		               (declare (ignore generic-function))
+		               (make-instance 'long-method-combination
+		                 :type type
+		                 :documentation doc
+		                 :options options))
+                           args))
+	     :optimized-function
+               #'(lambda (generic-function type options)
+		   (declare (ignore generic-function))
+		   (make-instance 'long-method-combination
+		     :type type
+		     :documentation doc
+		     :options options))
 	     :definition-source `((define-method-combination ,type)
 				  ,(load-truename)))))
     (setf (gethash type *long-method-combination-functions*) function)
@@ -237,18 +257,18 @@
 (defmethod compute-effective-method ((generic-function generic-function)
 				     (combin long-method-combination)
 				     applicable-methods)
-  (funcall (gethash (method-combination-type combin)
-		    *long-method-combination-functions*)
-	   generic-function
-	   combin
-	   applicable-methods))
+  (method-function-funcall (gethash (method-combination-type combin)
+		                    *long-method-combination-functions*)
+	                   generic-function
+	                   combin
+	                   applicable-methods))
 
 ;;;
 ;;;
 ;;;
 (defun make-long-method-combination-function
        (type ll method-group-specifiers arguments-option gf-var body)
-  ;;(declare (values documentation function))
+  (declare (values documentation function))
   (declare (ignore type))
   (multiple-value-bind (documentation declarations real-body)
       (extract-declarations body)
@@ -330,7 +350,7 @@
       ,@real-body)))
    
 (defun parse-method-group-specifier (method-group-specifier)
-  ;;(declare (values name tests description order required))
+  (declare (values name tests description order required))
   (let* ((name (pop method-group-specifier))
 	 (patterns ())
 	 (tests 
diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 054c81f91..692acdfee 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -147,7 +147,7 @@
     (name (fdefine-carefully name new-value))
     (name (fdefine-carefully (get-setf-function-name name) new-value))))
 
-
+
 (proclaim '(special *the-class-t* 
                     *the-class-vector* *the-class-symbol*
                     *the-class-string* *the-class-sequence*
@@ -170,10 +170,8 @@
                     *the-class-funcallable-standard-class*
                     *the-class-standard-method*
                     *the-class-standard-generic-function*
-                    *the-class-standard-effective-slot-definition*
-
-                    *the-eslotd-standard-class-slots*
-                    *the-eslotd-funcallable-standard-class-slots*))
+                    *the-class-standard-direct-slot-definition*
+                    *the-class-standard-effective-slot-definition*))
 
 (proclaim '(special *the-wrapper-of-t*
                     *the-wrapper-of-vector* *the-wrapper-of-symbol*
@@ -186,6 +184,7 @@
                     *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
 
 (defun coerce-to-class (class &optional make-forward-referenced-class-p)
+  (declare (type boolean make-forward-referenced-class-p))
   (if (symbolp class)
       (or (find-class class (not make-forward-referenced-class-p))
 	  (ensure-class class))
@@ -206,7 +205,7 @@
   (when (symbolp specl)
     (setq specl (find-class specl))) ;(or (find-class specl nil) (ensure-class specl))
   (cond ((consp specl)
-         (unless (member (car specl) '(class class-eq eql))
+         (unless (memq (car specl) '(class class-eq eql))
            (error "~S is not a legal specializer type" specl))
          specl)
         ((specializerp specl)
@@ -235,7 +234,7 @@
 (defun make-type-predicate (name)
   (let ((cell (find-class-cell name)))
     #'(lambda (x)
-	(funcall (the function (find-class-cell-predicate cell)) x))))
+	(funcall (the compiled-function (find-class-cell-predicate cell)) x))))
 
 
 ;This stuff isn't right.  Good thing it isn't used.
@@ -265,8 +264,6 @@
 (deftype eql (type-object)
   `(member ,type-object))
 
-
-
 ;;;
 ;;; These functions are a pale imitiation of their namesake.  They accept
 ;;; class objects or types where they should.
@@ -313,21 +310,25 @@
 	   (car type)
 	   type))))
 
+(declaim (ftype (function (T T) boolean) *typep))
 (defun *typep (object type)
   (setq type (*normalize-type type))
-  (cond ((member (car type) '(eql wrapper-eq class-eq class))
+  (cond ((memq (car type) '(eql wrapper-eq class-eq class))
          (specializer-applicable-using-type-p type `(eql ,object)))
         ((eq (car type) 'not)
          (not (*typep object (cadr type))))
         (t
          (typep object (convert-to-system-type type)))))
 
+#-kcl
+(declaim (ftype (function (T T) (values boolean boolean)) *subtypep))
 (defun *subtypep (type1 type2)
   (setq type1 (*normalize-type type1))
   (setq type2 (*normalize-type type2))
   (if (member (car type2) '(eql wrapper-eq class-eq class))
       (multiple-value-bind (app-p maybe-app-p)
           (specializer-applicable-using-type-p type2 type1)
+        (declare (type boolean app-p maybe-app-p))
         (values app-p (or app-p (not maybe-app-p))))
       (subtypep (convert-to-system-type type1)
 		(convert-to-system-type type2))))
@@ -357,6 +358,7 @@
   (eval `(deftype ,name () '(satisfies ,predicate))))
 
 (defun make-type-predicate-name (name &optional kind)
+  (when (null name) (error "This shouldn't happen."))
   (if (symbol-package name)
       (intern (format nil
 		      "~@[~A ~]TYPE-PREDICATE ~A ~A"
@@ -369,6 +371,7 @@
 			   kind
 			   (symbol-name name)))))
 
+
 
 
 (defvar *built-in-class-symbols* ())
@@ -433,60 +436,59 @@
 	       classes)))
 
 (defun make-class-predicate-name (name)
-  (intern (let ((*package* *the-pcl-package*))
-	    (format nil "~S class predicate" name))
-	  *the-pcl-package*))
+  (intern (format nil "~A class predicate" (symbol-name name))
+          (symbol-package name)))
 
-(defun plist-value (object name)
-  (getf (object-plist object) name))
+(defun plist-value (object name &optional default)
+  (getf (object-plist object) name default))
 
 (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
-  (if new-value
-      (setf (getf (object-plist object) name) new-value)
-      (progn
-        (remf (object-plist object) name)
-        nil)))
+  (setf (getf (object-plist object) name) new-value))
 
 
 
 (defvar *built-in-classes*
   ;;
   ;; name       supers     subs                     cdr of cpl
-  ;; prototype
+  ;; prototype	predicate-name
   '(;(t         ()         (number sequence array character symbol) ())
-    (number     (t)        (complex float rational) (t))
+    (number     (t)        (complex float rational) (t)
+     1		numberp)
     (complex    (number)   ()                       (number t)
-     #c(1 1))
+     #c(1 1)	complexp)
     (float      (number)   ()                       (number t)
-     1.0)
-    (rational   (number)   (integer ratio)          (number t))
+     1.0	floatp)
+    (rational   (number)   (integer ratio)          (number t)
+     1		rationalp)
     (integer    (rational) ()                       (rational number t)
-     1)
+     1		integerp)
     (ratio      (rational) ()                       (rational number t)
      1/2)
 
-    (sequence   (t)        (list vector)            (t))
-    (list       (sequence) (cons null)              (sequence t))
+    (sequence   (t)        (list vector)            (t)
+     nil	sequencep)
+    (list       (sequence) (cons null)              (sequence t)
+     ()		listp)
     (cons       (list)     ()                       (list sequence t)
-     (nil))
+     (nil)	consp)
     
 
     (array      (t)        (vector)                 (t)
-     #2A((NIL)))
+     #2A((NIL))	arrayp)
     (vector     (array
 		 sequence) (string bit-vector)      (array sequence t)
-     #())
+     #()	vectorp)
     (string     (vector)   ()                       (vector array sequence t)
-     "")
+     ""		stringp)
     (bit-vector (vector)   ()                       (vector array sequence t)
-     #*1)
+     #*1	bit-vector-p)
     (character  (t)        ()                       (t)
-     #\c)
+     #\c	characterp)
    
     (symbol     (t)        (null)                   (t)
-     symbol)
+     symbol	symbolp)
     (null       (symbol)   ()                       (symbol list sequence t)
-     nil)))
+     nil	null)))
 
 
 ;;;
@@ -524,74 +526,95 @@
 	:initform ()
 	:accessor object-plist)))
 
-(defclass documentation-mixin (plist-mixin)
-     ())
+(defclass documentation-mixin ()
+  ((documentation
+      :initform NIL
+      :initarg :documentation)))
 
 (defclass dependent-update-mixin (plist-mixin)
     ())
 
 ;;;
 ;;; The class CLASS is a specified basic class.  It is the common superclass
-;;; of any kind of class.  That is any class that can be a metaclass must
-;;; have the class CLASS in its class precedence list.
+;;; of any kind of class.  It holds all of the documented reader functions from
+;;; the AMOP.  Any class that can be a metaclass must have the class CLASS
+;;; in its class precedence list.
 ;;; 
-(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
-		 specializer)
-     ((name
-	:initform nil
-	:initarg  :name
-	:accessor class-name)
-      (class-eq-specializer
+(defclass class (documentation-mixin dependent-update-mixin
+                 definition-source-mixin specializer)
+     ((default-initargs
+        :reader class-default-initargs)
+      (direct-default-initargs
         :initform nil
-        :reader class-eq-specializer)
-      (direct-superclasses
-	:initform ()
-	:reader class-direct-superclasses)
+        :reader class-direct-default-initargs)
+      (direct-slots
+        :initform nil
+	:reader class-direct-slots)
       (direct-subclasses
-	:initform ()
+        :initform nil
 	:reader class-direct-subclasses)
-      (direct-methods
-	:initform (cons nil nil))
-      (predicate-name
+      (direct-superclasses
+        :initform nil
+	:reader class-direct-superclasses)
+      (finalized-p
         :initform nil
-	:reader class-predicate-name)))
+        :reader class-finalized-p)
+      (name
+	:initform nil
+	:initarg  :name
+	:reader class-name)
+      (class-precedence-list
+	:reader class-precedence-list)
+      (prototype
+        :reader class-prototype)
+      (slots
+	:reader class-slots)))
+
 
 ;;;
 ;;; The class PCL-CLASS is an implementation-specific common superclass of
 ;;; all specified subclasses of the class CLASS.
 ;;; 
 (defclass pcl-class (class)
-     ((class-precedence-list
-	:reader class-precedence-list)
+     ((cached-in-generic-functions
+        :initform ()
+        :reader class-cached-in-generic-functions)
       (can-precede-list
         :initform ()
 	:reader class-can-precede-list)
+      (class-eq-specializer
+        :initform nil
+        :reader class-eq-specializer)
+      (direct-methods
+	:initform (cons nil nil))
       (incompatible-superclass-list
         :initform ()
 	:accessor class-incompatible-superclass-list)
+      (internal-slotds
+        :reader class-internal-slotds
+        :documentation
+          "List of internal-slotd structure copies of class-slots (for optimization).")
       (wrapper
 	:initform nil
 	:reader class-wrapper)
-      (prototype
-	:initform nil
-	:reader class-prototype)))
+      (predicate-name
+        :initform nil
+	:reader class-predicate-name))
+      )
 
 (defclass slot-class (pcl-class)
-     ((direct-slots
-	:initform ()
-	:accessor class-direct-slots)
-      (slots
-        :initform ()
-	:accessor class-slots)))
+     ((side-effect-internal-slotds
+        :reader class-side-effect-internal-slotds
+        :documentation
+          "List of internal-slotd structure copies of class-slots whose initfunctions
+           may have side-effects (for optimization).")))
 
 ;;;
 ;;; The class STD-CLASS is an implementation-specific common superclass of
 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
 ;;; 
 (defclass std-class (slot-class)
-     ((no-of-instance-slots		    ;*** MOVE TO WRAPPER ***
-	:initform 0
-	:accessor class-no-of-instance-slots)))
+ ())
 
 (defclass standard-class (std-class)
      ())
@@ -604,16 +627,17 @@
 (defclass built-in-class (pcl-class) ())
 
 (defclass structure-class (slot-class)
-     ((defstruct-form
-        :initform ()
-	:accessor class-defstruct-form)
+     ((defstruct-conc-name
+        :initform nil
+        :reader class-defstruct-conc-name)
       (defstruct-constructor
         :initform nil
-	:accessor class-defstruct-constructor)
+	:reader class-defstruct-constructor)
       (from-defclass-p
         :initform nil
-	:initarg :from-defclass-p)))
-     
+	:initarg :from-defclass-p
+        :reader class-from-defclass-p)))
+
 
 (defclass specializer-with-object (specializer) ())
 
@@ -639,7 +663,7 @@
 ;;;
 ;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
 ;;;
-(defclass slot-definition (metaobject) 
+(defclass slot-definition (documentation-mixin metaobject) 
      ((name
 	:initform nil
 	:initarg :name
@@ -650,6 +674,7 @@
 	:accessor slot-definition-initform)
       (initfunction
 	:initform nil
+        :type     (or function null)
 	:initarg :initfunction
 	:accessor slot-definition-initfunction)
       (readers
@@ -668,13 +693,15 @@
 	:initform t
 	:initarg :type
 	:accessor slot-definition-type)
-      (documentation
-	:initform ""
-	:initarg :documentation)
       (class
         :initform nil
 	:initarg :class
-	:accessor slot-definition-class)))
+	:accessor slot-definition-class)
+      (initfunction-side-effect-free-p
+	:initform nil
+	:initarg :initfunction-side-effect-free-p
+	:accessor slot-definition-initfunction-side-effect-free-p)))
+
 
 (defclass standard-slot-definition (slot-definition)
   ((allocation
@@ -700,14 +727,23 @@
   ())
 
 (defclass effective-slot-definition (slot-definition)
-  ((reader-function ; #'(lambda (object) ...)
+  ((location ; nil, a fixnum, a cons: (slot-name . value)
+    :initform nil
+    :accessor slot-definition-location)
+   (reader-function ; #'(lambda (object) ...)
     :accessor slot-definition-reader-function)
    (writer-function ; #'(lambda (new-value object) ...)
     :accessor slot-definition-writer-function)
    (boundp-function ; #'(lambda (object) ...)
     :accessor slot-definition-boundp-function)
    (accessor-flags
-    :initform 0)))
+    :initform 0)
+   (internal-slotd
+    :initform NIL
+    :accessor slot-definition-internal-slotd
+    :documentation
+      "Internal-slotd structure with copies of slot-definition info
+       used for optimizations purposes.")))
 
 (defclass standard-direct-slot-definition (standard-slot-definition
 					   direct-slot-definition)
@@ -715,9 +751,7 @@
 
 (defclass standard-effective-slot-definition (standard-slot-definition
 					      effective-slot-definition)
-  ((location ; nil, a fixnum, a cons: (slot-name . value)
-    :initform nil
-    :accessor slot-definition-location)))
+  ())
 
 (defclass structure-direct-slot-definition (structure-slot-definition
 					    direct-slot-definition)
@@ -727,6 +761,39 @@
 					       effective-slot-definition)
   ())
 
+
+
+(defun slot-reader-undefined (object)
+  (error "slot reader-function undefined for ~S" object))
+
+(defun slot-writer-undefined (new-value object)
+  (declare (ignore new-value))
+  (error "slot writer-function undefined for ~S" object))
+
+(defun slot-boundp-undefined (object)
+  (error "slot boundp-function undefined for ~S" object))
+
+(defstruct (internal-slotd
+             (:print-function print-internal-slotd))
+ (name            NIL  :type symbol)
+ (slot-definition NIL)
+ (location        NIL)
+ (initargs        ()   :type list)
+ (initfunction    ()   :type (or function null))
+ (reader-function #'slot-reader-undefined :type compiled-function)
+ (writer-function #'slot-writer-undefined :type compiled-function)
+ (boundp-function #'slot-boundp-undefined :type compiled-function))
+
+#+akcl
+(si::freeze-defstruct 'internal-slotd)
+
+(defun print-internal-slotd (internal-slotd stream depth)
+  (declare (ignore depth))
+  (printing-random-thing (internal-slotd stream)
+    (format stream "internal-slotd ~S"
+            (internal-slotd-slot-definition internal-slotd))))
+
+
 (defparameter *early-class-predicates*
   '((specializer specializerp)
     (exact-class-specializer exact-class-specializer-p)
@@ -737,3 +804,4 @@
     (funcallable-standard-class funcallable-standard-class-p)
     (structure-class structure-class-p)
     (forward-referenced-class forward-referenced-class-p)))
+
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index 9e99c24cc..fad393bbc 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -50,6 +50,11 @@
 ;;;    loaded into the same world it was compiled in.
 ;;;
 
+#+pcl
+(when (boundp 'pcl::*boot-state*)
+  (warn "Lisp heap already had PCL package.  Renaming it to OLD-PCL.")
+  (rename-package "PCL" "OLD-PCL"))
+
 (in-package "PCL" :use (list (or (find-package :walker)
 				 (make-package :walker :use '(:lisp)))
 			     (or (find-package :iterate)
@@ -70,13 +75,18 @@
 ;;; 
 (defvar *the-pcl-package* (find-package :pcl))
 
-(defvar *pcl-system-date* "March 92 PCL (2a)")
+(defvar *pcl-system-date* "July 92 PCL (beta)")
+
+#+cmu
+(when (boundp 'ext::*herald-items*)
+  (setf (getf ext::*herald-items* :pcl)
+        `("    CLOS based on PCL version:  " ,*pcl-system-date*)))
 
-
 ;;;
 ;;; Various hacks to get people's *features* into better shape.
 ;;; 
 (eval-when (compile load eval)
+  
   #+(and Symbolics Lispm)
   (multiple-value-bind (major minor) (sct:get-release-version)
     (etypecase minor
@@ -146,7 +156,7 @@
   )
 
 
-
+
 ;;; Yet Another Sort Of General System Facility and friends.
 ;;;
 ;;; The entry points are defsystem and operate-on-system.  defsystem is used
@@ -279,7 +289,7 @@ and load your system with:
 	 #+(and Lucid PRISM)                 ("lisp"  . "abin")
 	 #+(and Lucid PA)                    ("lisp"  . "hbin")
 	 #+(and excl SPARC)                  ("cl"    . "sparc")
-	 #+(and excl m68k)                   ("cl"    . "m68k")
+	 #+(and excl m68k (not next))        ("cl"    . "m68k")
 	 #+excl                              ("cl"    . "fasl")
          #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
 	 #+HP-HPLabs                         ("l"     . "b")
@@ -410,7 +420,7 @@ and load your system with:
       (> (file-write-date (make-source-pathname (module-name module)))
          (file-write-date (make-binary-pathname (module-name module))))))
 
-(defun operation-transformations (name mode arg)
+(defun operation-transformations (name mode &optional arg)
   (let ((system (get-system name)))
     (unless system (error "Can't find system with name ~S." name))
     (let ((*system-directory* (funcall (car system)))
@@ -474,7 +484,14 @@ and load your system with:
 	   #'(lambda (m transforms)
 	       (declare (ignore transforms))
 	       (y-or-n-p "Load ~A?" (module-name m)))
-	   #'make-load-without-dependencies-transformation))))))
+	   #'make-load-without-dependencies-transformation))
+	(:compile-load
+	  ;; Compile any files that have changed and any other files
+	  ;; that require recompilation when another file has been
+	  ;; recompiled.  But if nothing requires compilation,
+          ;; then load the whole system.
+	  (make-compile-load-transformations
+	    modules))))))
 
 (defun true (&rest ignore)
   (declare (ignore ignore))
@@ -545,6 +562,18 @@ and load your system with:
 
     pathname))
 
+(defun make-compile-load-transformations (modules)
+  (let ((transforms (list nil)))
+    (dolist (m modules)
+      (when (compile-filter m transforms)
+        (make-compile-transformation m transforms)))
+    (if (cdr transforms)
+        (reverse (cdr transforms))
+        (make-transformations
+	    modules
+	    #'true
+	    #'make-load-transformation))))
+
 (defun system-source-files (name)
   (let ((system (get-system name)))
     (unless system (error "Can't find system with name ~S." name))
@@ -562,7 +591,7 @@ and load your system with:
       (mapcar #'(lambda (module)
 		  (make-binary-pathname (module-name module)))
 	      modules))))
-
+
 ;;; ***                SITE SPECIFIC PCL DIRECTORY                        ***
 ;;;
 ;;; *pcl-directory* is a variable which specifies the directory pcl is stored
@@ -584,6 +613,10 @@ and load your system with:
 ;;; ***                                                                   ***
 
 (defun load-truename (&optional (errorp nil))
+  #-(or Lispm excl Xerox (and dec vax common) LUCID akcl)
+  (declare (ignore errorp))
+  #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil
+  #+(or Lispm excl Xerox (and dec vax common) LUCID akcl)
   (flet ((bad-time ()
 	   (when errorp
 	     (error "LOAD-TRUENAME called but a file isn't being loaded."))))
@@ -597,8 +630,8 @@ and load your system with:
     ;; 3.0 it's in the LUCID-COMMON-LISP package.
     ;;
     #+LUCID (or lucid::*source-pathname* (bad-time))
-    #+akcl   si:*load-pathname*
-    #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil))
+    #+akcl   si:*load-pathname*))
+
 
 #-(or cmu Symbolics)
 (defvar *pcl-directory*
@@ -687,6 +720,7 @@ and load your system with:
    (slots       t                                   t (vector boot defs low cache fin))
    (init        t                                   t (vector boot defs low cache fin))
    (std-class   t                                   t (vector boot defs low cache fin slots))
+   (structure-class t                               t (vector boot defs low cache fin slots))
    (cpl         t                                   t (vector boot defs low cache fin slots))
    (braid       t                                   t (boot defs low fin cache))
    (fsc         t                                   t (defclass boot defs low fin cache))
@@ -699,6 +733,7 @@ and load your system with:
    (construct   t                                   t (defclass boot defs low))
    (env         t                                   t (defclass boot defs low fin))
    (compat      t                                   t ())
+   (extensions  t                                   t ())
    (precom1     (dlap)                              t (defs low cache fin dfun))
    (precom2     (dlap)                              t (defs low cache fin dfun))
    ))
@@ -753,8 +788,8 @@ and load your system with:
 	  (lisp-implementation-version)
 	  *features*))
 
-
-
+
+
 ;;;;
 ;;;
 ;;; This stuff is not intended for external use.
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
index 60b42fde5..d9c6b02ca 100644
--- a/pcl/dfun.lisp
+++ b/pcl/dfun.lisp
@@ -106,13 +106,15 @@ And so, we are saved.
 	      (cons (car generator-entry) (caar args-entry))
 	      (caddr args-entry)))))
 
+
+(declaim (ftype (function (T &rest T) real-function) get-dfun-constructor))
 (defun get-dfun-constructor (generator &rest args)
   (let* ((generator-entry (assq generator *dfun-constructors*))
 	 (args-entry (assoc args (cdr generator-entry) :test #'equal)))
     (if (null *enable-dfun-constructor-caching*)
-	(apply (symbol-function generator) args)
+	(apply-function (symbol-function generator) args)
 	(or (cadr args-entry)
-	    (let ((new (apply (symbol-function generator) args)))
+	    (let ((new (apply-function (symbol-function generator) args)))
 	      (if generator-entry
 		  (push (list (copy-list args) new nil) (cdr generator-entry))
 		  (push (list generator (list (copy-list args) new nil)) *dfun-constructors*))
@@ -127,6 +129,7 @@ And so, we are saved.
 	  (push (list generator (list args constructor system)) *dfun-constructors*)))))
 
 (defmacro precompile-dfun-constructors (&optional system)
+  #+excl (declare (ignore system))
   #+excl ()
   #-excl
   (let ((*precompiling-lap* t))
@@ -136,9 +139,11 @@ And so, we are saved.
 	     (dolist (args-entry (cdr generator-entry))
 	       (when (or (null (caddr args-entry))
 			 (eq (caddr args-entry) system))
+		 (when system (setf (caddr args-entry) system))
 		 (multiple-value-bind (closure-variables arguments 
 							 iregs vregs fvregs tregs lap)
-		     (apply (symbol-function (car generator-entry)) (car args-entry))
+		     (apply-function (symbol-function (car generator-entry))
+                                     (car args-entry))
 		   (gather1
 		     (make-top-level-form `(precompile-dfun-constructor 
 					    ,(car generator-entry))
@@ -201,6 +206,14 @@ And so, we are saved.
   (printing-random-thing (dfun-info stream)
     (format stream "~A" (type-of dfun-info))))
 
+(defstruct (no-methods
+	     (:constructor no-methods-dfun-info ())
+	     (:include dfun-info)))
+
+(defstruct (initial-dispatch
+	     (:constructor initial-dispatch-dfun-info ())
+	     (:include dfun-info)))
+
 (defstruct (dispatch
 	     (:constructor dispatch-dfun-info ())
 	     (:include dfun-info)))
@@ -276,7 +289,7 @@ And so, we are saved.
 
 (defmacro dfun-update (generic-function function &rest args)
   `(multiple-value-bind (dfun cache info)
-       (funcall ,function ,generic-function ,@args)
+       (funcall-function ,function ,generic-function ,@args)
      (update-dfun ,generic-function dfun cache info)))
 
 (defun accessor-miss-function (gf dfun-info)
@@ -289,10 +302,47 @@ And so, we are saved.
      #'(lambda (new arg)
 	 (declare (pcl-fast-call))
 	 (accessor-miss gf new arg dfun-info)))))
-
+
+
+(declaim (ftype (function (T T T T) (values function null T))
+		make-one-class-accessor-dfun))
+(declaim (ftype (function (T T T T T) (values function null T))
+		make-two-class-accessor-dfun))
+(declaim (ftype (function (T T T &optional T) (values function cache T))
+		make-one-index-accessor-dfun))
+(declaim (ftype (function (T T T T) (values function cache T))
+		make-final-one-index-accessor-dfun))
+(declaim (ftype (function (T T &optional T) (values function cache T))
+		make-n-n-accessor-dfun))
+(declaim (ftype (function (T T T) (values function cache T))
+		make-final-n-n-accessor-dfun))
+(declaim (ftype (function (T T &optional T) (values function (or cache null) T))
+		make-checking-dfun))
+(declaim (ftype (function (T T T T) (values function (or cache null) T))
+		make-final-checking-dfun))
+(declaim (ftype (function (T &optional T) (values function (or cache null) T))
+		make-caching-dfun))
+(declaim (ftype (function (T T T) (values function (or cache null) T))
+		make-final-caching-dfun))
+(declaim (ftype (function (T &optional T) (values function cache T))
+		make-constant-value-dfun))
+(declaim (ftype (function (T T T) (values function cache T))
+		make-final-constant-value-dfun))
+(declaim (ftype (function (T) (values function null T))
+		make-dispatch-dfun
+		make-final-dispatch-dfun))
+(declaim (ftype (function (T &optional T) (values function (or cache null) T))
+		make-final-dfun-internal))
+
+(declaim (ftype (function (T) boolean)
+		use-caching-dfun-p
+		use-dispatch-dfun-p))
+
 ;;;
 ;;; ONE-CLASS-ACCESSOR
 ;;;
+(declaim (ftype (function (T T T T) (values function null T))
+		make-one-class-accessor-dfun))
 (defun make-one-class-accessor-dfun (gf type wrapper index)
   (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
 	(dfun-info (one-class-dfun-info type index wrapper)))
@@ -306,6 +356,8 @@ And so, we are saved.
 ;;;
 ;;; TWO-CLASS-ACCESSOR
 ;;;
+(declaim (ftype (function (T T T T T) (values function null T))
+		make-two-class-accessor-dfun))
 (defun make-two-class-accessor-dfun (gf type w0 w1 index)
   (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
 	(dfun-info (two-class-dfun-info type index w0 w1)))
@@ -319,6 +371,8 @@ And so, we are saved.
 ;;;
 ;;; std accessors same index dfun
 ;;;
+(declaim (ftype (function (T T T &optional T) (values function cache T))
+		make-one-index-accessor-dfun))
 (defun make-one-index-accessor-dfun (gf type index &optional cache)
   (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
 	 (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
@@ -333,6 +387,8 @@ And so, we are saved.
      cache
      dfun-info)))
 
+(declaim (ftype (function (T T T T) (values function cache T))
+		make-final-one-index-accessor-dfun))
 (defun make-final-one-index-accessor-dfun (gf type index table)
   (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn)))
     (make-one-index-accessor-dfun gf type index cache)))				
@@ -341,6 +397,8 @@ And so, we are saved.
   (default-limit-fn nlines))
 
 
+(declaim (ftype (function (T T &optional T) (values function cache T))
+		make-n-n-accessor-dfun))
 (defun make-n-n-accessor-dfun (gf type &optional cache)
   (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
 	 (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
@@ -354,6 +412,8 @@ And so, we are saved.
      cache
      dfun-info)))
 
+(declaim (ftype (function (T T T) (values function cache T))
+		make-final-n-n-accessor-dfun))
 (defun make-final-n-n-accessor-dfun (gf type table)
   (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn)))
     (make-n-n-accessor-dfun gf type cache)))
@@ -362,8 +422,11 @@ And so, we are saved.
   (default-limit-fn nlines))
 
 (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache)
-  (let ((cache (or cache (get-cache nkeys valuep limit-fn
-				    (+ (hash-table-count table) 3)))))
+  (let ((cache
+          (or cache
+              (get-cache
+                 nkeys valuep limit-fn
+		 (the index (+ (the index (hash-table-count table)) 3))))))
     (maphash #'(lambda (classes value)
 		 (setq cache (fill-cache cache
 					 (class-wrapper classes)
@@ -376,10 +439,12 @@ And so, we are saved.
 ;;;
 ;;;
 ;;;
+
+
 (defun make-checking-dfun (generic-function function &optional cache)
   (unless cache
     (when (some #'(lambda (method)
-		    (method-function-closure-generator (method-function method)))
+		    (method-closure-generator method))
 		(generic-function-methods generic-function))
       (return-from make-checking-dfun (make-caching-dfun generic-function)))
     (when (use-dispatch-dfun-p generic-function)
@@ -388,6 +453,7 @@ And so, we are saved.
 	 (metatypes (arg-info-metatypes arg-info))
 	 (applyp (arg-info-applyp arg-info))
 	 (nkeys (arg-info-nkeys arg-info)))
+    (declare (type boolean applyp) (type index nkeys))
     (if (every #'(lambda (mt) (eq mt 't)) metatypes)
 	(values function nil (default-method-only-dfun-info))
 	(let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
@@ -432,6 +498,7 @@ And so, we are saved.
 	 (nkeys (arg-info-nkeys arg-info))
 	 (cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
 	 (dfun-info (caching-dfun-info cache)))
+    (declare (type boolean applyp) (type index nkeys))
     (values
      (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
 	      (cache-field cache) (cache-vector cache) 
@@ -454,6 +521,7 @@ And so, we are saved.
 (defun use-constant-value-dfun-p (gf)
   (let ((methods (generic-function-methods gf))
 	(default '(unknown)))
+    (declare (type list methods))
     (and (null (arg-info-applyp (gf-arg-info gf)))
 	 (compute-applicable-methods-emf-std-p gf)
 	 (< 1 (length methods))
@@ -462,9 +530,9 @@ And so, we are saved.
 			  (method-specializers method)))
 	       methods)
 	 (notany #'(lambda (method)
-		     (or (some #'eql-specializer-p (method-specializers method))
-			 (eq (getf (method-function-plist (method-function method))
-				   :constant-value default)
+		     (or (some #'eql-specializer-p
+			       (method-specializers method))
+			 (eq (plist-value method :constant-value default)
 			     default)))
 		methods))))
 
@@ -491,7 +559,7 @@ And so, we are saved.
     (make-constant-value-dfun generic-function cache)))
 
 (defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn
-							   classes-list new-class)
+					  classes-list new-class)
   (let* ((arg-info (gf-arg-info generic-function))
 	 (nkeys (arg-info-nkeys arg-info))
 	 (new-class (and new-class
@@ -503,6 +571,7 @@ And so, we are saved.
 	 (cache (if new-class
 		    (copy-cache (gf-dfun-cache generic-function))
 		    (get-cache nkeys (not (null valuep)) limit-fn 4))))
+      (declare (type index nkeys))
       (make-emf-cache generic-function valuep cache classes-list new-class)))
 
 (defun use-caching-dfun-p (gf)
@@ -514,6 +583,7 @@ And so, we are saved.
 	   (arg-info (gf-arg-info gf))
 	   (mt (arg-info-metatypes arg-info))
 	   (nreq (length mt)))
+      (declare (type list methods mt) (type index nreq))
       ;;Is there a position at which every specializer is eql or non-standard?
       (dotimes (i nreq nil)
 	(when (not (eq 't (nth i mt)))
@@ -521,10 +591,7 @@ And so, we are saved.
 	    (dolist (method methods)
 	      (let ((specl (nth i (method-specializers method))))
 		(when (and (not (eql-specializer-p specl))
-			   (let ((sclass (specializer-class specl)))
-			     (or (null (class-finalized-p sclass))
-				 (member *the-class-standard-object*
-					 (class-precedence-list sclass)))))
+                           (class-standard-p (specializer-class specl)))
 		  (setq some-std-class-specl-p t))))
 	    (unless some-std-class-specl-p
 	      (return-from use-dispatch-dfun-p t))))))))
@@ -539,11 +606,11 @@ And so, we are saved.
   (if *lazy-dispatch-dfun-compute-p*
       (values (let ((*lazy-dfun-compute-p* t))
 		(make-initial-dfun gf))
-	      nil nil)
+	      nil (initial-dispatch-dfun-info))
       (make-dispatch-dfun gf)))
 
 (defun before-precompile-random-code-segments ()
-  (dolist (gf (gfs-of-type 'dispatch))
+  (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
     (dfun-update gf #'make-dispatch-dfun)))
 
 (defvar *dfun-miss-gfs-on-stack* ())
@@ -557,10 +624,11 @@ And so, we are saved.
        (cache-miss-values ,gf ,args ',(cond (type 'accessor)
 					    (caching-p 'caching)
 					    (t 'checking)))
+     (declare (type boolean ,invalidp))
      (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
        (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
 	 ,@body))
-     (apply ,nfunction ,args)))
+     (method-function-apply ,nfunction ,args)))
 
 ;;;
 ;;; The dynamically adaptive method lookup algorithm is implemented is
@@ -606,8 +674,11 @@ And so, we are saved.
   (let ((methods (generic-function-methods gf)) type
 	(new-class *new-class*) (*new-class* nil))
     (cond ((null methods)
-	   #'(lambda (&rest args)
-	       (apply #'no-applicable-method gf args)))
+	   (values
+	    #'(lambda (&rest args)
+		(apply #'no-applicable-method gf args))
+	    nil
+	    (no-methods-dfun-info)))
 	  ((setq type (cond ((every #'standard-reader-method-p methods)
 			     'reader)
 			    ((every #'standard-writer-method-p methods)
@@ -615,11 +686,13 @@ And so, we are saved.
 	   (with-eq-hash-table (table)
 	     (multiple-value-bind (table all-index first second size no-class-slots-p)
 		 (make-accessor-table gf type table)
+               (declare (type boolean no-class-slots-p))
 	       (if table
-		   (cond ((= size 1)
+		   (cond ((= (the index size) 1)
 			  (let ((w (class-wrapper first)))
 			    (make-one-class-accessor-dfun gf type w all-index)))
-			 ((and (= size 2) (or (integerp all-index) (consp all-index)))
+			 ((and (= (the index size) 2)
+                               (or (integerp all-index) (consp all-index)))
 			  (let ((w0 (class-wrapper first))
 				(w1 (class-wrapper second)))
 			    (make-two-class-accessor-dfun gf type w0 w1 all-index)))
@@ -660,7 +733,7 @@ And so, we are saved.
       ;; information from the lexical variables bound above.
       ;; 
       (flet ((two-class (index w0 w1)
-	       (when (zerop (random 2)) (psetf w0 w1 w1 w0))
+	       (when (zerop (the index (random 2))) (psetf w0 w1 w1 w0))
 	       (dfun-update gf #'make-two-class-accessor-dfun ntype w0 w1 index))
 	     (one-index (index &optional cache)
 	       (dfun-update gf #'make-one-index-accessor-dfun ntype index cache))
@@ -674,13 +747,15 @@ And so, we are saved.
 	     (do-fill (update-fn)
 	       (let ((ncache (fill-cache cache wrappers nindex)))
 		 (unless (eq ncache cache)
-		   (funcall update-fn ncache)))))
+		   (funcall-function update-fn ncache)))))
 	(cond ((null ntype)
 	       (caching))
 	      ((or invalidp
 		   (null nindex)))
 	      ((not (or (std-instance-p object)
-			(fsc-instance-p object)))
+			(fsc-instance-p object)
+                        #+pcl-user-instances
+                        (user-instance-p object)))
 	       (caching))
 	      ((or (neq ntype otype) (listp wrappers))
 	       (caching))
@@ -742,7 +817,7 @@ And so, we are saved.
     (dfun-miss (generic-function args wrappers invalidp function nil nil t)
       (cond (invalidp)
 	    (t
-	     (let* ((value (getf (method-function-plist function) :constant-value))
+	     (let* ((value (method-constant-value (method-function-method function)))
 		    (ncache (fill-cache ocache wrappers value)))
 	       (unless (eq ncache ocache)
 		 (dfun-update generic-function
@@ -771,7 +846,8 @@ And so, we are saved.
 	 (cache (gf-dfun-cache gf)))
     (when cache
       (let ((size (cache-size cache)))
-	(when (>= size *minimum-cache-size-to-list*)
+        (declare (type index size))
+	(when (>= size (the index *minimum-cache-size-to-list*))
 	  (let ((a (assoc size dfun-list)))
 	    (unless a
 	      (push (setq a (list size)) dfun-list))
@@ -793,13 +869,13 @@ And so, we are saved.
 	 (a (assq sym dfun-count)))
     (unless a
       (push (setq a (list sym 0 nil)) dfun-count))
-    (incf (cadr a))
+    (setf (cadr a) (the index (1+ (the index (cadr a)))))
     (when cache
       (let* ((size (cache-size cache))
 	     (b (assoc size (third a))))
 	(unless b 
 	  (push (setq b (cons size 0)) (third a)))
-	(incf (cdr b))))))
+        (setf (cdr b) (the index (1+ (the index (cdr b)))))))))
 
 (defun count-all-dfuns ()
   (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil))
@@ -819,8 +895,9 @@ And so, we are saved.
   (values))
 
 (defun gfs-of-type (type)
+  (unless (consp type) (setq type (list type)))
   (let ((gf-list nil))
     (map-all-generic-functions #'(lambda (gf)
-				   (when (eq type (type-of (gf-dfun-info gf)))
+				   (when (memq (type-of (gf-dfun-info gf)) type)
 				     (push gf gf-list))))
     gf-list))
diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp
index 2624228ba..2627efef8 100644
--- a/pcl/dlap.lisp
+++ b/pcl/dlap.lisp
@@ -38,6 +38,8 @@
 
 
 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
+  (declare (type index   1-or-2-class)
+           (type boolean class-slot-p))
   (let ((instance nil)
 	(arglist  ())
 	(closure-variables ())
@@ -69,8 +71,20 @@
 		     (opcode :move (operand :arg instance) inst)   ;get the instance
 		     (opcode :std-instance-p inst 'std-instance)   ;if not either std-inst
 		     (opcode :fsc-instance-p inst 'fsc-instance)   ;or fsc-instance then
+                     #+pcl-user-instances
+		     (opcode :user-instance-p inst 'user-instance) ;if not either std-inst
 		     (opcode :go 'trap)				   ;we lose
 
+                     #+pcl-user-instances
+		     (opcode :label 'user-instance)
+                     #+pcl-user-instances
+		     (opcode :move (operand :user-wrapper inst) wrapper)
+                     #+pcl-user-instances
+		     (and slots
+			  (opcode :move (operand :user-slots inst) slots))
+                     #+pcl-user-instances
+		     (opcode :go 'have-wrapper)
+
 		     (opcode :label 'fsc-instance)
 		     (opcode :move (operand :fsc-wrapper inst) wrapper)
 		     (and slots
@@ -115,6 +129,7 @@
 
 
 (defun emit-one-index-readers (class-slot-p)
+  (declare (type boolean class-slot-p))
   (let ((arglist (list (dfun-arg-symbol 0))))
     (generating-lap '(field cache-vector mask size index miss-fn)
 		    arglist
@@ -135,6 +150,7 @@
 		    (and (null class-slot-p) (list slots)))))))
 
 (defun emit-one-index-writers (class-slot-p)
+  (declare (type boolean class-slot-p))
   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
     (generating-lap '(field cache-vector mask size index miss-fn)
 		    arglist
@@ -414,7 +430,12 @@
       hit)))
 
 (defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
-  (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
+  (declare (list wrappers))
+  (let ((cache-line-size (compute-line-size
+                           (if value
+                               (the index (1+ (the index (length wrappers))))
+                             (length wrappers)))))
+    (declare (type index cache-line-size))
     (with-lap-registers ((location index)
 			 (primary index)
 			 (cache-vector vector)
diff --git a/pcl/env.lisp b/pcl/env.lisp
index 8471207f2..336fd6893 100644
--- a/pcl/env.lisp
+++ b/pcl/env.lisp
@@ -35,16 +35,16 @@
 (defun pcl-arglist (function &rest other-args)
   (let ((defn nil))
     (cond ((and (fsc-instance-p function)
-		(generic-function-p function))
-	   (generic-function-pretty-arglist function))
-	  ((and (symbolp function)
-		(fboundp function)
-		(setq defn (symbol-function function))
-		(fsc-instance-p defn)
-		(generic-function-p defn))
-	   (generic-function-pretty-arglist defn))
-	  (t (apply (original-definition 'sys::arglist)
-		    function other-args)))))
+                (generic-function-p function))
+           (generic-function-pretty-arglist function))
+          ((and (symbolp function)
+                (fboundp function)
+                (setq defn (symbol-function function))
+                (fsc-instance-p defn)
+                (generic-function-p defn))
+           (generic-function-pretty-arglist defn))
+          (t (apply (original-definition 'sys::arglist)
+                    function other-args)))))
 
 (redefine-function 'sys::arglist 'pcl-arglist)
 
@@ -68,74 +68,95 @@
 
 (defmethod describe-object (object stream)
   (let ((*standard-output* stream))
-    (funcall (original-definition 'describe) object)))
+    (funcall-compiled (original-definition 'describe) object)))
 
 (redefine-function 'describe 'pcl-describe)
 
 )
 
 (defmethod describe-object ((object slot-object) stream)
-  (let* ((class (class-of object))
-	 (slotds (slots-to-inspect class object))
-	 (max-slot-name-length 0)
-	 (instance-slotds ())
-	 (class-slotds ())
-	 (other-slotds ()))
+  (format stream "~%~S is an instance of class ~S:" object (class-of object))
+  (describe-object-slots object stream))
+
+(defmethod describe-object-slots
+           ((object slot-object)
+            stream
+            &key
+            (slots-to-inspect (slots-to-inspect (class-of object) object))
+            &allow-other-keys)
+  "Display the value of all the slots-to-inspect on this object."
+  (let* ((max-slot-name-length 0)
+         (instance-slotds ())
+         (class-slotds ())
+         (other-slotds ()))
+    (declare (type index max-slot-name-length))
     (flet ((adjust-slot-name-length (name)
-	     (setq max-slot-name-length
-		   (max max-slot-name-length
-			(length (the string (symbol-name name))))))
-	   (describe-slot (name value &optional (allocation () alloc-p))
-	     (if alloc-p
-		 (format stream
-			 "~% ~A ~S ~VT  ~S"
-			 name allocation (+ max-slot-name-length 7) value)
-		 (format stream
-			 "~% ~A~VT  ~S"
-			 name max-slot-name-length value))))
+             (setq max-slot-name-length
+                   (the index
+                        (max max-slot-name-length
+                             (length (the simple-string
+                                          (symbol-name name)))))))
+           (describe-slot (name value &optional (allocation () alloc-p))
+             (if alloc-p
+                 (format stream
+                         "~% ~A ~S ~VT  "
+                         name allocation (+ max-slot-name-length 7))
+                 (format stream
+                         "~% ~A~VT  "
+                         name max-slot-name-length))
+             (prin1 value stream)))
+
       ;; Figure out a good width for the slot-name column.
-      (dolist (slotd slotds)
-	(adjust-slot-name-length (slot-definition-name slotd))
-	(case (slot-definition-allocation slotd)
-	  (:instance (push slotd instance-slotds))
-	  (:class  (push slotd class-slotds))
-	  (otherwise (push slotd other-slotds))))
-      (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
-      (format stream "~%~S is an instance of class ~S:" object class)
+      (dolist (slotd slots-to-inspect)
+        (adjust-slot-name-length (slot-definition-name slotd))
+        (case (slot-definition-allocation slotd)
+          (:instance (push slotd instance-slotds))
+          (:class  (push slotd class-slotds))
+          (otherwise (push slotd other-slotds))))
+      (setq max-slot-name-length
+            (the index (min (the index (+ max-slot-name-length 3)) 30)))
 
       (when instance-slotds
-	(format stream "~% The following slots have :INSTANCE allocation:")
-	(dolist (slotd (nreverse instance-slotds))
-	  (describe-slot (slot-definition-name slotd)
-			 (slot-value-or-default object (slot-definition-name slotd)))))
+        (format stream "~% The following slots have :INSTANCE allocation:")
+        (dolist (slotd (nreverse instance-slotds))
+          (describe-slot (slot-definition-name slotd)
+                         (slot-value-or-default
+                           object (slot-definition-name slotd)))))
 
       (when class-slotds
-	(format stream "~% The following slots have :CLASS allocation:")
-	(dolist (slotd (nreverse class-slotds))
-	  (describe-slot (slot-definition-name slotd)
-			 (slot-value-or-default object (slot-definition-name slotd)))))
-
-      (when other-slotds 
-	(format stream "~% The following slots have allocation as shown:")
-	(dolist (slotd (nreverse other-slotds))
-	  (describe-slot (slot-definition-name slotd)
-			 (slot-value-or-default object (slot-definition-name slotd))
-			 (slot-definition-allocation slotd))))
+        (format stream "~% The following slots have :CLASS allocation:")
+        (dolist (slotd (nreverse class-slotds))
+          (describe-slot (slot-definition-name slotd)
+                         (slot-value-or-default
+                            object (slot-definition-name slotd)))))
+
+      (when other-slotds
+        (format stream "~% The following slots have allocation as shown:")
+        (dolist (slotd (nreverse other-slotds))
+          (describe-slot (slot-definition-name slotd)
+                         (slot-value-or-default
+                           object (slot-definition-name slotd))
+                         (slot-definition-allocation slotd))))
       (values))))
 
 (defmethod slots-to-inspect ((class slot-class) (object slot-object))
   (class-slots class))
 
+(defvar *describe-generic-functions-as-objects-p* nil)
+
 (defmethod describe-object ((fun standard-generic-function) stream)
   (format stream "~A is a generic function.~%" fun)
   (format stream "Its arguments are:~%  ~S~%"
           (generic-function-pretty-arglist fun))
-  (format stream "Its methods are:")
-  (dolist (meth (generic-function-methods fun))
-    (format stream "~2%**** ~{~S ~}~:S =>~%"
-            (method-qualifiers meth)
-            (unparse-specializers meth))
-    (describe-object (method-function meth) stream)))
+  (if *describe-generic-functions-as-objects-p*
+      (describe-object-slots fun stream)
+      (progn
+        (format stream "Its methods are:")
+        (dolist (meth (generic-function-methods fun))
+          (format stream "~2%**** ~{~S ~}~:S =>~%"
+                  (method-qualifiers meth)
+                  (unparse-specializers meth))
+          (describe-object meth stream)))))
 
 ;;;
 ;;;
@@ -146,25 +167,77 @@
   (flet ((pretty-class (c) (or (class-name c) c)))
     (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
       (ft "~&~S is a class, it is an instance of ~S.~%"
-	  class (pretty-class (class-of class)))
+          class (pretty-class (class-of class)))
       (let ((name (class-name class)))
-	(if name
-	    (if (eq class (find-class name nil))
-		(ft "Its proper name is ~S.~%" name)
-		(ft "Its name is ~S, but this is not a proper name.~%" name))
-	    (ft "It has no name (the name is NIL).~%")))
+        (if name
+            (if (eq class (find-class name nil))
+                (ft "Its proper name is ~S.~%" name)
+                (ft "Its name is ~S, but this is not a proper name.~%" name))
+            (ft "It has no name (the name is NIL).~%")))
       (ft "The direct superclasses are: ~:S, and the direct~%~
-           subclasses are: ~:S.  The class precedence list is:~%~S~%~
-           There are ~D methods specialized for this class."
-	  (mapcar #'pretty-class (class-direct-superclasses class))
-	  (mapcar #'pretty-class (class-direct-subclasses class))
-	  (mapcar #'pretty-class (class-precedence-list class))
-	  (length (specializer-direct-methods class)))))
+           subclasses are: ~:S.  "
+          (mapcar #'pretty-class (class-direct-superclasses class))
+          (mapcar #'pretty-class (class-direct-subclasses class)))
+      (if (class-finalized-p class)
+          (ft "The class precedence list is:~%~S~%"
+              (mapcar #'pretty-class (class-precedence-list class)))
+          (ft "The class is not finalized.~%"))
+      (ft "There are ~D methods specialized for this class."
+          (length (the list (specializer-direct-methods class))))))
   (when *describe-classes-as-objects-p*
-    (call-next-method)))
-
+    (describe-object-slots class stream)))
+
+
+(declaim (ftype (function (T &optional T) (values T T symbol))
+		parse-method-or-spec))
+(defun parse-method-or-spec (spec &optional (errorp t))
+  (declare (values generic-function method method-name))
+  (let (gf method name temp)
+    (if (method-p spec) 
+        (setq method spec
+              gf (method-generic-function method)
+              temp (and gf (generic-function-name gf))
+              name (if temp
+                       (intern-function-name
+                         (make-method-spec temp
+                                           (method-qualifiers method)
+                                           (unparse-specializers
+                                             (method-specializers method))))
+                       (make-symbol (format nil "~S" method))))
+        (multiple-value-bind (gf-spec quals specls)
+            (parse-defmethod spec)
+          (declare (list quals specls))
+          (and (setq gf (and (or errorp (gboundp gf-spec))
+                             (gdefinition gf-spec)))
+               (let ((nreq (compute-discriminating-function-arglist-info gf)))
+                 (declare (type index nreq))
+                 (setq specls (append (parse-specializers specls)
+                                      (make-list (the index (- nreq (length specls)))
+                                                 :initial-element
+                                                 *the-class-t*)))
+                 (and 
+                   (setq method (get-method gf quals specls errorp))
+                   (setq name
+                         (intern-function-name (make-method-spec gf-spec
+                                                                 quals
+                                                                 specls))))))))
+    (values gf method name)))
+
+(defmethod copy-instance-slots ((object1 slot-object)
+                                (object2 slot-object)
+                                &key
+                                (exclude-slot-names NIL))
+  (let ((obj1-slot-names
+         (mapcar #'slot-definition-name (class-slots (class-of object1))))
+        (obj2-slot-names
+         (mapcar #'slot-definition-name (class-slots (class-of object2)))))
+    (declare (type list obj1-slot-names obj2-slot-names))
+    (dolist (slot-name obj1-slot-names)
+      (when (and (not (memq slot-name exclude-slot-names))
+                 (memq slot-name obj2-slot-names))
+        (setf (slot-value object2 slot-name)
+              (slot-value object1 slot-name))))))
 
-
 ;;;
 ;;; trace-method and untrace-method accept method specs as arguments.  A
 ;;; method-spec should be a list like:
@@ -186,66 +259,119 @@
 ;;; For untrace-method, if an argument is given, that method is untraced.
 ;;; If no argument is given, all traced methods are untraced.
 ;;;
-(defclass traced-method (method)
-     ((method :initarg :method)
-      (function :initarg :function
-		:reader method-function)
-      (generic-function :initform nil
-			:accessor method-generic-function)))
-
-(defmethod method-lambda-list ((m traced-method))
-  (with-slots (method) m (method-lambda-list method)))
-
-(defmethod method-specializers ((m traced-method))
-  (with-slots (method) m (method-specializers method)))
 
-(defmethod method-qualifiers ((m traced-method))
-  (with-slots (method) m (method-qualifiers method)))
-
-(defmethod method-qualifiers ((m traced-method))
-  (with-slots (method) m (method-qualifiers method)))
-
-(defmethod accessor-method-slot-name ((m traced-method))
-  (with-slots (method) m (accessor-method-slot-name method)))
+(defclass traced-method (standard-method)
+     ((method :initarg :method)))
 
 (defvar *traced-methods* ())
 
-(defun trace-method (spec &rest options)
-  (multiple-value-bind (gf omethod name)
+(defmethod trace-method ((spec cons) &rest options)
+  (multiple-value-bind (gf method name)
       (parse-method-or-spec spec)
-    (let* ((tfunction (trace-method-internal (method-function omethod)
-					     name
-					     options))
-	   (tmethod (make-instance 'traced-method
-				   :method omethod
-				   :function tfunction)))
-      (remove-method gf omethod)
-      (add-method gf tmethod)
-      (pushnew tmethod *traced-methods*)
-      tmethod)))
+    (declare (ignore gf name))
+    (apply #'trace-method method options)))
+
+(defmethod trace-method ((tmethod traced-method) &rest options)
+  (untrace-method tmethod)
+  (apply #'trace-method (slot-value tmethod 'method) options))
+
+(defmethod trace-method ((method standard-method) &rest options)
+  (let* ((gf        (method-generic-function method))
+         (base-name (symbol-name (method-function-name method)))
+         (tmethod   (make-instance 'traced-method :method method))
+         (function  (method-function method))
+         (t-function
+           (if function 
+                (trace-function-internal
+                 function (gentemp base-name) options)))
+         (optimized-fn (method-optimized-function method))
+         (t-optimized-fn
+           (if optimized-fn
+               (trace-function-internal
+                 optimized-fn (gentemp base-name) options)))
+         (traced-function-names
+           (append (if function     (list t-function))
+                   (if optimized-fn (list t-optimized-fn)))))
+    (declare (type simple-string base-name)
+             (type symbol        t-function t-optimized-fn))
+    (copy-instance-slots method tmethod
+                         :exclude-slot-names
+                         '(function optimized-function cached-functions-alist
+                           generic-function))
+    (when function
+      (setf (slot-value tmethod 'function)
+            (symbol-function t-function)))
+    (when optimized-fn
+      (setf (slot-value tmethod 'optimized-function)
+            (symbol-function t-optimized-fn)))
+    (setf (slot-value tmethod 'cached-functions-alist)
+          (mapcar
+            #'(lambda (cached-fn)
+                (let ((fn (cdr cached-fn)))
+                  (cons
+                    (car cached-fn)
+                    (symbol-function
+                      (the symbol
+                           (cond ((eq fn function) t-function)
+                                 ((eq fn optimized-fn) t-optimized-fn)
+                                 (T
+                                   (let ((t-name
+                                          (trace-function-internal
+                                            fn
+                                            (gentemp base-name)
+                                            options)))
+                                     (push t-name traced-function-names)
+                                     t-name))))))))
+            (slot-value method 'cached-functions-alist)))
+    (remove-method gf method)
+    (add-method gf tmethod)
+    (push (cons tmethod traced-function-names) *traced-methods*)
+    tmethod))
 
 (defun untrace-method (&optional spec)  
-  (flet ((untrace-1 (m)
-	   (let ((gf (method-generic-function m)))
-	     (when gf
-	       (remove-method gf m)
-	       (add-method gf (slot-value m 'method))
-	       (setq *traced-methods* (remove m *traced-methods*))))))
-    (if (not (null spec))
-	(multiple-value-bind (gf method)	    
-	    (parse-method-or-spec spec)
-	  (declare (ignore gf))
-	  (if (memq method *traced-methods*)
-	      (untrace-1 method)
-	      (error "~S is not a traced method?" method)))
-	(dolist (m *traced-methods*) (untrace-1 m)))))
-
-(defun trace-method-internal (ofunction name options)
+  (flet ((untrace-1 (method-cons-traces)
+           (let* ((m  (car method-cons-traces))
+                  (gf (method-generic-function m)))
+             (when gf
+               (remove-method gf m)
+               (add-method gf (slot-value m 'method))))
+           (untrace-method-function-names (cdr method-cons-traces))
+           (setq *traced-methods*
+                 (remove method-cons-traces *traced-methods* :test #'eq))))
+    (cond ((consp spec)
+           (multiple-value-bind (gf method)            
+               (parse-method-or-spec spec)
+             (declare (ignore gf))
+             (let ((old-trace (assq method *traced-methods*)))
+               (if old-trace
+                   (untrace-1 old-trace)
+                   (error "~S is not a traced method?" method)))))
+          ((typep spec 'standard-method)
+             (let ((old-trace (assq spec *traced-methods*)))
+               (if old-trace
+                   (untrace-1 old-trace)
+                   (error "~S is not a traced method?" spec))))
+          ((null spec)
+           (dolist (trace *traced-methods*) (untrace-1 trace)))
+          (T (error
+              "Untrace-method needs method, method specifier, or nothing.")))))
+
+(defun trace-function-internal (function name options)
   (eval `(untrace ,name))
-  (setf (symbol-function name) ofunction)
+  (setf (symbol-function name) function)
   (eval `(trace ,name ,@options))
-  (symbol-function name))
+  name)
+
+(defun untrace-method-function-names (names)
+  (dolist (name names)
+    (setf (symbol-function name) NIL))
+  (eval `(untrace ,@names)))
 
+(defun trace-methods (gf)
+  (let ((methods (generic-function-methods gf)))
+    (dolist (method methods)
+      (trace-method method))
+    methods))
 
 
 
@@ -272,3 +398,9 @@
 (pushnew :pcl *features*)
 (pushnew :portable-commonloops *features*)
 (pushnew :pcl-structures *features*)
+
+#+cmu
+(when (find-package "OLD-PCL")
+  (setf (symbol-function 'old-pcl::print-object)
+        (symbol-function 'pcl::print-object)))
+
diff --git a/pcl/excl-low.lisp b/pcl/excl-low.lisp
index 2252e64ef..a0361c485 100644
--- a/pcl/excl-low.lisp
+++ b/pcl/excl-low.lisp
@@ -43,6 +43,10 @@
 		  '(setq excl::*without-interrupts* 0)))
        ,.body)))
 
+(defmacro without-interrupts-simple (&body body)
+  `(let ((excl::*without-interrupts* 0))
+     ,.body))
+
 (eval-when (compile load eval)
   (unless (fboundp 'excl::sy_hash)
     (setf (symbol-function 'excl::sy_hash)
@@ -63,6 +67,12 @@
 		  (pop ,list-var)
 		  (go start))))))
 
+(defmacro structurep (x)
+  `(excl::structurep ,x))
+
+(defmacro structure-type (x)
+  `(svref ,x 0))
+
 (defun std-instance-p (x)
   (and (excl::structurep x)
        (locally
diff --git a/pcl/extensions.lisp b/pcl/extensions.lisp
new file mode 100644
index 000000000..32231cf41
--- /dev/null
+++ b/pcl/extensions.lisp
@@ -0,0 +1,496 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
+
+;;;
+;;; *************************************************************************
+;;;
+;;;   File: extensions.lisp.
+;;;
+;;;     by Trent E. Lange, Effective Date 04-23-92
+;;;
+;;;
+;;;  This file contains a small set of useful extensions to PCL. 
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify and distribute this document.
+;;;
+;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(eval-when (compile load eval)
+
+(defvar *extensions-exports*
+        '(set-standard-instance-access
+          set-funcallable-instance-access
+
+          funcallable-instance-slot-value
+          set-funcallable-instance-slot-value
+          funcallable-instance-slot-boundp
+          standard-instance-slot-value
+          set-standard-instance-slot-value
+          standard-instance-slot-boundp
+          structure-instance-slot-value
+          set-structure-instance-slot-value
+          structure-instance-slot-boundp
+
+          #+pcl-user-instances
+          user-instance-slot-value
+          #+pcl-user-instances
+          set-user-instance-slot-value
+          #+pcl-user-instances
+          user-instance-slot-boundp
+
+          with-optimized-slots
+          with-standard-instance-slots
+
+          method-needs-next-methods-p
+          map-all-classes
+          finalize-all-classes
+
+          updater
+          record-updater))
+)
+
+(defclass updater ()
+  ((dependent :initarg :dependent :reader dependent)))
+
+(defun record-updater (class dependee dependent &rest initargs)
+  (let ((updater
+         (apply #'make-instance class :dependent dependent initargs)))
+    (add-dependent dependee updater)
+    updater))
+
+
+(defun finalize-all-classes (&optional (root-name 't))
+  "Makes sure that all classes are finalized.  If Root-Name is supplied,
+   then finalizes Root-Name and all of its subclasses and their subclasses."
+  (map-all-classes #'(lambda (class)
+                       (unless (class-finalized-p class)
+                         (finalize-inheritance class)))
+                   root-name))
+
+
+;;;
+;;;
+;;;
+
+
+(defmacro slot-value-from-index (instance wrapper slot-name slots index)
+  "Returns instance's slot-value given slot-name's index."
+  (once-only (index)
+    `(if ,index
+         (let ((val (%svref ,slots ,index)))
+           (if (eq val ',*slot-unbound*)
+               (slot-unbound (wrapper-class ,wrapper) ,instance ,slot-name)
+             val))
+         (if *safe-to-use-slot-value-wrapper-optimizations-p*
+             (get-class-slot-value-1 ,instance ,wrapper ,slot-name)
+             (accessor-slot-value ,instance ,slot-name)))))
+
+(defmacro set-slot-value-from-index
+          (instance wrapper slot-name slots index new-value)
+  "Sets instance's slot-value to new-value given slot-name's index."
+  (once-only (index)
+    `(if ,index
+          (setf (%svref ,slots ,index) ,new-value)
+          (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
+              (set-class-slot-value-1 ,instance ,wrapper ,slot-name ,new-value)
+              (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
+
+(defsetf slot-value-from-index set-slot-value-from-index)
+
+(defmacro with-slots-slot-value-from-index
+          (instance wrapper slot-name slots index variable-instance)
+  "Returns instance's slot-value given slot-name's index."
+  (cond
+   ((consp wrapper)
+    `(let ((wrapper ,wrapper))
+       (unless (eq (wrapper-state wrapper) 't)
+         (setf wrapper (wrapper-state-trap wrapper ,instance)))
+       (with-slots-slot-value-from-index
+         ,instance wrapper ,slot-name ,slots ,index ,variable-instance)))
+   (variable-instance
+    `(let ((,instance ,variable-instance))
+       (with-slots-slot-value-from-index
+         ,instance ,wrapper ,slot-name ,slots ,index NIL)))
+   (T `(slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index))))
+
+(defmacro set-with-slots-slot-value-from-index
+          (instance wrapper slot-name slots index variable-instance new-value)
+  "Sets instance's slot-value to new-value given slot-name's index."
+  (cond
+   ((consp wrapper)
+    `(let ((wrapper ,wrapper))
+       (unless (eq (wrapper-state wrapper) 't)
+         (setf wrapper (wrapper-state-trap wrapper ,instance)))
+       (set-with-slots-slot-value-from-index
+         ,instance wrapper ,slot-name ,slots ,index ,variable-instance
+         ,new-value)))
+   (variable-instance
+    `(let ((,instance ,variable-instance))
+       (set-with-slot-slots-value-from-index
+         ,instance ,wrapper ,slot-name ,slots ,index NIL ,new-value)))
+   (T
+    `(setf (slot-value-from-index ,instance ,wrapper ,slot-name ,slots ,index)
+           ,new-value))))
+
+(defsetf with-slots-slot-value-from-index
+         set-with-slots-slot-value-from-index)
+
+(defmacro with-slots-slot-value-from-wrapper-and-slots
+    (instance slot-name wrapper slots-layout slots variable-instance)
+  (cond
+   (variable-instance
+    `(let ((,instance ,variable-instance))
+       (with-slots-slot-value-from-wrapper-and-slots
+         ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL)))
+   ((consp wrapper)
+    `(if *safe-to-use-slot-value-wrapper-optimizations-p*
+         (let ((wrapper ,wrapper))
+           (unless (eq (wrapper-state wrapper) 't)
+             (setf wrapper (wrapper-state-trap wrapper ,instance)))
+           (slot-value-from-wrapper-and-slots ,instance ,slot-name
+             wrapper ,slots-layout ,slots NIL))
+         (accessor-slot-value ,instance ,slot-name)))
+   (T
+    `(if *safe-to-use-slot-value-wrapper-optimizations-p*
+         (slot-value-from-wrapper-and-slots
+           ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL)
+         (accessor-slot-value ,instance ,slot-name)))))
+
+(defmacro set-with-slots-slot-value-from-wrapper-and-slots
+    (instance slot-name wrapper slots-layout slots variable-instance new-value)
+  (cond
+   (variable-instance
+    `(let ((,instance ,variable-instance))
+       (set-with-slots-slot-value-from-wrapper-and-slots
+         ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL ,new-value)))
+   ((consp wrapper)
+    `(if *safe-to-use-set-slot-value-wrapper-optimizations-p*
+         (let ((wrapper ,wrapper))
+           (unless (eq (wrapper-state wrapper) 't)
+             (setf wrapper (wrapper-state-trap wrapper ,instance)))
+           (setf (slot-value-from-wrapper-and-slots ,instance ,slot-name
+                    wrapper ,slots-layout ,slots NIL)
+                 ,new-value))
+         (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))
+   (T
+    `(if *safe-to-use-set-slot-value-wrapper-optimizations-p*
+         (setf (slot-value-from-wrapper-and-slots
+                 ,instance ,slot-name ,wrapper ,slots-layout ,slots NIL)
+               ,new-value)
+         (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
+
+(defsetf with-slots-slot-value-from-wrapper-and-slots
+         set-with-slots-slot-value-from-wrapper-and-slots)
+
+(defun tree-memq-p (item form)
+  (cond ((consp form)
+         (or (tree-memq-p item (car form))
+             (tree-memq-p item (cdr form))))
+        (T (eq item form)))) 
+
+(defmacro with-optimized-slots (slot-entries instance-form &body body)
+  "Optimized version of With-Slots that is faster because it factors out
+   functions common to all slot accesses on the instance.  It has two
+   extensions to With-Slots: (1) the second value of slot-entries are
+   evaluated as forms rather than considered to be hard slot-names, allowing
+   access of variable slot-names.  (2) if a :variable-instance keyword is
+   the first part of the body, then the instance-form is treated as a variable
+   form, which is always expected to return an instance of the same class.
+   The value of the keyword must be an instance that is the same class as
+   instance-form will always return."
+  ;;  E.g. (with-optimized-slots (foo-slot
+  ;;                         (foo-slot-accessor     'foo-slot)
+  ;;                         (variable-slot-accessor variable-slot))
+  ;;                        instance
+  ;;                        :instance-form (car instances-of-same-class)
+  ;;         (loop for instance in objects-of-same-class
+  ;;               as  variable-slot in variable-slots
+  ;;               collect (list foo-slot
+  ;;                             foo-slot-accessor
+  ;;                             variable-slot-accessor)))
+  ;;   ==> (loop for instance in objects-of-same-class
+  ;;             as  variable-slot in variable-slots
+  ;;             collect (list (slot-value instance 'foo-slot)
+  ;;                           (slot-value instance 'foo-slot)
+  ;;                           (slot-value instance variable-slot)))
+  (build-with-optimized-slots-form slot-entries instance-form body))
+
+(defmacro with-standard-instance-slots (slot-entries instance-form &body body)
+  "Optimized version of With-Slots that assumes that the instance-form
+   evaluates to a standard-instance.  The result is undefined if it does not.
+   With-standard-instance-slots is faster than With-Slots because it factors
+   out functions common to all slot accesses on the instance.  It has two
+   extensions to With-Slots: (1) the second value of slot-entries are
+   evaluated as forms rather than considered to be hard slot-names, allowing
+   access of variable slot-names.  (2) if a :variable-instance keyword is
+   the first part of the body, then the instance-form is treated as a variable
+   form, which is always expected to return an instance of the same class.
+   The value of the keyword must be an instance that is the same class as
+   instance-form will always return."
+  (build-with-optimized-slots-form slot-entries instance-form body 'std-instance))
+
+(defun build-with-optimized-slots-form (slot-entries instance-form body
+                                        &optional instance-type)
+  (let* ((variable-instance
+           (if (eq (car body) :variable-instance)
+               (prog1
+                 (cadr body)
+                 (setf body (cddr body)))))
+         (hard-accessors
+           (let ((collect NIL))
+             (dolist (slot-entry slot-entries (nreverse collect))
+               (when (and (symbolp slot-entry)
+                          (tree-memq-p slot-entry body))
+                 (push (cons slot-entry slot-entry) collect))
+               (when (and (consp slot-entry)
+                          (constantp   (second slot-entry))
+                          (tree-memq-p (car slot-entry) body))
+                 (push (cons (car slot-entry) (second (second slot-entry)))
+                       collect)))))
+         (variable-accessors
+           (let ((collect NIL))
+             (dolist (slot-entry slot-entries (nreverse collect))
+               (when (and (consp slot-entry)
+                          (not (constantp (second slot-entry)))
+                          (tree-memq-p (car slot-entry) body))
+                 (push slot-entry collect))))))
+    (if *safe-to-use-slot-wrapper-optimizations-p*
+        (build-maybe-safe-w-o-s-v hard-accessors variable-accessors
+                                  instance-form body variable-instance
+                                  instance-type)
+        (build-with-accessor-s-v  hard-accessors variable-accessors
+                                  instance-form body variable-instance))))
+
+(defun build-maybe-safe-w-o-s-v (hard-accessors variable-accessors
+                                 instance-form body variable-instance
+                                 instance-type)
+  (let* ((instance-string
+           (if (symbolp instance-form) (symbol-name instance-form) ""))
+         (instance-form-var
+           (if (and variable-instance (simple-eval-access-p instance-form))
+               instance-form
+             (gensym
+               (concatenate 'simple-string instance-string "-INSTANCE-FORM"))))
+         (prototype-form
+           (if variable-instance
+               (if (simple-eval-access-p variable-instance)
+                   variable-instance
+                 (gensym (concatenate 'simple-string "VARIABLE-INSTANCE"
+                                                     instance-string)))
+               instance-form-var))
+         (wrapper-var
+           (gensym (concatenate 'simple-string instance-string "-WRAPPER")))
+         (slots-var
+           (unless variable-instance
+             (gensym (concatenate 'simple-string instance-string "-SLOTS"))))
+         (type-var
+           (when (and variable-instance (not instance-type))
+             (gensym (concatenate 'simple-string instance-string "-TYPE"))))
+         (type-var-std 1)
+         (type-var-fsc 2)
+         #+pcl-user-instances
+         (type-var-user 3)
+         (slot-index-vars
+           (mapcar #'(lambda (slot-entry)
+                         (list (car slot-entry)
+                               (cdr slot-entry)
+                               (gensym (concatenate
+                                         'simple-string
+                                         (if (string= instance-string "")
+                                             "INSTANCE-FORM-"
+                                           instance-string)
+                                         (symbol-name (cdr slot-entry))
+                                         "-INDEX"))))
+                   (remove-duplicates hard-accessors :key #'cdr)))
+         (slots-layout-var
+           (gensym (concatenate 'simple-string "SLOTS-LAYOUT-" instance-string)))
+         (runtime-slots-form
+           (if variable-instance
+               (ecase instance-type
+                 (std-instance  `(std-instance-slots ,instance-form-var))
+                 (fsc-instance  `(fsc-instance-slots ,instance-form-var))
+                 #+pcl-user-instances
+                 (user-instance `(get-user-instance-slots ,instance-form-var))
+                 ((nil)
+                  `(case ,type-var
+                     (,type-var-std  (std-instance-slots ,instance-form-var))
+                     (,type-var-fsc  (fsc-instance-slots ,instance-form-var))
+                     #+pcl-user-instances
+                     (,type-var-user (get-user-instance-slots ,instance-form-var)))))
+                slots-var))
+         (runtime-wrapper-form
+           (if variable-instance
+               (ecase instance-type
+                 (std-instance  `(std-instance-wrapper ,instance-form-var))
+                 (fsc-instance  `(fsc-instance-wrapper ,instance-form-var))
+                 #+pcl-user-instances
+                 (user-instance `(get-user-instance-wrapper ,instance-form-var))
+                 ((nil)
+                  `(case ,type-var
+                     (,type-var-std  (std-instance-wrapper ,instance-form-var))
+                     (,type-var-fsc  (fsc-instance-wrapper ,instance-form-var))
+                     #+pcl-user-instances
+                     (,type-var-user (get-user-instance-wrapper ,instance-form-var)))))
+               wrapper-var)))
+    (declare (type simple-string instance-string)
+             (type list          slot-index-vars))
+    `(let (,@(unless variable-instance
+              `((,instance-form-var ,instance-form)))
+           ,@(when (and variable-instance
+                        (not (eq prototype-form variable-instance)))
+               `((,prototype-form ,variable-instance)))
+           ,wrapper-var ,slots-layout-var
+           ,@(if variable-instance
+                 (if type-var `((type-var 0)))
+                 (list slots-var))
+           ,@(mapcar #'third slot-index-vars))
+       ,@(when type-var `((declare (type index ,type-var))))
+       (when *safe-to-use-slot-wrapper-optimizations-p*
+         ,@(ecase instance-type
+             (std-instance
+              `((setf ,wrapper-var (std-instance-wrapper ,prototype-form))
+                ,@(unless variable-instance
+                   `((setf ,slots-var (std-instance-slots ,prototype-form))))))
+             (fsc-instance
+              `((setf ,wrapper-var (fsc-instance-wrapper ,prototype-form))
+                ,@(unless variable-instance
+                   `((setf ,slots-var (fsc-instance-slots ,prototype-form))))))
+             #+pcl-user-instances
+             (user-instance
+              `((setf ,wrapper-var (get-user-instance-wrapper ,prototype-form))
+                ,@(unless variable-instance
+                   `((setf ,slots-var (get-user-instance-slots ,prototype-form))))))
+             ((nil)
+             `((cond
+                ((std-instance-p ,prototype-form)
+                 (setf ,wrapper-var (std-instance-wrapper ,prototype-form))
+                 ,(if variable-instance
+                      `(setf ,type-var ,type-var-std)
+                    `(setf ,slots-var (std-instance-slots ,prototype-form))))
+                ((fsc-instance-p ,prototype-form)
+                 (setf ,wrapper-var (fsc-instance-wrapper ,prototype-form))
+                 ,(if variable-instance
+                      `(setf ,type-var ,type-var-fsc)
+                    `(setf ,slots-var (fsc-instance-slots ,prototype-form))))
+                #+pcl-user-instances
+                ((get-user-instance-p ,prototype-form)
+                 (setf ,wrapper-var (get-user-instance-wrapper ,prototype-form))
+                 ,(if variable-instance
+                      `(setf ,type-var ,type-var-user)
+                    `(setf ,slots-var (get-user-instance-slots ,prototype-form))))))))
+         ,@(if instance-type
+               (build-w-s-v-find-slot-indices wrapper-var slots-layout-var
+                  prototype-form slot-index-vars)
+               `((when ,wrapper-var
+                  ,@(build-w-s-v-find-slot-indices wrapper-var slots-layout-var
+                       prototype-form slot-index-vars)))))
+       (symbol-macrolet
+         (,@(mapcar
+              #'(lambda (slot-cons)
+                  `(,(car slot-cons)
+                     (with-slots-slot-value-from-index
+                        ,instance-form-var
+                        ,runtime-wrapper-form
+                        ',(cdr slot-cons)
+                        ,runtime-slots-form
+                        ,(third (assoc (car slot-cons) slot-index-vars
+                                       :test #'eq))
+                        ,(when (and variable-instance
+                                    (not (eq variable-instance
+                                             instance-form-var)))
+                           variable-instance))))
+              hard-accessors)
+          ,@(mapcar
+              #'(lambda (variable-cons)
+                  `(,(car variable-cons)
+                    (with-slots-slot-value-from-wrapper-and-slots
+                      ,instance-form-var
+                      ,(second variable-cons)
+                      ,runtime-wrapper-form
+                      ,slots-layout-var
+                      ,runtime-slots-form
+                      ,(when (and variable-instance
+                                  (not (eq variable-instance
+                                           instance-form-var)))
+                         variable-instance))))
+              variable-accessors))
+         ,@body))))
+
+(defun build-w-s-v-find-slot-indices (wrapper-var slots-layout-var
+                                      prototype-form
+                                      slot-index-vars)
+  (declare (type list slot-index-vars))
+  `((unless (eq (wrapper-state ,wrapper-var) 't)
+      (setf ,wrapper-var
+            (wrapper-state-trap ,wrapper-var ,prototype-form)))
+    (setf ,slots-layout-var (wrapper-instance-slots-layout ,wrapper-var))
+    ,@(if (<= (length slot-index-vars) 2)
+          (mapcar
+            #'(lambda (slot-cons)
+                `(setf ,(third slot-cons)
+                       (instance-slot-index-from-slots-layout
+                         ,slots-layout-var ',(second slot-cons))))
+            slot-index-vars)
+          ;; More than two slots, so more efficient to search slots-layout-var
+          ;; only once, rather than once for each with instance-slot-index.
+          (labels
+            ((build-comps (slot-vars index)
+               (if slot-vars
+                   `(if (eq slot-name ',(second (car slot-vars)))
+                        (progn
+                          (setf ,(third (car slot-vars)) ,index)
+                          (if (= matches ,(1- (length slot-index-vars)))
+                              (go end-loop)
+                            (setf matches (the fixnum (1+ matches)))))
+                     ,(build-comps (cdr slot-vars) index)))))
+            `((block nil
+                (let ((slots-left ,slots-layout-var)
+                      (slot-name  NIL)
+                      (index      0)
+                      (matches    0))
+                  (declare (type fixnum index matches))
+                  (when slots-left
+                    (tagbody
+                      begin-instance-slots-loop
+                        (setf slot-name (car slots-left))
+                        ,(build-comps slot-index-vars 'index)
+                        (setf index (the fixnum (1+ index)))
+                        (if (null (setf slots-left (cdr slots-left)))
+                            (go end-loop))
+                        (go begin-instance-slots-loop)
+                      end-loop)))))))))
+
+(defun build-with-accessor-s-v (hard-accessors variable-accessors
+                                instance-form body variable-instance)
+  ;; Build the body for with-optimized-slot-value when it is unsafe
+  ;; and accessor-slot-value must be used.
+  (let ((instance-form-var
+          (if variable-instance instance-form (gensym "INSTANCE-FORM"))))
+  `(let (,@(unless variable-instance
+            `((,instance-form-var ,instance-form))))
+     (symbol-macrolet
+       (,@(mapcar
+            #'(lambda (slot-cons)
+                `(,(car slot-cons)
+                  (accessor-slot-value ,instance-form-var
+                                       ',(cdr slot-cons))))
+            hard-accessors)
+        ,@(mapcar
+            #'(lambda (variable-cons)
+                `(,(car variable-cons)
+                  (accessor-slot-value ,instance-form-var
+                                       ,(second variable-cons))))
+            variable-accessors))
+       ,@body))))
+
+
+#-(or KCL IBCL)
+(export *extensions-exports* *the-pcl-package*)
+
+#+(or KCL IBCL)
+(mapc 'export (list *extensions-exports*) (list *the-pcl-package*))
+
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
index a675bbecc..645ad85e5 100644
--- a/pcl/fin.lisp
+++ b/pcl/fin.lisp
@@ -129,6 +129,8 @@ explicitly marked saying who wrote it.
   (error "Attempt to funcall a funcallable-instance without first~%~
           setting its funcallable-instance-function."))
 
+
+
 
 ;;;
 ;;; In Lucid Lisp, compiled functions and compiled closures have the same
@@ -158,7 +160,7 @@ explicitly marked saying who wrote it.
 ;;;  optimized version of the code for this inner closure function.
 ;;;
 (defun make-trampoline (function)
-  (declare (optimize (speed 3) (safety 0)))
+  (declare (optimize (speed 3) (safety 0)(compilation-speed 0)(space 0)))
   #'(lambda (&rest args)
       (apply function args)))
 
@@ -168,16 +170,17 @@ explicitly marked saying who wrote it.
 
 
 (defun binary-assemble (codes)
+  (declare (list codes))
   (let* ((ncodes (length codes))
 	 (code-vec #-LCL3.0 (lucid::new-code ncodes)
 		   #+LCL3.0 (lucid::with-current-area 
 				lucid::*READONLY-NON-POINTER-AREA*
 			      (lucid::new-code ncodes))))
-    (declare (fixnum ncodes))
+    (declare (type index ncodes))
     (do ((l codes (cdr l))
-	 (i 0 (1+ i)))
+	 (i 0 (the index (1+ i))))
 	((null l) nil)
-      (declare (fixnum i))
+      (declare (type index i))
       (setf (lucid::code-ref code-vec i) (car l)))
     code-vec))
 
@@ -221,8 +224,10 @@ explicitly marked saying who wrote it.
   (if (not (lucid::procedurep x))
       (error "Can't make a non-procedure a fin.")
       (setf (lucid::procedure-ref x lucid::procedure-flags)
-	    (logior (expt 2 procedure-is-funcallable-instance-bit-position)
-		    (the fixnum
+	    (logior (the index
+                         (expt 2 (the index
+                                      procedure-is-funcallable-instance-bit-position)))
+		    (the index
 			 (lucid::procedure-ref x lucid::procedure-flags))))))
 
 
@@ -233,13 +238,13 @@ explicitly marked saying who wrote it.
                                                 ;incorrectly
   (let ((new-fin (lucid::new-procedure fin-size))
 	(fin-index fin-size))
-    (declare (fixnum fin-index)
+    (declare (type index fin-index)
 	     (type lucid::procedure new-fin))
-    (dotimes (i (length funcallable-instance-data)) 
+    (dotimes (i (length (the list funcallable-instance-data)) )
       ;; Initialize the new funcallable-instance.  As part of our contract,
       ;; we have to make sure the initial value of all the funcallable
       ;; instance data slots is NIL.
-      (decf fin-index)
+      (setf fin-index (the index (1- fin-index)))
       (setf (lucid::procedure-ref new-fin fin-index) nil))
     ;;
     ;; "Assemble" the initial function by installing a fast "trampoline" code;
@@ -252,7 +257,7 @@ explicitly marked saying who wrote it.
     #+MIPS (progn
 	     (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
 	     (setf (sys:procedure-ref new-fin lucid::procedure-max-args) 
-		   call-arguments-limit))
+		   (the index call-arguments-limit)))
     ;; but start out with the function to be run as an error call.
     (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
 	  #'called-fin-without-function)
@@ -278,10 +283,10 @@ explicitly marked saying who wrote it.
 (defmacro funcallable-instance-data-1 (instance data)
   `(lucid::procedure-ref 
 	   ,instance
-	   (the fixnum
-		(- (- fin-size 1)
-		   (the fixnum (funcallable-instance-data-position ,data))))))
-  
+	   (the index
+		(- (the index (- (the index fin-size) 1))
+		   (the index (funcallable-instance-data-position ,data))))))
+
 );end of #+Lucid
 
 
@@ -357,7 +362,7 @@ explicitly marked saying who wrote it.
                                             (make-trampoline new-value)))))
 
 (defun make-trampoline (function)
-  (declare (optimize (speed 3) (safety 0)))
+  (declare #.*optimize-speed*)
   #'(lambda (&rest args)
       #+Genera (declare (dbg:invisible-frame :pcl-internals))
       (apply function args)))
@@ -881,7 +886,7 @@ dbg:
 ;; This function is never linked in and never appears on the stack.
 
 (defun funcallable-instance-mattress-pad ()
-  (declare (optimize (speed 3) (safety 0)))
+  (declare #.*optimize-speed*)
   'nil)
 
 (eval-when (eval)
@@ -1072,7 +1077,7 @@ dbg:
 ;; This function is never linked in and never appears on the stack.
 
 (defun funcallable-instance-mattress-pad ()
-  (declare (optimize (speed 3) (safety 0)))
+  (declare #.*optimize-speed*)
   'nil)
 
 (eval-when (eval)
@@ -1161,17 +1166,19 @@ dbg:
 (defun add-instance-vars (cvec old-cvec)
   ;; create a constant vector containing everything in the given constant
   ;; vector plus space for the instance variables
-  (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
+  (let* ((nconstants (cond (cvec (length (the simple-vector cvec))) (t 0)))
          (ndata (length funcallable-instance-data))
-         (old-cvec-length (if old-cvec (length old-cvec) 0))
+         (old-cvec-length (if old-cvec (length (the simple-vector old-cvec)) 0))
          (new-cvec nil))
-    (cond ((<= (+ nconstants ndata)  old-cvec-length)
+    (declare (fixnum nconstants ndate old-cvec-length))
+    (cond ((<= (the fixnum (+ nconstants ndata))  old-cvec-length)
            (setq new-cvec old-cvec))
           (t
-           (setq new-cvec (make-array (+ nconstants ndata)))
+           (setq new-cvec (make-array (the fixnum (+ nconstants ndata))))
            (when old-cvec
              (dotimes (i ndata)
-               (setf (svref new-cvec (- (+ nconstants ndata) i 1))
+               (declare (fixnum i))
+               (setf (svref new-cvec (- (the fixnum (+ nconstants ndata)) i 1))
                      (svref old-cvec (- old-cvec-length i 1)))))))
     
     (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
@@ -1180,8 +1187,11 @@ dbg:
 
 (defun funcallable-instance-data-1 (instance data)
   (let ((constant (excl::fn_constant instance)))
-    (svref constant (- (length constant)
-                       (1+ (funcallable-instance-data-position data))))))
+    (declare (simple-vector constant))
+    (svref constant (- (the fixnum (length constant))
+                       (the fixnum
+                            (1+ (the fixnum
+                                     (funcallable-instance-data-position data))))))))
 
 (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
 
@@ -1442,8 +1452,8 @@ dbg:
         ((not (functionp new-value))
          (error "~S is not a function." new-value))
         ((and (cclosurep new-value)
-              (<= (length (%cclosure-env new-value))
-                  funcallable-instance-available-size))
+              (<= (the index (length (the list (%cclosure-env new-value))))
+                  (the index funcallable-instance-available-size)))
          (%set-cclosure fin new-value funcallable-instance-available-size))
         (t
          (set-funcallable-instance-function
@@ -1456,12 +1466,14 @@ dbg:
   (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
                                 env))
          (index-form (if (constantp pos-form)
-                         (- funcallable-instance-closure-size
-                            (eval pos-form)
-                            2)
-                         `(- funcallable-instance-closure-size
-                             (funcallable-instance-data-position ,data)
-                             2))))
+                         (the index
+                              (- (the index funcallable-instance-closure-size)
+                                 (the index (eval pos-form))
+                                 2))
+                         `(the index
+                               (- (the index funcallable-instance-closure-size)
+                                  (the index (funcallable-instance-data-position ,data))
+                                  2)))))
     `(car (%cclosure-env-nthcdr ,index-form ,fin))))
 
 
@@ -1954,10 +1966,12 @@ make_turbo_trampoline_internal(base0)
 (defmacro fsc-instance-slots (fin)
   `(funcallable-instance-data-1 ,fin 'slots))
 
-(defun allocate-funcallable-instance (wrapper number-of-static-slots)
+(defun allocate-funcallable-instance (wrapper allocate-static-slot-storage-copy)
+  (declare (type simple-vector allocate-static-slot-storage-copy))
   (let ((fin (allocate-funcallable-instance-1))
         (slots
-          (%allocate-static-slot-storage--class number-of-static-slots)))
+          (%allocate-static-slot-storage--class
+            allocate-static-slot-storage-copy)))
     (setf (fsc-instance-wrapper fin) wrapper
           (fsc-instance-slots fin) slots)
     fin))
diff --git a/pcl/fixup.lisp b/pcl/fixup.lisp
index 0901b4e18..2ca36d380 100644
--- a/pcl/fixup.lisp
+++ b/pcl/fixup.lisp
@@ -39,4 +39,3 @@
   (print-object instance stream))
 
 
-
diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp
index c49a42e51..d5e97c8a5 100644
--- a/pcl/fngen.lisp
+++ b/pcl/fngen.lisp
@@ -42,14 +42,17 @@
 		      &optional (test-converter     #'default-test-converter)
 		                (code-converter     #'default-code-converter)
 				(constant-converter #'default-constant-converter))
-  (function-apply (get-function-generator lambda test-converter code-converter)
+  (apply-function (get-function-generator lambda test-converter code-converter)
 		  (compute-constants      lambda constant-converter)))
 
+(declaim (ftype (function (T &optional T T T) (values function T))
+                get-function1))
 (defun get-function1 (lambda
 		      &optional (test-converter     #'default-test-converter)
 		                (code-converter     #'default-code-converter)
 				(constant-converter #'default-constant-converter))
-  (values (the function (get-function-generator lambda test-converter code-converter))
+  (values (the function
+               (get-function-generator lambda test-converter code-converter))
 	  (compute-constants      lambda constant-converter)))
 
 (defun default-constantp (form)
@@ -61,10 +64,11 @@
       '.constant.
       form))
 
+(declaim (ftype (function (T) (values T list)) default-code-converter))
 (defun default-code-converter  (form)
   (if (default-constantp form)
       (let ((gensym (gensym))) (values gensym (list gensym)))
-      form))
+      (values form nil)))
 
 (defun default-constant-converter (form)
   (if (default-constantp form)
@@ -109,6 +113,10 @@
 	(fgen-generator fgen)
 	(get-new-function-generator lambda test code-converter))))
 
+(declaim (ftype (function (T T) (values T list))
+                get-new-function-generator-internal
+                compute-code))
+
 (defun get-new-function-generator (lambda test code-converter)
   (multiple-value-bind (gensyms generator-lambda)
       (get-new-function-generator-internal lambda code-converter)
@@ -124,17 +132,19 @@
 
 
 (defun compute-test (lambda test-converter)
-  (walk-form lambda
-	     nil
-	     #'(lambda (f c e)
-		 (declare (ignore e))
-		 (if (neq c :eval)
-		     f
-		     (let ((converted (funcall test-converter f)))
-		       (values converted (neq converted f)))))))
+  (let ((walk-form-expand-macros-p t))
+    (walk-form lambda
+	       nil
+	       #'(lambda (f c e)
+		   (declare (ignore e))
+		   (if (neq c :eval)
+		       f
+		       (let ((converted (funcall test-converter f)))
+			 (values converted (neq converted f))))))))
 
 (defun compute-code (lambda code-converter)
-  (let ((gensyms ()))
+  (let ((walk-form-expand-macros-p t)
+	(gensyms ()))
     (values (walk-form lambda
 		       nil
 		       #'(lambda (f c e)
@@ -148,21 +158,22 @@
 	      gensyms)))
 
 (defun compute-constants (lambda constant-converter)
-  (macrolet ((appending ()
-	       `(let ((result ()))
- 		  (values #'(lambda (value) (setq result (append result value)))
- 			  #'(lambda ()result)))))
-    (gathering1 (appending)
-      (walk-form lambda
-		 nil
-		 #'(lambda (f c e)
-		     (declare (ignore e))
-		     (if (neq c :eval)
-			 f
-			 (let ((consts (funcall constant-converter f)))
-			   (if consts
-			       (progn (gather1 consts) (values f t))
-			       f))))))))
+  (let ((walk-form-expand-macros-p t)) ; doesn't matter here.
+    (macrolet ((appending ()
+		 `(let ((result ()))
+		   (values #'(lambda (value) (setq result (append result value)))
+		    #'(lambda ()result)))))
+      (gathering1 (appending)
+		  (walk-form lambda
+			     nil
+			     #'(lambda (f c e)
+				 (declare (ignore e))
+				 (if (neq c :eval)
+				     f
+				     (let ((consts (funcall constant-converter f)))
+				       (if consts
+					   (progn (gather1 consts) (values f t))
+					   f)))))))))
 
 
 ;;;
@@ -175,6 +186,7 @@
 		(dolist (fgen *fgens*)
 		  (when (or (null (fgen-system fgen))
 			    (eq (fgen-system fgen) system))
+		    (when system (setf (svref fgen 4) system))
 		    (gather1
 		     `(load-function-generator
 		       ',(fgen-test fgen)
diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
index b8ec13df2..d2f3ab7ec 100644
--- a/pcl/fsc.lisp
+++ b/pcl/fsc.lisp
@@ -64,16 +64,47 @@
   (declare (ignore initargs))
   (unless (class-finalized-p class) (finalize-inheritance class))
   (let ((class-wrapper (class-wrapper class)))
-    (allocate-funcallable-instance class-wrapper
-				   (class-no-of-instance-slots class))))
+    (allocate-funcallable-instance
+      class-wrapper (wrapper-allocate-static-slot-storage-copy class-wrapper))))
 
-(defmethod make-reader-method-function ((class funcallable-standard-class)
-					slot-name)
-  (make-std-reader-method-function slot-name))
+(defmethod make-optimized-reader-method-function
+           ((class funcallable-standard-class)
+            generic-function
+            reader-method-prototype
+            slot-name)
+  (declare (ignore generic-function reader-method-prototype))
+  (make-funcallable-standard-instance-reader-method-function slot-name))
 
-(defmethod make-writer-method-function ((class funcallable-standard-class)
-					slot-name)
-  (make-std-writer-method-function slot-name))
+(defmethod make-optimized-writer-method-function
+           ((class funcallable-standard-class)
+            generic-function
+            writer-method-prototype
+            slot-name)
+  (declare (ignore generic-function writer-method-prototype))
+  (make-funcallable-standard-instance-writer-method-function slot-name))
+
+(defmethod make-optimized-boundp-method-function
+           ((class funcallable-standard-class)
+            generic-function
+            boundp-method-prototype
+            slot-name)
+  (declare (ignore generic-function boundp-method-prototype))
+  (make-funcallable-standard-instance-boundp-method-function slot-name))
+
+(defun make-funcallable-standard-instance-reader-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (funcallable-standard-instance-slot-value instance slot-name)))
+
+(defun make-funcallable-standard-instance-writer-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (nv instance)
+      (setf (funcallable-standard-instance-slot-value instance slot-name) nv)))
+
+(defun make-funcallable-standard-instance-boundp-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (funcallable-standard-instance-slot-boundp instance slot-name)))
 
 ;;;;
 ;;;; See the comment about reader-function--std and writer-function--sdt.
diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp
index cb9bf445f..74b2b47b7 100644
--- a/pcl/generic-functions.lisp
+++ b/pcl/generic-functions.lisp
@@ -3,41 +3,39 @@
 (in-package :pcl)
 
 ;;; 1 arguments 
-(defgeneric accessor-method-slot-name (m))
-(defgeneric |ARRAY class predicate| (object))
-(defgeneric |BIT-VECTOR class predicate| (object))
+(defgeneric accessor-method-slot-definition (method))
+(defgeneric accessor-method-slot-name (standard-accessor-method))
 (defgeneric |BUILT-IN-CLASS class predicate| (object))
-(defgeneric |CHARACTER class predicate| (object))
+(defgeneric class-cached-in-generic-functions (pcl-class))
 (defgeneric class-can-precede-list (pcl-class))
 (defgeneric class-constructors (class))
 (defgeneric class-default-initargs (class))
+(defgeneric class-defstruct-conc-name (structure-class))
 (defgeneric class-defstruct-constructor (structure-class))
-(defgeneric class-defstruct-form (structure-class))
 (defgeneric class-direct-default-initargs (class))
 (defgeneric class-direct-slots (class))
 (defgeneric class-direct-subclasses (class))
 (defgeneric class-direct-superclasses (class))
-(defgeneric class-eq-specializer (class))
+(defgeneric class-eq-specializer (pcl-class))
 (defgeneric class-eq-specializer-p (object))
 (defgeneric class-finalized-p (class))
+(defgeneric class-from-defclass-p (structure-class))
 (defgeneric class-incompatible-superclass-list (pcl-class))
+(defgeneric class-internal-slotds (pcl-class))
 (defgeneric class-name (class))
-(defgeneric class-no-of-instance-slots (std-class))
-(defgeneric class-precedence-list (pcl-class))
-(defgeneric class-predicate-name (class))
+(defgeneric class-precedence-list (class))
+(defgeneric class-predicate-name (pcl-class))
 (defgeneric class-prototype (class))
+(defgeneric class-side-effect-internal-slotds (slot-class))
 (defgeneric class-slot-cells (class))
 (defgeneric class-slots (class))
 (defgeneric class-wrapper (pcl-class))
 (defgeneric classp (object))
-(defgeneric |COMPLEX class predicate| (object))
 (defgeneric compute-class-precedence-list (root))
 (defgeneric compute-default-initargs (class))
 (defgeneric compute-discriminating-function (gf))
 (defgeneric compute-discriminating-function-arglist-info (generic-function))
 (defgeneric compute-slots (class))
-(defgeneric |CONS class predicate| (object))
-(defgeneric |CONSTRUCTOR class predicate| (object))
 (defgeneric constructor-class (constructor))
 (defgeneric constructor-code-generators (constructor))
 (defgeneric constructor-code-type (constructor))
@@ -45,6 +43,7 @@
 (defgeneric constructor-supplied-initarg-names (constructor))
 (defgeneric definition-source (definition-source-mixin))
 (defgeneric |DEFINITION-SOURCE-MIXIN class predicate| (object))
+(defgeneric dependent (updater))
 (defgeneric |DEPENDENT-UPDATE-MIXIN class predicate| (object))
 (defgeneric |DIRECT-SLOT-DEFINITION class predicate| (object))
 (defgeneric |DOCUMENTATION-MIXIN class predicate| (object))
@@ -53,11 +52,12 @@
 (defgeneric eql-specializer-p (object))
 (defgeneric exact-class-specializer-p (object))
 (defgeneric finalize-inheritance (class))
-(defgeneric |FLOAT class predicate| (object))
 (defgeneric forward-referenced-class-p (object))
 (defgeneric funcallable-standard-class-p (object))
 (defgeneric function-keywords (method))
-(defgeneric generic-function-lambda-list (gf))
+(defgeneric generic-function-argument-precedence-order (standard-generic-function))
+(defgeneric generic-function-declarations (standard-generic-function))
+(defgeneric generic-function-lambda-list (standard-generic-function))
 (defgeneric generic-function-method-class (standard-generic-function))
 (defgeneric generic-function-method-combination (standard-generic-function))
 (defgeneric generic-function-methods (standard-generic-function))
@@ -68,52 +68,55 @@
 (defgeneric gf-dfun-state (standard-generic-function))
 (defgeneric gf-pretty-arglist (standard-generic-function))
 (defgeneric gf-valid-p (standard-generic-function))
+(defgeneric initialize-allocate-static-slot-storage-copy (class))
 (defgeneric initialize-internal-slot-functions (slotd))
 (defgeneric install-lazy-constructor-installer (constructor))
-(defgeneric |INTEGER class predicate| (object))
-(defgeneric |LIST class predicate| (object))
-(defgeneric |LONG-METHOD-COMBINATION class predicate| (object))
 (defgeneric long-method-combination-function (long-method-combination))
+(defgeneric make-class-prototype (class))
 (defgeneric make-instances-obsolete (class))
 (defgeneric |METAOBJECT class predicate| (object))
+(defgeneric method-cached-functions (method))
+(defgeneric method-cached-functions-alist (standard-method))
 (defgeneric method-closure-generator (standard-method))
-(defgeneric method-combination-documentation (standard-method-combination))
 (defgeneric method-combination-options (standard-method-combination))
 (defgeneric method-combination-p (object))
 (defgeneric method-combination-type (standard-method-combination))
-(defgeneric method-function (traced-method))
+(defgeneric method-constant-value (method))
+(defgeneric method-function (standard-method))
 (defgeneric method-function-for-caching-p (method))
 (defgeneric method-function-name (standard-method))
-(defgeneric method-generic-function (traced-method))
-(defgeneric method-lambda-list (m))
+(defgeneric method-generic-function (standard-method))
+(defgeneric method-identifier (standard-method))
+(defgeneric method-lambda-list (standard-method))
+(defgeneric method-needs-next-methods-p (standard-method))
+(defgeneric method-optimized-function (standard-method))
+(defgeneric method-optimized-method-lambda (standard-method))
+(defgeneric method-optimized-slot-indices (standard-method))
 (defgeneric method-p (object))
 (defgeneric method-pretty-arglist (method))
-(defgeneric method-qualifiers (m))
-(defgeneric method-specializers (m))
-(defgeneric |NULL class predicate| (object))
-(defgeneric |NUMBER class predicate| (object))
+(defgeneric method-qualifiers (method))
+(defgeneric method-specializers (standard-method))
 (defgeneric object-plist (plist-mixin))
 (defgeneric |PCL-CLASS class predicate| (object))
 (defgeneric |PLIST-MIXIN class predicate| (object))
-(defgeneric |RATIO class predicate| (object))
-(defgeneric |RATIONAL class predicate| (object))
 (defgeneric raw-instance-allocator (class))
-(defgeneric |SEQUENCE class predicate| (object))
 (defgeneric short-combination-identity-with-one-argument (short-method-combination))
 (defgeneric short-combination-operator (short-method-combination))
 (defgeneric short-method-combination-p (object))
 (defgeneric |SLOT-CLASS class predicate| (object))
 (defgeneric |SLOT-DEFINITION class predicate| (object))
-(defgeneric slot-definition-allocation (slotd))
+(defgeneric slot-definition-allocation (standard-slot-definition))
 (defgeneric slot-definition-boundp-function (effective-slot-definition))
 (defgeneric slot-definition-class (slot-definition))
 (defgeneric slot-definition-defstruct-accessor-symbol (structure-slot-definition))
 (defgeneric slot-definition-initargs (slot-definition))
 (defgeneric slot-definition-initform (slot-definition))
 (defgeneric slot-definition-initfunction (slot-definition))
+(defgeneric slot-definition-initfunction-side-effect-free-p (slot-definition))
 (defgeneric slot-definition-internal-reader-function (structure-slot-definition))
+(defgeneric slot-definition-internal-slotd (effective-slot-definition))
 (defgeneric slot-definition-internal-writer-function (structure-slot-definition))
-(defgeneric slot-definition-location (standard-effective-slot-definition))
+(defgeneric slot-definition-location (effective-slot-definition))
 (defgeneric slot-definition-name (slot-definition))
 (defgeneric slot-definition-reader-function (effective-slot-definition))
 (defgeneric slot-definition-readers (slot-definition))
@@ -122,11 +125,11 @@
 (defgeneric slot-definition-writers (slot-definition))
 (defgeneric |SLOT-OBJECT class predicate| (object))
 (defgeneric slots-fetcher (class))
-(defgeneric specializer-class (class-eq-specializer))
+(defgeneric specializer-class (specializer))
 (defgeneric specializer-direct-generic-functions (specializer))
 (defgeneric specializer-direct-methods (specializer))
 (defgeneric specializer-method-table (specializer))
-(defgeneric specializer-object (eql-specializer))
+(defgeneric specializer-object (class-eq-specializer))
 (defgeneric specializer-type (specializer))
 (defgeneric |SPECIALIZER-WITH-OBJECT class predicate| (object))
 (defgeneric specializerp (object))
@@ -136,83 +139,19 @@
 (defgeneric |STANDARD-DIRECT-SLOT-DEFINITION class predicate| (object))
 (defgeneric |STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate| (object))
 (defgeneric standard-generic-function-p (object))
-(defgeneric |STANDARD-METHOD-COMBINATION class predicate| (object))
 (defgeneric standard-method-p (object))
 (defgeneric |STANDARD-OBJECT class predicate| (object))
 (defgeneric standard-reader-method-p (object))
 (defgeneric |STANDARD-SLOT-DEFINITION class predicate| (object))
 (defgeneric standard-writer-method-p (object))
 (defgeneric |STD-CLASS class predicate| (object))
-(defgeneric |STRING class predicate| (object))
 (defgeneric structure-class-p (object))
 (defgeneric |STRUCTURE-DIRECT-SLOT-DEFINITION class predicate| (object))
 (defgeneric |STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate| (object))
 (defgeneric |STRUCTURE-OBJECT class predicate| (object))
 (defgeneric |STRUCTURE-SLOT-DEFINITION class predicate| (object))
-(defgeneric |SYMBOL class predicate| (object))
-(defgeneric |T class predicate| (object))
-(defgeneric |TRACED-METHOD class predicate| (object))
 (defgeneric update-constructors (class))
-(defgeneric |VECTOR class predicate| (object))
 (defgeneric wrapper-fetcher (class))
-(defgeneric slot-accessor-name::|LISP FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|LISP TYPE slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL ACCESSOR-FLAGS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL ALLOCATION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL ARG-INFO slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL BOUNDP-FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CAN-PRECEDE-LIST slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CLASS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CLASS-EQ-SPECIALIZER slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CLASS-PRECEDENCE-LIST slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CLOSURE-GENERATOR slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CODE-GENERATORS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL CODE-TYPE slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DEFSTRUCT-ACCESSOR-SYMBOL slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DEFSTRUCT-CONSTRUCTOR slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DEFSTRUCT-FORM slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DFUN-STATE slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-METHODS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-SLOTS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-SUBCLASSES slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-SUPERCLASSES slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL DOCUMENTATION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL FROM-DEFCLASS-P slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL FUNCTION-NAME slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL GENERIC-FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL IDENTITY-WITH-ONE-ARGUMENT slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL INCOMPATIBLE-SUPERCLASS-LIST slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL INITARGS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL INITFORM slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL INITFUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL INTERNAL-READER-FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL INTERNAL-WRITER-FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL LAMBDA-LIST slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL LOCATION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL METHOD slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL METHOD-CLASS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL METHOD-COMBINATION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL METHODS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL NAME slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL NO-OF-INSTANCE-SLOTS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL OBJECT slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL OPERATOR slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL OPTIONS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL PLIST slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL PREDICATE-NAME slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL PRETTY-ARGLIST slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL PROTOTYPE slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL READER-FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL READERS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL SLOT-NAME slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL SLOTS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL SOURCE slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL SPECIALIZERS slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL SUPPLIED-INITARG-NAMES slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL VALID-P slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL WRAPPER slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL WRITER-FUNCTION slot READER| (slot-object))
-(defgeneric slot-accessor-name::|PCL WRITERS slot READER| (slot-object))
 
 ;;; 2 arguments 
 (defgeneric add-constructor (class constructor))
@@ -220,23 +159,20 @@
 (defgeneric add-direct-method (specializer method))
 (defgeneric add-direct-subclass (class subclass))
 (defgeneric add-method (generic-function method))
-(defgeneric change-class (instance new-class))
-(defgeneric (setf class-defstruct-constructor) (new-value structure-class))
-(defgeneric (setf class-defstruct-form) (new-value structure-class))
-(defgeneric (setf class-direct-slots) (new-value slot-class))
+(defgeneric cached-slot-locations-and-fetchers-from-wrappers (method wrappers))
+(defgeneric change-class (instance new-class-name))
 (defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
 (defgeneric (setf class-name) (new-value class))
-(defgeneric (setf class-no-of-instance-slots) (new-value std-class))
 (defgeneric class-slot-value (class slot-name))
-(defgeneric (setf class-slots) (new-value slot-class))
 (defgeneric compatible-meta-class-change-p (class proto-new-class))
 (defgeneric compute-applicable-methods (generic-function arguments))
 (defgeneric compute-applicable-methods-using-classes (generic-function classes))
+(defgeneric compute-class-slots (class eslotds))
 (defgeneric compute-constructor-code (class constructor))
-(defgeneric compute-effective-slot-definition (class dslotds))
 (defgeneric compute-effective-slot-definition-initargs (class direct-slotds))
+(defgeneric compute-instance-layout (class instance-eslotds))
+(defgeneric compute-storage-info (class eslotds))
 (defgeneric (setf constructor-code-type) (new-value constructor))
-(defgeneric default-initargs (class supplied-initargs))
 (defgeneric describe-object (class stream))
 (defgeneric direct-slot-definition-class (class initargs))
 (defgeneric effective-slot-definition-class (class initargs))
@@ -248,6 +184,7 @@
 (defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function))
 (defgeneric (setf gf-valid-p) (new-value standard-generic-function))
 (defgeneric inform-type-system-about-class (class name))
+(defgeneric legal-declarations-p (object x))
 (defgeneric legal-documentation-p (object x))
 (defgeneric legal-lambda-list-p (object x))
 (defgeneric legal-method-function-p (object x))
@@ -256,16 +193,17 @@
 (defgeneric legal-slot-name-p (object x))
 (defgeneric legal-specializer-p (object x))
 (defgeneric legal-specializers-p (object x))
-(defgeneric make-boundp-method-function (class slot-name))
-(defgeneric make-reader-method-function (class slot-name))
-(defgeneric make-writer-method-function (class slot-name))
+(defgeneric make-cached-method-function-from-stored-lambda (method slot-locations-and-fetchers))
+(defgeneric make-cached-method-lambda-from-stored-lambda (method slot-locations-and-fetchers))
 (defgeneric map-dependents (metaobject function))
 (defgeneric maybe-update-constructors (generic-function method))
+(defgeneric (setf method-cached-functions-alist) (new-value standard-method))
 (defgeneric method-function-for-caching (method wrappers))
 (defgeneric (setf method-function-name) (new-value standard-method))
-(defgeneric (setf method-generic-function) (new-value traced-method))
+(defgeneric (setf method-generic-function) (new-value standard-method))
+(defgeneric (setf method-optimized-function) (new-value standard-method))
 (defgeneric (setf object-plist) (new-value plist-mixin))
-(defgeneric print-object (instance stream))
+(defgeneric print-object (constructor stream))
 (defgeneric remove-boundp-method (class generic-function))
 (defgeneric remove-constructor (class constructor))
 (defgeneric remove-dependent (metaobject dependent))
@@ -284,9 +222,11 @@
 (defgeneric (setf slot-definition-initargs) (new-value slot-definition))
 (defgeneric (setf slot-definition-initform) (new-value slot-definition))
 (defgeneric (setf slot-definition-initfunction) (new-value slot-definition))
+(defgeneric (setf slot-definition-initfunction-side-effect-free-p) (new-value slot-definition))
 (defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition))
+(defgeneric (setf slot-definition-internal-slotd) (new-value effective-slot-definition))
 (defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition))
-(defgeneric (setf slot-definition-location) (location slotd))
+(defgeneric (setf slot-definition-location) (new-value effective-slot-definition))
 (defgeneric (setf slot-definition-name) (new-value slot-definition))
 (defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition))
 (defgeneric (setf slot-definition-readers) (new-value slot-definition))
@@ -295,103 +235,81 @@
 (defgeneric (setf slot-definition-writers) (new-value slot-definition))
 (defgeneric slots-to-inspect (class object))
 (defgeneric update-gf-dfun (class gf))
-(defgeneric validate-superclass (class new-super))
-(defgeneric slot-accessor-name::|PCL ACCESSOR-FLAGS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL ALLOCATION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL ARG-INFO slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL BOUNDP-FUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CAN-PRECEDE-LIST slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CLASS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CLASS-EQ-SPECIALIZER slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CLASS-PRECEDENCE-LIST slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CLOSURE-GENERATOR slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CODE-GENERATORS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL CODE-TYPE slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DEFSTRUCT-ACCESSOR-SYMBOL slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DEFSTRUCT-CONSTRUCTOR slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DEFSTRUCT-FORM slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DFUN-STATE slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-METHODS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-SLOTS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-SUBCLASSES slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DIRECT-SUPERCLASSES slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL DOCUMENTATION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL FROM-DEFCLASS-P slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL FUNCTION-NAME slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL GENERIC-FUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL IDENTITY-WITH-ONE-ARGUMENT slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL INCOMPATIBLE-SUPERCLASS-LIST slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL INITARGS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL INITFORM slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL INITFUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL INTERNAL-READER-FUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL INTERNAL-WRITER-FUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL LAMBDA-LIST slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL LOCATION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL METHOD slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL METHOD-CLASS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL METHOD-COMBINATION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL METHODS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL NAME slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL NO-OF-INSTANCE-SLOTS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL OBJECT slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL OPERATOR slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL OPTIONS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL PLIST slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL PREDICATE-NAME slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL PRETTY-ARGLIST slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL PROTOTYPE slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL READER-FUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL READERS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL SLOT-NAME slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL SLOTS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL SOURCE slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL SPECIALIZERS slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL SUPPLIED-INITARG-NAMES slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL VALID-P slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL WRAPPER slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL WRITER-FUNCTION slot WRITER| (new-value slot-object))
-(defgeneric slot-accessor-name::|PCL WRITERS slot WRITER| (new-value slot-object))
+(defgeneric validate-superclass (fsc class))
 
 ;;; 3 arguments 
-(defgeneric add-boundp-method (class generic-function slot-name))
-(defgeneric add-reader-method (class generic-function slot-name))
-(defgeneric add-writer-method (class generic-function slot-name))
 (defgeneric (setf class-slot-value) (nv class slot-name))
 (defgeneric compute-effective-method (generic-function combin applicable-methods))
+(defgeneric compute-effective-slot-definition (class name dslotds))
+(defgeneric compute-layout (class cpl instance-eslotds))
+(defgeneric default-initargs (class supplied-initargs all-default))
 (defgeneric find-method-combination (generic-function type options))
-(defgeneric (setf slot-accessor-function) (function slotd type))
 (defgeneric (setf slot-accessor-std-p) (value slotd type))
 (defgeneric slot-boundp-using-class (class object slotd))
 (defgeneric slot-exists-p-using-class (class object slotd))
 (defgeneric slot-makunbound-using-class (class object slotd))
-(defgeneric slot-unbound (class instance slot-name))
+(defgeneric slot-unbound (class class-instance slot-name))
 (defgeneric slot-value-using-class (class object slotd))
+(defgeneric store-closure-generator-p (generic-function method initargs))
+(defgeneric store-method-function-p (generic-function method initargs))
+(defgeneric store-method-optimized-function-p (generic-function method initargs))
+(defgeneric store-optimized-method-lambda-p (generic-function method initargs))
 
 ;;; 4 arguments 
 (defgeneric load-constructor-internal (class name initargs generators))
+(defgeneric make-closure-generator-form (generic-function method optimized-method-lambda initargs))
+(defgeneric make-documented-boundp-method-function (class generic-function boundp-method-prototype slot-name))
+(defgeneric make-documented-reader-method-function (class generic-function reader-method-prototype slot-name))
+(defgeneric make-documented-writer-method-function (class generic-function writer-method-prototype slot-name))
+(defgeneric make-method-lambda (generic-function method lambda-expression environment))
+(defgeneric make-optimized-boundp-method-function (class generic-function boundp-method-prototype slot-name))
+(defgeneric make-optimized-method-lambda (generic-function method lambda-expression environment))
+(defgeneric make-optimized-reader-method-function (class generic-function reader-method-prototype slot-name))
+(defgeneric make-optimized-writer-method-function (class generic-function writer-method-prototype slot-name))
 (defgeneric (setf slot-value-using-class) (new-value class object slotd))
 
 ;;; 5 arguments 
+(defgeneric compile-structure-class-internals (class direct-slots conc-name predicate-name constructor))
 (defgeneric make-constructor-code-generators (class name lambda-list supplied-initarg-names supplied-initargs))
 
+;;; 6 arguments 
+(defgeneric do-defstruct-from-defclass (class direct-superclasses direct-slots conc-name predicate constructor))
+
+;;; 8 arguments 
+(defgeneric optimize-instance-access (generic-function method parameter-class parameter slots read/write slot-name new-value))
+
 ;;; optional arguments  
+(defgeneric add-boundp-method (class generic-function slot-name &optional direct-slot))
+(defgeneric add-cached-function (method function slot-locations &optional slot-fetchers))
+(defgeneric add-reader-method (class generic-function slot-name &optional direct-slot))
+(defgeneric add-writer-method (class generic-function slot-name &optional direct-slot))
 (defgeneric documentation (object &optional doc-type))
 (defgeneric (setf documentation) (new-value object &optional doc-type))
-(defgeneric get-constructor (class name &optional (error-p t)))
-(defgeneric get-method (generic-function qualifiers specializers &optional (errorp t)))
+(defgeneric get-cached-function (method slot-locations &optional slot-fetchers))
+(defgeneric get-constructor (class name &optional error-p))
+(defgeneric get-method (generic-function qualifiers specializers &optional errorp))
 (defgeneric remove-named-method (generic-function-name argument-specifiers &optional extra))
 (defgeneric slot-missing (class instance slot-name operation &optional new-value))
+(defgeneric update-slot-accessor-function (slotd type function &optional update-accessors-p))
 
 ;;; keyword arguments  
 (defgeneric allocate-instance (class &rest initargs))
-(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys))
-(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key &allow-other-keys))
-(defgeneric initialize-instance (item &key))
-(defgeneric make-instance (class &rest initargs))
+(defgeneric boundp-method-class (class direct-slot &rest initargs))
+(defgeneric copy-instance-slots (object1 object2 &key exclude-slot-names))
+(defgeneric describe-object-slots (object stream &key slots-to-inspect &allow-other-keys))
+(defgeneric ensure-class-using-class (name class &rest args &key))
+(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key generic-function-class environment &allow-other-keys))
+(defgeneric initialize-instance (gf &key lambda-list argument-precedence-order))
+(defgeneric make-direct-slotd (class &rest initargs &key name conc-name defstruct-accessor-symbol &allow-other-keys))
+(defgeneric make-instance (class-name &rest initargs))
 (defgeneric no-applicable-method (generic-function &rest args))
-(defgeneric reinitialize-instance (instance &rest initargs))
-(defgeneric shared-initialize (instance slot-names &key))
+(defgeneric no-next-method (generic-function method &rest args))
+(defgeneric reader-method-class (class direct-slot &rest initargs))
+(defgeneric reinitialize-instance (gf &rest args &key lambda-list argument-precedence-order))
+(defgeneric shared-initialize (generic-function slot-names &key lambda-list argument-precedence-order))
+(defgeneric trace-method (method &rest options))
+(defgeneric update-dependent (meta-object dependent &rest initargs))
 (defgeneric update-instance-for-different-class (previous current &rest initargs))
 (defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs))
+(defgeneric writer-method-class (class direct-slot &rest initargs))
 
diff --git a/pcl/ibcl-low.lisp b/pcl/ibcl-low.lisp
index 2ab3f77ba..33a5bc782 100644
--- a/pcl/ibcl-low.lisp
+++ b/pcl/ibcl-low.lisp
@@ -73,6 +73,11 @@
     `(and (si:structurep ,x)
 	  (eq (si:structure-name ,x) 'std-instance))))
 
+(import 'si:structurep)
+
+(defmacro structure-type (x)
+  `(si:structure-name ,x))
+
 (dolist (inline '((si:structurep
 		    ((t) compiler::boolean nil nil "type_of(#0)==t_structure")
 		    compiler::inline-always)
diff --git a/pcl/init.lisp b/pcl/init.lisp
index 35467f187..3d57b1671 100644
--- a/pcl/init.lisp
+++ b/pcl/init.lisp
@@ -30,40 +30,47 @@
 
 (in-package 'pcl)
 
+(declaim (type boolean *check-initargs-p*))
 (defvar *check-initargs-p* nil)
 
 (defmacro checking-initargs (&body forms)
   `(when *check-initargs-p* ,@forms))
 
+(declaim (type boolean *making-instance-p*))
+(defvar *making-instance-p* nil)
+
 (defmethod make-instance ((class slot-class) &rest initargs)
+  (declare (list initargs))
   (unless (class-finalized-p class) (finalize-inheritance class))
-  (setq initargs (default-initargs class initargs))
-  (when initargs
-    (checking-initargs
+  (let ((class-default-initargs (class-default-initargs class)))
+    (when class-default-initargs
+      (setf initargs (default-initargs class initargs class-default-initargs)))
+    (when initargs
       (when (and (eq *boot-state* 'complete)
-		 (not (getf initargs :allow-other-keys)))
-	(check-initargs-1
-	 class initargs
-	 (append (compute-applicable-methods
-		  #'allocate-instance (list* class initargs))
-		 (compute-applicable-methods 
-		  #'initialize-instance (list* (class-prototype class) initargs))
-		 (compute-applicable-methods 
-		  #'shared-initialize (list* (class-prototype class) t initargs)))))))
-  (let ((instance (apply #'allocate-instance class initargs)))
-    (apply #'initialize-instance instance initargs)
-    instance))
+	         (not (getf initargs :allow-other-keys)))
+        (let ((class-proto (class-prototype class)))
+          (check-initargs-1
+  	    class initargs
+	    (append (compute-applicable-methods
+		      #'allocate-instance (list* class initargs))
+		    (compute-applicable-methods 
+		      #'initialize-instance (list* class-proto initargs))
+		    (compute-applicable-methods 
+		      #'shared-initialize (list* class-proto t initargs)))))))
+    (let* ((*making-instance-p* T)
+           (instance (apply #'allocate-instance class initargs)))
+      (apply #'initialize-instance instance initargs)
+      instance)))
 
 (defmethod make-instance ((class-name symbol) &rest initargs)
   (apply #'make-instance (find-class class-name) initargs))
 
 (defvar *default-initargs-flag* (list nil))
 
-(defmethod default-initargs ((class slot-class) supplied-initargs)
+(defmethod default-initargs ((class slot-class) supplied-initargs all-default)
   ;; This implementation of default initargs is critically dependent
   ;; on all-default-initargs not having any duplicate initargs in it.
-  (let ((all-default (class-default-initargs class))
-	(miss *default-initargs-flag*))
+  (let ((miss *default-initargs-flag*))
     (flet ((getf* (plist key)
 	     (do ()
 		 ((null plist) miss)
@@ -75,15 +82,34 @@
 		     nil
 		     (if (eq (getf* supplied-initargs (caar tail)) miss)
 			 (list* (caar tail)
-				(funcall (cadar tail))
+				(funcall-function (cadar tail))
 				(default-1 (cdr tail)))
 			 (default-1 (cdr tail))))))
 	(append supplied-initargs (default-1 all-default))))))
 
 
+(defmethod allocate-instance ((class standard-class) &rest initargs)
+  (declare (ignore initargs))
+  (unless (or *making-instance-p* (class-finalized-p class))
+    (finalize-inheritance class))
+  (let* ((class-wrapper (class-wrapper class))
+         (instance (%allocate-instance--class
+                     (wrapper-allocate-static-slot-storage-copy
+                       class-wrapper))))
+    (setf (std-instance-wrapper instance) class-wrapper)
+    instance))
+
+(defmethod allocate-instance ((class structure-class) &rest initargs)
+  (declare (ignore initargs))
+  (let ((constructor (class-defstruct-constructor class)))
+    (if constructor
+        (funcall-function (symbol-function constructor))
+        (error "Can't allocate an instance of class ~S" (class-name class)))))
+
 (defmethod initialize-instance ((instance slot-object) &rest initargs)
   (apply #'shared-initialize instance t initargs))
 
+
 (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
   (checking-initargs
     (when (and initargs (eq *boot-state* 'complete)
@@ -141,14 +167,16 @@
 
 (defmethod shared-initialize
 	   ((instance slot-object) slot-names &rest initargs)
+  (declare (list initargs))
+  (declare #.*optimize-speed*)
   ;;
   ;; initialize the instance's slots in a two step process
-  ;;   1) A slot for which one of the initargs in initargs can set
+  ;;   1. A slot for which one of the initargs in initargs can set
   ;;      the slot, should be set by that initarg.  If more than
   ;;      one initarg in initargs can set the slot, the leftmost
   ;;      one should set it.
   ;;
-  ;;   2) Any slot not set by step 1, may be set from its initform
+  ;;   2. Any slot not set by step 1, may be set from its initform
   ;;      by step 2.  Only those slots specified by the slot-names
   ;;      argument are set.  If slot-names is:
   ;;       T
@@ -161,38 +189,119 @@
   ;;       ()
   ;;            no slots are set from initforms
   ;;
-  (let* ((class (class-of instance))
-	 (slotds (class-slots class))
-	 (std-p (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)))
-	(unless (progn
-		  ;; Try to initialize the slot from one of the initargs.
-		  ;; If we succeed return T, otherwise return nil.
-		  (doplist (initarg val) initargs
-			   (when (memq initarg slot-initargs)
-			     (setf (slot-value-using-class class instance slotd) val)
-			     (return 't))))
-	  ;; Try to initialize the slot from its initform.
-	  (if (and slot-names
-		   (or (eq slot-names 't)
-		       (memq slot-name slot-names))
-		   (or (and (not std-p) (eq slot-names 't))
-		       (not (slot-boundp-using-class class instance slotd))))
-	      (let ((initfunction (slot-definition-initfunction slotd)))
-		(when initfunction
-		  (setf (slot-value-using-class class instance slotd)
-			(funcall initfunction)))))))))
-  instance)
+  (flet
+   ((init-safe (slots initing-internal-slotds)
+      (dolist (internal-slotd initing-internal-slotds)
+       (unless
+         (and
+           initargs
+           ;; Try to initialize the slot from one of the initargs.
+           (let ((slot-initargs (internal-slotd-initargs internal-slotd))
+                 (initargs-ptr  initargs))
+             (loop
+               (when (memq (car initargs-ptr) slot-initargs)
+                 (let ((location (internal-slotd-location internal-slotd)))
+                   (typecase location
+                     (fixnum (setf (%svref slots location)
+                                   (cadr initargs-ptr)))
+                     (cons   (setf (cdr location) (cadr initargs-ptr)))
+                     (T (method-function-funcall
+                          (internal-slotd-writer-function internal-slotd)
+                          (cadr initargs-ptr) instance))))
+                   (return 't))
+                 (when (null (setf initargs-ptr (cddr initargs-ptr)))
+                   (return)))))
+           ;; Try to initialize the slot from its initform.
+           (when (or (eq slot-names 't)
+                     (memq (internal-slotd-name internal-slotd) slot-names))
+             (let ((location (internal-slotd-location internal-slotd)))
+               (typecase location
+                 (fixnum
+                   (when (eq (%svref slots location) *slot-unbound*)
+                     (let ((initfn (internal-slotd-initfunction
+                                      internal-slotd)))
+                       (when initfn
+                         (setf (%svref slots location)
+                               (slot-initfunction-funcall initfn))))))
+                 (cons
+                   (when (eq (cdr location) *slot-unbound*)
+                     (let ((initfn (internal-slotd-initfunction
+                                     internal-slotd)))
+                       (when initfn
+                         (setf (cdr location)
+                                    (slot-initfunction-funcall initfn))))))
+                 (T
+                   (unless (method-function-funcall
+                             (internal-slotd-boundp-function internal-slotd)
+                             instance)
+                     (let ((initfn (internal-slotd-initfunction
+                                     internal-slotd)))
+                       (when initfn
+                         (method-function-funcall
+                           (internal-slotd-writer-function internal-slotd)
+                           (slot-initfunction-funcall initfn) instance)))))))))))
+
+    (init-unsafe (initing-internal-slotds)
+      (dolist (internal-slotd initing-internal-slotds)
+       (unless
+         (and
+           initargs
+           ;; Try to initialize the slot from one of the initargs.
+           (let ((slot-initargs (internal-slotd-initargs internal-slotd))
+                 (initargs-ptr  initargs))
+             (loop
+               (when (memq (car initargs-ptr) slot-initargs)
+                 (method-function-funcall
+                   (internal-slotd-writer-function internal-slotd)
+                   (cadr initargs-ptr) instance)
+                 (return 't))
+               (when (null (setf initargs-ptr (cddr initargs-ptr)))
+                 (return)))))
+           ;; Try to initialize the slot from its initform.
+           (when (or (eq slot-names 't)
+                     (memq (internal-slotd-name internal-slotd) slot-names))
+             (unless (method-function-funcall
+                       (internal-slotd-boundp-function internal-slotd)
+                       instance)
+               (let ((initfn (internal-slotd-initfunction internal-slotd)))
+                 (when initfn
+                   (method-function-funcall
+                     (internal-slotd-writer-function internal-slotd)
+                     (slot-initfunction-funcall initfn) instance)))))))))
+    
+    (when (or slot-names initargs)
+      (let ((initing-internal-slotds
+              (fast-slot-value (class-of instance)
+                               (if (and *making-instance-p* (null initargs))
+                                   'side-effect-internal-slotds
+                                   'internal-slotds))))
+      (if *safe-to-use-slot-wrapper-optimizations-p*
+          (cond
+            ((std-instance-p instance)
+             (fast-check-wrapper-validity instance std-instance-wrapper)
+             (init-safe (std-instance-slots instance) initing-internal-slotds))
+            ((fsc-instance-p instance)
+             (fast-check-wrapper-validity instance fsc-instance-wrapper)
+             (init-safe (fsc-instance-slots instance) initing-internal-slotds))
+            #+pcl-user-instances
+            ((user-instance-p instance)
+             (fast-check-wrapper-validity instance user-instance-wrapper)
+             (init-safe (user-instance-slots instance) initing-internal-slotds))
+            (T (init-unsafe initing-internal-slotds)))
+          (init-unsafe initing-internal-slotds))))
+    instance))
+
 
 
 ;;; 
 ;;; if initargs are valid return nil, otherwise signal an error
 ;;;
+
+(declaim (ftype (function (T) (values list boolean)) function-keywords))
+
 (defun check-initargs-1 (class initargs methods)
-  (let ((legal (apply #'append (mapcar #'slot-definition-initargs
-				       (class-slots class)))))
+  (let ((legal (apply #'append (mapcar #'internal-slotd-initargs
+				       (class-internal-slotds class)))))
     (unless nil ; (getf initargs :allow-other-keys) ; This is already checked.
       ;; Add to the set of slot-filling initargs the set of
       ;; initargs that are accepted by the methods.  If at
@@ -201,6 +310,7 @@
       (dolist (method methods)
 	(multiple-value-bind (keys allow-other-keys)
 	    (function-keywords method)
+          (declare (type boolean allow-other-keys))
 	  (when allow-other-keys
 	    (return-from check-initargs-1 nil))
 	  (setq legal (append keys legal))))
diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp
index d690a9537..57041e31e 100644
--- a/pcl/iterate.lisp
+++ b/pcl/iterate.lisp
@@ -307,6 +307,7 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's
                         let-body)
                  update-forms)
            (dolist (v vars)
+	       #-excl
                (declare (ignore v))
                                                ; Pop off the vars we have now
                                                ; bound from the list of vars
@@ -367,12 +368,13 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's
                          (eq (car binding-type)
                              'lambda)
                          (not (find-if #'(lambda (x)
-                                                (member x lambda-list-keywords)
+                                                (member x lambda-list-keywords
+                                                        :test #'eq)
                                                 )
                                      (setq let-bindings (second binding-type)))
                               )
-                         (eql (length (second expansion))
-                              (length let-bindings))
+                         (eql (length (the list (second expansion)))
+                              (length (the list let-bindings)))
                          (null (cddr expansion)))
                                                ; A simple LAMBDA form can be
                                                ; treated as LET
@@ -479,13 +481,13 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's
                                                  :abort))
                                          ((and (setq renaming (assoc form 
                                                                    renamed-vars
-                                                                     ))
+                                                                   :test #'eq))
                                                (variable-same-p form env 
                                                       iterate-env))
                                                ; Reference to one of the vars
                                                ; we're renaming
                                           (cdr renaming))
-                                         ((and (member form bound-vars)
+                                         ((and (member form bound-vars :test #'eq)
                                                (variable-same-p form env 
                                                       iterate-env))
                                                ; FORM is a var that is bound
@@ -590,7 +592,7 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's
                  (consp (setq body (cdr form)))
                  (listp (setq args (car body)))
                  (or (null nargs)
-                     (eql (length args)
+                     (eql (length (the list args))
                           nargs))
                  form)))
 
@@ -663,7 +665,7 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's
                        (declare (ignore context))
                        (let (pair)
                             (cond ((and (symbolp form)
-                                        (setq pair (assoc form alist))
+                                        (setq pair (assoc form alist :test #'eq))
                                         (variable-same-p form subenv env))
                                    (cdr pair))
                                   (t form))))))
@@ -1068,11 +1070,11 @@ NIL => never; :USER => those resulting from user code; T => always, even if it's
                                                ; non-variable or one that has
                                                ; been rebound
                                         form)
-                                       ((setq pair (assoc form alist))
+                                       ((setq pair (assoc form alist :test #'eq))
                                                ; One to rename
                                         (cdr pair))
                                        (t      ; var is free
-                                          (pushnew form closed)
+                                          (pushnew form closed :test #'eq)
                                           form)))))
                   closed)))
 
diff --git a/pcl/kcl-low.lisp b/pcl/kcl-low.lisp
index 14813a513..281ff6b6e 100644
--- a/pcl/kcl-low.lisp
+++ b/pcl/kcl-low.lisp
@@ -30,6 +30,7 @@
           %compiled-function-name
           %set-compiled-function-name))
 (in-package 'pcl)
+(import 'si:structurep)
 
 (shadow 'lisp:dotimes)
 
@@ -143,6 +144,11 @@
 
 )
 
+(defun function-ftype-declaimed-p (name)
+  "Returns whether the function given by name already has its ftype declaimed."
+  (get name 'compiler::proclaimed-function))
+
+
 ;;;
 ;;; turbo-closure patch.  See the file kcl-mods.text for details.
 ;;;
@@ -200,7 +206,7 @@ int n; object cc;
     (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
     
     (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
-  
+
 (defun make-function-inline (inline)
   (setf (get (car inline) 'compiler::inline-always)
         (list (if (fboundp 'compiler::flags)
@@ -245,7 +251,7 @@ int n; object cc;
   (declare (ignore ignore))
   (cond ((compiled-function-p fn)
 	 (si::turbo-closure fn)
-	 (when (symbolp new-name) (proclaim-defgeneric new-name nil))
+	 (when (symbolp new-name) (proclaim-closure new-name))
          (setf (si:%compiled-function-name fn) new-name))
         ((and (listp fn)
               (eq (car fn) 'lambda-block))
@@ -257,6 +263,13 @@ int n; object cc;
   fn)
 
 
+(defun proclaim-closure (spec)
+  (when (consp spec)
+    (setq spec (get-setf-function-name (cadr spec))))
+  (unless (function-ftype-declaimed-p spec)
+    #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
+
+
 #+akcl (clines "#define AKCL206") 
 
 (clines "
@@ -291,24 +304,12 @@ object set_cclosure (result_cc,value_cc,available_size)
 (defentry %set-cclosure (object object int) (object set_cclosure))
 
 
-(defun structure-functions-exist-p ()
-  t)
-
-(si:define-compiler-macro structure-instance-p (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (not (eq (si:%structure-name ,x) 'std-instance)))))
-
-(defun structure-type (x)
-  (and (si:structurep x)
-       (si:%structure-name x)))
+(pushnew :structure-functions *features*)
 
-(si:define-compiler-macro structure-type (x)
-  (once-only (x)
-    `(and (si:structurep ,x)
-          (si:%structure-name ,x))))
+(defmacro structure-type (x)
+  `(si:%structure-name (the structure ,x)))
 
-(defun structure-type-p (type)
+(defun known-structure-type-p (type)
   (or (not (null (gethash type *structure-table*)))
       (let (#+akcl(s-data nil))
         (and (symbolp type)
@@ -319,7 +320,9 @@ object set_cclosure (result_cc,value_cc,available_size)
 
 (defun structure-type-included-type-name (type)
   (or (car (gethash type *structure-table*))
-      #+akcl (si::s-data-included (get type 'si::s-data))
+      #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data))))
+	       (when includes
+		 (si::s-data-name includes)))
       #-akcl (get type 'si::structure-include)))
 
 (defun structure-type-internal-slotds (type)
@@ -409,4 +412,4 @@ object set_cclosure (result_cc,value_cc,available_size)
     (format st "~%")
     ))
 
-	
+
diff --git a/pcl/kcl-patches.lisp b/pcl/kcl-patches.lisp
index fffaa469c..3d94b9420 100644
--- a/pcl/kcl-patches.lisp
+++ b/pcl/kcl-patches.lisp
@@ -34,6 +34,149 @@
   (pushnew :pre_akcl_610 *features*))
 )
 
+#+akcl
+(progn
+
+;There is a bug in the implementation of *print-circle* that
+;causes some akcl debugging commands (including :bt and :bl)
+;to cause the following error when PCL is being used:
+;Unrecoverable error: value stack overflow.
+
+;When a CLOS object is printed, travel_push_object ends up
+;traversing almost the whole class structure, thereby overflowing
+;the value-stack.
+
+;from lsp/debug.lsp.
+;*print-circle* is badly implemented in kcl.
+;it has two separate problems that should be fixed:
+;  1. it traverses the printed object putting all objects found
+;     on the value stack (rather than in a hash table or some
+;     other structure; this is a problem because the size of the value stack
+;     is fixed, and a potentially unbounded number of objects
+;     need to be traversed), and
+;  2. it blindly traverses all slots of any
+;     kind of structure including std-object structures.
+;     This is safe, but not always necessary, and is very time-consuming
+;     for CLOS objects (because it will always traverse every class).
+
+;For now, avoid using *print-circle* T when it will cause problems.
+
+(eval-when (compile eval)
+(defmacro si::f (op &rest args)
+    `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
+
+(defmacro si::fb (op &rest args)
+    `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
+)
+
+(defun si::display-env (n env)
+  (do ((v (reverse env) (cdr v)))
+      ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
+    (or (and (consp (car v))
+	     (listp (cdar v)))
+	(return))
+    (let ((*print-circle* (can-use-print-circle-p (cadar v))))
+      (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))
+
+(defun si::display-compiled-env ( plength ihs &aux
+				      (base (si::ihs-vs ihs))
+				      (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
+  (format si::*display-string* "")
+  (do ((i base )
+       (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
+      ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
+    (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
+    (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
+	    (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
+	    (si::fb < (setq i (si::f + i 1)) end)))))
+
+(clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")
+(defentry objnull-p (object) (object "objnull_p"))
+
+(defun can-use-print-circle-p (x)
+  (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?
+       (typecase x
+	 (vector  (or (not (eq 't (array-element-type x)))
+		      (every #'can-use-print-circle-p x)))
+	 (cons    (and (can-use-print-circle-p (car x))
+		       (can-use-print-circle-p (cdr x))))
+	 (array   (or (not (eq 't (array-element-type x)))
+		      (let* ((rank (array-rank x))
+			     (dimensions (make-list rank)))
+			(dotimes (i rank)
+			  (setf (nth i dimensions) (array-dimension x i)))
+			(or (member 0 dimensions)
+			    (do ((cursor (make-list rank :initial-element 0)))
+				(nil)
+			      (declare (:dynamic-extent cursor))
+			      (unless (can-use-print-circle-p (apply #'aref x cursor))
+				(return nil))
+			      (when (si::increment-cursor cursor dimensions)
+				(return t)))))))
+	 (t (or (not (si:structurep x))
+		(let* ((def (si:structure-def x))
+		       (name (si::s-data-name def))
+		       (len (si::s-data-length def))
+		       (pfun (si::s-data-print-function def)))
+		  (and (null pfun)
+		       (dotimes (i len t)
+			 (unless (can-use-print-circle-p (si:structure-ref x name i))
+			   (return nil))))))))))
+
+(defun si::apply-display-fun (display-fun  n lis)  
+  (let ((*print-length* si::*debug-print-level*)
+	(*print-level* si::*debug-print-level*)
+	(*print-pretty* nil)
+	(*PRINT-CASE* :downcase)
+	(*print-circle* nil)
+	)
+    (setf (fill-pointer si::*display-string*) 0)
+    (format si::*display-string* "{")
+    (funcall display-fun n lis)
+    (when (si::fb > (fill-pointer si::*display-string*) n)
+      (setf (fill-pointer si::*display-string*) n)
+      (format si::*display-string* "..."))
+
+    (format si::*display-string* "}")
+    )
+  si::*display-string*
+  )
+
+;The old definition of this had a bug:
+;sometimes it returned without calling mv-values.
+(defun si::next-stack-frame (ihs &aux line-info li i k na)
+  (cond ((si::fb < ihs si::*ihs-base*)
+	 (si::mv-values nil nil nil nil nil))
+	((let (fun)
+	   ;; next lower visible ihs
+	   (si::mv-setq (fun i) (si::get-next-visible-fun ihs))
+	   (setq na fun)
+	   (cond ((and (setq line-info (get fun 'si::line-info))
+		       (do ((j (si::f + ihs 1) (si::f - j 1))
+			    (form ))
+			   ((<= j i) nil)
+			 (setq form (si::ihs-fun j))
+			 (cond ((setq li (si::get-line-of-form form line-info))
+				(return-from si::next-stack-frame 
+				  (si::mv-values
+				   i fun li
+				   ;; filename
+				   (car (aref line-info 0))
+				   ;;environment
+				   (list (si::vs (setq k (si::ihs-vs j)))
+					 (si::vs (1+ k))
+					 (si::vs (+ k 2)))))))))))))
+	((and (not (special-form-p na))
+	      (not (get na 'si::dbl-invisible))
+	      (fboundp na))
+	 (si::mv-values i na nil nil
+		    (if (si::ihs-not-interpreted-env i)
+			nil
+			(let ((i (si::ihs-vs i)))
+			  (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))
+	(t (si::mv-values nil nil nil nil nil))))
+)
+
 #+pre_akcl_610
 (progn
 
diff --git a/pcl/lap.lisp b/pcl/lap.lisp
index 33c4bf446..d41313a59 100644
--- a/pcl/lap.lisp
+++ b/pcl/lap.lisp
@@ -49,14 +49,15 @@
 
 (defun make-lap-closure-generator 
     (closure-variables arguments iregs vregs fvregs tregs lap-code)
-  (funcall *make-lap-closure-generator*
-	   closure-variables arguments iregs 
-	   vregs fvregs tregs lap-code))
+  (funcall-function *make-lap-closure-generator*
+	            closure-variables arguments iregs 
+	            vregs fvregs tregs lap-code))
 
 (defmacro precompile-lap-closure-generator 
     (cvars args i-regs v-regs fv-regs t-regs lap)
-  (funcall *precompile-lap-closure-generator* cvars args i-regs 
-	   v-regs fv-regs t-regs lap))
+  (funcall-function *precompile-lap-closure-generator*
+                    cvars args i-regs 
+	            v-regs fv-regs t-regs lap))
 
 (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
   (declare (ignore cvars args))
@@ -131,7 +132,7 @@
 		   (cadr *generating-lap*) (cons entry allocated))
 	     (cdr entry))
 	    (t
-	     (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*))))))
+	     (let ((new `(,type . (:reg ,(incf (the fixnum (caddr *generating-lap*)))))))
 	       (setf (cadr *generating-lap*) (cons new allocated))
 	       (cdr new)))))))
 
@@ -201,13 +202,13 @@
 (defun opcode (name &rest args)
   (let ((emitter (gethash name *lap-emitters*)))
     (if emitter
-	(apply emitter args)
+	(apply-function (symbol-function emitter) args)
 	(error "No opcode named ~S." name))))
 
 (defun operand (name &rest args)
   (let ((emitter (gethash name *lap-emitters*)))
     (if emitter
-	(apply emitter args)
+	(apply-function (symbol-function emitter) args)
 	(error "No operand named ~S." name))))
 
 (defmacro defopcode (name types)
@@ -273,7 +274,7 @@
   (flet ((check (x)
 	   (ecase x
 	     (:symbol           (symbolp arg))
-	     (:register-number  (and (integerp arg) (>= arg 0)))
+	     (:register-number  (and (integerp arg) (>= (the fixnum arg) 0)))
 	     (:t                t)
 	     (:reg              (and (consp arg) (eq (car arg) :reg)))
 	     (:fixnum           (typep arg 'fixnum)))))
@@ -305,6 +306,8 @@
 (defopcode :fsc-instance-p       (:reg :label))
 (defopcode :built-in-instance-p  (:reg :label))
 (defopcode :structure-instance-p (:reg :label))
+#+pcl-user-instances
+(defopcode :user-instance-p      (:reg :label))
 
 (defopcode :jmp      ((or :reg :constant)))
 
@@ -332,9 +335,13 @@
 (defoperand :structure-wrapper (:reg))
 (defoperand :other-wrapper     (:reg))
 (defoperand :built-in-or-structure-wrapper (:reg))
+#+pcl-user-instances
+(defoperand :user-wrapper      (:reg))
 
 (defoperand :std-slots (:reg))
 (defoperand :fsc-slots (:reg))
+#+pcl-user-instances
+(defoperand :user-slots (:reg))
 
 (defoperand :wrapper-cache-number-vector (:reg))
 
diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp
index 125773599..83b8fc50d 100644
--- a/pcl/list-functions.lisp
+++ b/pcl/list-functions.lisp
@@ -5,19 +5,26 @@
 (defvar *defmethod-list* nil)
 (defvar *defmacro-list* nil)
 (defvar *defgeneric-list* nil)
+(defvar *proclaim-list* nil)
 
 (defun list-functions (&optional print-p)
   (let ((eof '(eof))
 	(*package* *package*))
     (setq *defun-list* nil
 	  *defmethod-list* nil
-	  *defmacro-list* nil)
+	  *defmacro-list* nil
+          *proclaim-list* nil)
     (labels ((process-form (form)
 	       (when (consp form)
 		 (case (car form)
 		   ((in-package export import shadow shadowing-import) (eval form))
 		   #+lcl3.0 (lcl:handler-bind (eval form))
 		   (let (when print-p (print form)))
+                   (declaim
+                     (if (eq (caadr form) 'ftype)
+                         (setf *proclaim-list*
+                               (append (cdr form) *proclaim-list*))
+                         (when print-p (print form))))
 		   (defun (push (list (cadr form) (caddr form))
 				*defun-list*))
 		   (defmethod (push (list (cadr form) (caddr form)) 
@@ -50,7 +57,8 @@
 	(*package* *the-pcl-package*)
 	(*print-pretty* nil)
 	(s-a-n (find-package "SLOT-ACCESSOR-NAME"))
-	(lisp-sans (mapcar #'slot-reader-symbol '(function type))))
+	(lisp-sans (list (slot-reader-symbol 'function)
+                         (slot-reader-symbol 'type))))
     (map-all-generic-functions 
      #'(lambda (gf)
 	 (when (or all-p
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 260d9102a..30a7dc26f 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -65,19 +65,292 @@
 (in-package 'pcl)
 
 (eval-when (compile load eval)
-(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
+(defconstant *optimize-speed*
+  #+kcl
+  '(optimize)
+  #-kcl
+  '(optimize (speed 3) (safety 0) (compilation-speed 0) (space 0))
+  "List of declarations for locally-optimized internal code.")
 )
 
+
+;;; PCL optimizes slot-value accesses on specialized parameters by caching
+;;; methods for each set of classes the method is called on.
+;;; *compile-slot-access-method-functions-at-runtime-p* controls whether
+;;; July 92 stores the method lambda for such methods and compiles them
+;;; at runtime if one of the slot accesses is on a non-:instance allocated
+;;; slot, is on a non-standard instance, or has a user-defined
+;;; slot-value-using-class method.
+;;;   Doing so speeds up slot-accesses because each slot access is directly
+;;; coded in the cached method to be compiled, at the cost of extra compilation
+;;; at runtime.  store-optimized-method-lambda-p can also be specialized
+;;; for the specific kind of generic-function and methods (see methods.lisp).
+;;;   The default is normally T, but can be changed.
+
+(declaim (type boolean *compile-slot-access-method-functions-at-runtime-p*))
+(defvar *compile-slot-access-method-functions-at-runtime-p* T
+  "When T tells PCL to store the lambda source for methods containing slot
+   accesses and to compile those slot accesses at runtime in certain cases.")
+
+;;; 
+;;;    For optimization purposes, July 92 PCL adds the variable
+;;; *compile-all-method-functions-p*, that lets a programmer tell PCL
+;;; to make sure that all method functions are compiled, and to trust that
+;;; they will be compiled.  The default is NIL, leaving them compiled or
+;;; uncompiled as normal, so people can debug their programs more easily 
+;;; when loading uncompiled source code.
+;;;   It can be set to T by a program that uses PCL, but *must* be set
+;;; to T before any user methods are loaded (otherwise their method
+;;; functions might have been loaded as uncompiled functions, potentially
+;;; causing nasty things to happen when the method dispatch functions later
+;;; assume that they're compiled).  It is safe for a user program to set
+;;; it to T after PCL itself is loaded, however, because presumably PCL
+;;; will have been loaded as compiled.
+
+(declaim (type boolean *compile-all-method-functions-p*))
+(defvar *compile-all-method-functions-p* NIL
+  "When T tells PCL to compile all cached method-functions and
+   to assume that they are compiled.")
+
+
+;;;    *compile-all-slot-initfunctions-p* tells whether all slot
+;;; definition initfunctions should be compiled.  Default is T.
+;;;   It can be set to T or NIL by a program that uses PCL, but should
+;;; *not* ever later be changed to NIL if PCL has been compiled with it
+;;; as T, since the initfunction-funcall's for PCL will have assumed that
+;;; they are all compiled.  Later changing it to T after PCL has been
+;;; compiled with NIL if you change it here, however, is safe.
+
+(declaim (type boolean *compile-all-slot-initfunctions-p*))
+(defvar *compile-all-slot-initfunctions-p* T
+  "When T tells PCL to compile all slot initfunctions and assume they are compiled.")
+
+(declaim (type boolean *uncompiled-slot-initfunctions-exists-p*))
+(defvar *uncompiled-slot-initfunctions-exist-p* NIL
+  "Tells whether there have ever been any uncompiled slot initfunctions.")
+
+
+;;;   To adhere to the AMOP while retaining maximum efficiency, method
+;;; functions are actually stored in two ways: as a (1) METHOD-FUNCTION and
+;;; (2) as a METHOD-OPTIMIZED-FUNCTION or METHOD-CLOSURE-GENERATOR.
+;;; METHOD-FUNCTION is the documented function of the AMOP.
+;;; METHOD-OPTIMIZED-FUNCTION is the optimized function used by PCL in actual
+;;; method function invocation (METHOD-FUNCTION-FOR-CACHING). Its arguments are
+;;; the actual arguments of method, and it recieves its next-methods by
+;;; looking at the global *NEXT-METHODS*.  Alternatively, if the method's
+;;; body contains slot-value accesses that can be optimized for caching,
+;;; a METHOD-CLOSURE-GENERATOR is stored instead of METHOD-OPTIMIZED-FUNCTION
+;;; to generate an optimized caching function for given parameter types.
+;;;
+;;; To save space and compile time, generic function STORE-METHOD-FUNCTION-P
+;;; (generic-function method initargs) can be specialized to return NIL
+;;; if the (normally unused) documented method-functions are not needed.
+;;; Default returns T.  Variable *standard-store-method-function-p*, which
+;;; is what the default store-method-function-p method looks up, can be
+;;; set to NIL if it is known that documented method functions will never
+;;; be needed.
+
+(declaim (type boolean *standard-store-method-function-p*))
+(defvar *standard-store-method-function-p* T
+  "Value used by default STORE-METHOD-METHOD-FUNCTION-P method to tell
+   whether standard-methods used in standard-generic-functions store
+   documented method-functions.")
+
+
+;;;   Global variables keeping track of whether it is safe to use the
+;;; fast slot-value optimizations that directly lookup slot location
+;;; from wrapper (wrapper-optimized-slot-value) or not.  PCL changes
+;;; the appropriate variable to NIL if the user defines any
+;;; slot-value-using-class, (setf slot-value-using-class), or
+;;; slot-boundp-using-class that it doesn't know about (i.e. whose
+;;; specializers aren't found on the corresponding
+;;; *safe-slot-value-using-class-specializers* variable.
+;;;   
+;;;   Compiled slot-value accesses that are not specialized parameters
+;;; inside are generally converted by DEFINE-COMPILER-MACRO to a call
+;;; to macro FAST-SLOT-VALUE.  FAST-SLOT-VALUE checks whether it
+;;; is safe to use the wrapper optimizations by checking the appropriate
+;;; global (e.g. *safe-to-use-slot-value-wrapper-optimizations-p*).
+;;; If it is safe, then WRAPPER-OPTIMIZED-SLOT-VALUE is used to
+;;; access the slot directly by looking it up in the wrapper.  If it
+;;; is not safe, then ACCESSOR-SLOT-VALUE is called to access the
+;;; slot through a reader method defined just for that purpose (March 92 PCL).
+;;;
+;;;   Three optimization hints if defining such slot-value-using-class
+;;; method(s):  (1) If the slot-value-using-class method(s) is a
+;;; "simple" definition that can be looked up in the standard form
+;;; (i.e. only has instance slots stored in the std/fsc/user-instance-slots
+;;; vector, etc.), and therefore is still eligible for the slot-value
+;;; wrapper optimizations, then one can push the method's list of
+;;; specializers method onto the appropriate *safe-slot-value-using-
+;;; class-specializers* global to inform PCL that the method is still
+;;; "safe" (must be done _before_ defining the method).  See file
+;;; user-instances.lisp for an example.
+;;;   (2) If you know you are going to define such unsafe s-v-u-c
+;;; methods, you can change each of the *safe-to-use-slot-value-
+;;; wrapper-optimizations-p* globals defined below to NIL, so that
+;;; PCL doesn't generate any of the WRAPPER-OPTIMIZED-SLOT-VALUE
+;;; code that it won't be able to use anyway.
+;;;   (3) If it is guaranteed that you will *not* define such unsafe
+;;; s-v-u-c methods, then *always-safe-to-use-slot-wrapper-optimizations-p*
+;;; can be set to T, after which slot-value accesses will be compiled
+;;; to assume that slot accesses will always be safe.  This will slightly
+;;; optimize slot-value speed and space because it won't have to
+;;; check *safe-to-use-slot-value-wrapper-optimizations-p* and it
+;;; won't generate the extra code for ACCESSOR-SLOT-VALUE.  If an unsafe
+;;; user-defined s-v-u-c methods id defined after this is set to T,
+;;; however, then all bets are off.
+;;;
+;;;   Do *not* change the three *safe-to-use-slot-value-wrapper-optimizations-p*
+;;; globals by hand (aside for changing their initial values below).
+
+(declaim (type boolean *safe-to-use-slot-value-wrapper-optimizations-p*
+                       *safe-to-use-set-slot-value-wrapper-optimizations-p*
+                       *safe-to-use-slot-boundp-wrapper-optimizations-p*
+                       *safe-to-use-slot-wrapper-optimizations-p*))
+
+(defvar *safe-to-use-slot-value-wrapper-optimizations-p* T
+  "Tells whether it is safe for slot-value to directly access the
+   slot through the wrapper for instances of standard-class or
+   funcallable-standard-class.  NIL if any non-standard
+   slot-value-using-class methods have been defined.")
+
+(defvar *safe-to-use-set-slot-value-wrapper-optimizations-p* T
+  "Tells whether it is safe for set-slot-value to directly access the
+   slot through the wrapper for instances of standard-class or
+   funcallable-standard-class.  NIL if any non-standard
+   (setf slot-value-using-class) methods have been defined.")
+
+(defvar *safe-to-use-slot-boundp-wrapper-optimizations-p* T
+  "Tells whether it is safe for slot-boundp to directly access the
+   slot through the wrapper for instances of standard-class or
+   funcallable-standard-class.  NIL if any non-standard
+   slot-boundp-using-class methods have been defined.")
+
+(defvar *safe-to-use-slot-wrapper-optimizations-p*
+        (and *safe-to-use-slot-value-wrapper-optimizations-p*
+             *safe-to-use-set-slot-value-wrapper-optimizations-p*
+             *safe-to-use-slot-boundp-wrapper-optimizations-p*)
+  "(and *safe-to-use-slot-value-wrapper-optimizations-p*
+        *safe-to-use-set-slot-value-wrapper-optimizations-p*
+        *safe-to-use-slot-boundp-wrapper-optimizations-p*)")
+
+
+(defvar *safe-slot-value-using-class-specializers*
+    '((std-class standard-object standard-effective-slot-definition)
+      (structure-class structure-object structure-effective-slot-definition))
+  "List of the names of the standard slot-value-using-class
+   method specializers that it is safe to use the slot-value
+   wrapper optimizations for.")
+
+(defvar *safe-set-slot-value-using-class-specializers*
+  '((T std-class standard-object standard-effective-slot-definition)
+    (T structure-class structure-object structure-effective-slot-definition))
+  "List of the names of the standard (setf slot-value-using-class)
+   method specializers that it is safe to use the slot-value
+   wrapper optimizations for.")
+
+(defvar *safe-slot-boundp-using-class-specializers*
+   '((std-class standard-object standard-effective-slot-definition)
+     (structure-class structure-object structure-effective-slot-definition))
+  "List of the names of the standard slot-boundp-using-class
+   method specializers that it is safe to use the slot-boundp
+   wrapper optimizations for.")
+
+
+(declaim (type boolean *always-safe-to-use-slot-wrapper-optimizations-p*))
+(defvar *always-safe-to-use-slot-wrapper-optimizations-p* NIL
+  "Global that programmer can set to T for slight optimizations if it is
+   known that it will always be safe to use wrapper-optimized-slot-value
+   etc. for slot accesses.  (I.e. there will never be user-defined
+   slot-value-using-class methods not in *safe-slot-value-using-class-specializers*.)")
+
+
+;;;   When compiled with the feature :pcl-user-instances, PCL includes the
+;;; hooks built in to allow programmers to define their own USER-INSTANCE
+;;; low-level type of instances different from STD-INSTANCE, FSC-INSTANCE,
+;;; STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE (see file vector.lisp for more
+;;; description, and user-instances.lisp as an example of their use to save
+;;; space over standard instances).
+;;;   Note: pcl-user-instances do not currently work in excl (Allegro) on
+;;; the Sun 4 because of the low-level Sparc lap optimizations in
+;;; quadlap.lisp. :pcl-user-instances is therefore not usually compiled as
+;;; a feature in excl on the sun4.  If you want to use pcl-user-instances
+;;; in excl on the sun4, then the lines defining cpatch and quadlap as
+;;; part of the (defsystem pcl ...) in defsys.lisp must be commented out
+;;; and the below lines modified.
+
+;#-(and excl sun4)
+(pushnew :pcl-user-instances *features*)
+
+
+
 (defmacro %svref (vector index)
   `(locally (declare #.*optimize-speed*
-		     (inline svref))
-	    (svref (the simple-vector ,vector) (the fixnum ,index))))
+                     (inline svref))
+            (svref (the simple-vector ,vector) (the index ,index))))
 
 (defsetf %svref (vector index) (new-value)
   `(locally (declare #.*optimize-speed*
-		     (inline svref))
-     (setf (svref (the simple-vector ,vector) (the fixnum ,index))
-	   ,new-value)))
+                     (inline svref))
+     (setf (svref (the simple-vector ,vector) (the index ,index))
+           ,new-value)))
+
+
+(defun method-function-storage-form (function)
+  "Converts a function to the form it will be stored as a method-function
+   or method-function.  This is equal to itself, except that if it is
+   uncompiled and *compile-all-method-functions-p* is T, then it
+   will be compiled and that value returned."
+  (when function
+      (if (compiled-function-p function)
+          function
+          (if *compile-all-method-functions-p*
+              (compile-function function)
+              function))))
+
+(defmacro method-function-funcall (f &rest args)
+  (if *compile-all-method-functions-p*
+      `(funcall-compiled ,f ,@args)
+      `(funcall-function ,f ,@args)))
+
+(defmacro method-function-apply (f &rest args)
+  (if *compile-all-method-functions-p*
+      `(apply-compiled ,f ,@args)
+      `(apply-function ,f ,@args)))
+
+
+(defun slot-initfunction-storage-form (initfunction)
+  "Converts a slot-definition initfunction to the form it will be
+   stored as.  This is equal to itself, except that if it is uncompiled
+   and *compile-all-slot-initfunctions-p* is T, then it will be compiled
+   and that value returned."
+  (if initfunction
+      (if (compiled-function-p initfunction)
+          initfunction
+          (if *compile-all-slot-initfunctions-p*
+              (compile-initfunction initfunction)
+              (progn
+                (setf *uncompiled-slot-initfunctions-exist-p* T)
+                initfunction)))
+      (error "No initfunction supplied.")))
+
+(defun compile-initfunction (initfunction)
+  ;; This is meant to compile the initfunction if it is not compiled yet,
+  ;; which should be straightforward, since it will be in the form
+  ;; (function (lambda () ,initform)).  This definitely works in lucid,
+  ;; excl, and cmu-lisp. ;However, akcl does something strange to that
+  ;; form (i.e. convert it to '(lambda-closure () () () () ,initform)),
+  ;; which I've patched, but who knows what the heck other lisps do?  -- TL
+  (if (compiled-function-p initfunction)
+      initfunction
+      (compile-function initfunction)))
+
+(defmacro slot-initfunction-funcall (f &rest args)
+  (if (and *compile-all-slot-initfunctions-p*
+           (not *uncompiled-slot-initfunctions-exist-p*))
+      `(funcall-compiled ,f ,@args)
+      `(funcall-function ,f ,@args)))
 
 
 ;;;
@@ -100,17 +373,106 @@
 ;;;
 (defmacro without-interrupts (&body body)
   `(macrolet ((interrupts-on () ())
-	      (interrupts-off () ()))
+              (interrupts-off () ()))
      (progn ,.body)))
 
-
+(defmacro without-interrupts-simple (&body body)
+  `(without-interrupts ,.body))
+  
+
+;;; We have to redefine lisp's DEFSTRUCT macro so that pcl knows about
+;;; all the structure-classes.
+
+(defmacro pcl-defstruct (name-and-options &body slot-descriptions)
+  ;; Excludes structures types created with the :type option
+  (if (and (listp name-and-options) (assq :type (cdr name-and-options)))
+      `(original-defstruct ,name-and-options ,@slot-descriptions)
+      `(progn
+         (store-defstruct-form '(,(if (listp name-and-options)
+                                      name-and-options
+                                      (list name-and-options))
+                                 ,@slot-descriptions))
+         (original-defstruct ,name-and-options ,@slot-descriptions))))
+
+(redefine-macro 'defstruct 'pcl-defstruct)
+(setf (macro-function 'original-defstruct) (original-definition 'defstruct))
+
+
+(defvar *structure-table* (make-hash-table :test 'eq))
+
+(defun store-defstruct-form (defstruct-source)
+  (setf (gethash (caar defstruct-source) *structure-table*)
+        defstruct-source))
+
+(defun defstruct-form (structure-name)
+  (gethash structure-name *structure-table*))
+
+(defun defstruct-form-class-name (defstruct-form)
+  ;; Returns the name of the structure defined by the defstruct-form.
+  (caar defstruct-form))
+
+(defun defstruct-form-conc-name (defstruct-form)
+  ;; Returns a string of the conc-name given by the defstruct source.
+  (let ((conc-name-option (assq :conc-name (cdar defstruct-form))))
+    (if conc-name-option
+        (if (cadr conc-name-option)
+            (symbol-name (cadr conc-name-option))
+            "")
+        (concatenate 'simple-string
+                     (symbol-name (defstruct-form-class-name defstruct-form))
+                     "-"))))
+
+(defun defstruct-form-predicate-name (defstruct-form)
+  ;; Returns a string of the predicate-name given by the defstruct source.
+  (let ((predicate-option (assq :predicate (cdar defstruct-form))))
+    (if predicate-option
+        (cadr predicate-option)
+        (let ((class-name (defstruct-form-class-name defstruct-form)))
+          (intern (concatenate 'simple-string (symbol-name class-name) "-P")
+                  (symbol-package class-name))))))
+
+(defun defstruct-form-constructor (defstruct-form)
+  (let ((constructor-option (assq :constructor (cdar defstruct-form))))
+    (if constructor-option
+        (cdr constructor-option)
+        (let ((class-name (defstruct-form-class-name defstruct-form)))
+        (list
+          (intern (concatenate 'simple-string "MAKE-" (symbol-name class-name))
+                  (symbol-package class-name))
+          ())))))
+
+#-(or cmu excl ibcl kcl lucid)
+(defmacro structurep (x)
+  `(typep ,x 'structure))
+
+#-(or cmu excl ibcl kcl lucid)
+(defmacro structure-type (x)
+  `(type-of ,x))
+
+#-(or cmu kcl lucid)
+(defun known-structure-type-p (symbol)
+  (not (null (gethash symbol *structure-table*))))
+
+(defmacro structure-instance-p (x)
+  "All structures except std-instance structures match."
+  (once-only (x)
+    `(locally
+       (declare #.*optimize-speed*)
+       (and (structurep ,x)
+            (not (eq (structure-type ,x) 'std-instance))))))
+
+(defun structure-type-included-type-name (symbol)
+  (let ((defstruct-source (gethash symbol *structure-table*)))
+    (cadr (assq :include (cdar defstruct-source)))))
+
+
 ;;;
 ;;;  Very Low-Level representation of instances with meta-class standard-class.
 ;;;
 (defstruct (std-instance (:predicate std-instance-p)
-			 (:conc-name %std-instance-)
-			 (:constructor %%allocate-instance--class ())
-			 (:print-function print-std-instance))
+                         (:conc-name %std-instance-)
+                         (:constructor %%allocate-instance--class ())
+                         (:print-function print-std-instance))
   (wrapper nil)
   (slots nil))
 
@@ -118,20 +480,20 @@
 (defmacro std-instance-slots   (x) `(%std-instance-slots ,x))
 
 (defun print-std-instance (instance stream depth) ;A temporary definition used
-  (declare (ignore depth))		          ;for debugging the bootstrap
+  (declare (ignore depth))                        ;for debugging the bootstrap
   (printing-random-thing (instance stream)        ;code of PCL (See high.lisp).
     (format stream "std-instance")))
 
-(defmacro %allocate-instance--class (no-of-slots)
+(defmacro %allocate-instance--class (static-slot-storage-copy)
   `(let ((instance (%%allocate-instance--class)))
-     (%allocate-instance--class-1 ,no-of-slots instance)
+     (%allocate-instance--class-1 ,static-slot-storage-copy instance)
      instance))
 
-(defmacro %allocate-instance--class-1 (no-of-slots instance)
+(defmacro %allocate-instance--class-1 (static-slot-storage-copy instance)
   (once-only (instance)
     `(progn 
        (setf (std-instance-slots ,instance)
-	     (%allocate-static-slot-storage--class ,no-of-slots)))))
+             (%allocate-static-slot-storage--class ,static-slot-storage-copy)))))
 
 ;;;
 ;;; This is the value that we stick into a slot to tell us that it is unbound.
@@ -142,16 +504,27 @@
 ;;; code which actually use ..slot-unbound.. rather than this variable.  So
 ;;; much for modularity
 ;;; 
-(defvar *slot-unbound* '..slot-unbound..)
+(defconstant *slot-unbound* '..slot-unbound..)
 
-(defmacro %allocate-static-slot-storage--class (no-of-slots)
-  `(make-array ,no-of-slots :initial-element *slot-unbound*))
+;;; As of July 92 PCL, %allocate-static-slot-storage--class does not take
+;;; a number of slots.  As per the optimization suggestion in the first two
+;;; chapters of the CLOS specification, it instead takes a copy of the slot
+;;; storage vector and copies it.  This original vector copy (stored in
+;;; wrapper-allocate-static-slot-storage-copy in the wrappers)  holds the
+;;; results of the slot :initform forms that neither produce or depend on
+;;; side-effects (with any other slots holding *slot-unbound*).
+
+(defmacro %allocate-static-slot-storage--class (static-slot-storage-copy)
+  `(locally (declare #.*optimize-speed*)
+     (copy-simple-vector ,static-slot-storage-copy)))
 
+(defmacro %allocate-origional-static-slot-storage-copy (no-of-slots)
+  `(make-array ,no-of-slots :initial-element *slot-unbound*))
 
 (defmacro std-instance-class (instance)
   `(wrapper-class (std-instance-wrapper ,instance)))
 
-
+
 
   ;;   
 ;;;;;; FUNCTION-ARGLIST
@@ -193,8 +566,8 @@
 (defun set-function-name (function new-name)
   (declare (notinline set-function-name-1 intern-function-name))
   (set-function-name-1 function
-		       (intern-function-name new-name)
-		       new-name))
+                       (intern-function-name new-name)
+                       new-name))
 
 (defun set-function-name-1 (function new-name uninterned-name)
   (declare (ignore new-name uninterned-name))
@@ -202,15 +575,15 @@
 
 (defun intern-function-name (name)
   (cond ((symbolp name) name)
-	((listp name)
-	 (intern (let ((*package* *the-pcl-package*)
-		       (*print-case* :upcase)
-		       (*print-pretty* nil)
-		       (*print-gensym* 't))
-		   (format nil "~S" name))
-		 *the-pcl-package*))))
+        ((listp name)
+         (intern (let ((*package* *the-pcl-package*)
+                       (*print-case* :upcase)
+                       (*print-pretty* nil)
+                       (*print-gensym* 't))
+                   (format nil "~S" name))
+                 *the-pcl-package*))))
+
 
-
 ;;;
 ;;; COMPILE-LAMBDA
 ;;;
@@ -237,52 +610,74 @@
 ;;;                             ports which have non-reentrant compilers.
 ;;;
 ;;;
+;;; TL: 07/92: Added name optional parameter to compile-lambda to
+;;; allow the lambda to be compiled with a given function name.
+
 (defvar *compiler-present-p* t)
 
 (defvar *compiler-speed*
-	#+(or KCL IBCL GCLisp) :slow
-	#-(or KCL IBCL GCLisp) :fast)
+        #+(or KCL IBCL GCLisp) :slow
+        #-(or KCL IBCL GCLisp) :fast)
 
 (defvar *compiler-reentrant-p*
-	#+(and (not XKCL) (or KCL IBCL)) nil
-	#-(and (not XKCL) (or KCL IBCL)) t)
+        #+(and (not XKCL) (or KCL IBCL)) nil
+        #-(and (not XKCL) (or KCL IBCL)) t)
 
 (defun in-the-compiler-p ()
-  #+(and (not xkcl) (or KCL IBCL))compiler::*compiler-in-use*
+  #+(and (not xkcl) (or KCL IBCL)) compiler::*compiler-in-use*
   #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure)
   )
 
-(defun compile-lambda (lambda &optional (desirability :fast))
+(defun compile-function (function)
+  (cond #+kcl
+        ((and (listp function) (eq (car function) 'lambda-closure))
+         (compile-lambda `(lambda ,@(cddddr function))))
+        ((functionp function) (compile-lambda function))
+        (T "Function isn't in expected function form -- see
+            documentation of PCL::COMPILE-FUNCTION.")))
+
+(defun compile-lambda (lambda &optional (desirability :fast) name)
   (cond ((null *compiler-present-p*)
-	 (compile-lambda-uncompiled lambda))
-	((and (null *compiler-reentrant-p*)
-	      (in-the-compiler-p))
-	 (compile-lambda-deferred lambda))
-	((eq desirability :fast)
-	 (compile nil lambda))
-	((and (eq desirability :medium)
-	      (member *compiler-speed* '(:fast :medium)))
-	 (compile nil lambda))
-	((and (eq desirability :slow)
-	      (eq *compiler-speed* ':fast))
-	 (compile nil lambda))
-	(t
-	  (compile-lambda-uncompiled lambda))))
-
-(defun compile-lambda-uncompiled (uncompiled)
-  (let ((function (coerce uncompiled 'function)))
-    #'(lambda (&rest args) (apply function args))))
-
-(defun compile-lambda-deferred (uncompiled)
-  (let ((function (coerce uncompiled 'function))
-	(compiled nil))
-    #'(lambda (&rest args)
-	(if compiled
-	    (apply compiled args)
-	    (if (in-the-compiler-p)
-		(apply function args)
-		(progn (setq compiled (compile nil uncompiled))
-		       (apply compiled args)))))))
+         (compile-lambda-uncompiled lambda name))
+        ((and (null *compiler-reentrant-p*)
+              (in-the-compiler-p))
+         (compile-lambda-deferred lambda name))
+        ((eq desirability :fast)
+         (compile name lambda))
+        ((and (eq desirability :medium)
+              (memq *compiler-speed* '(:fast :medium)))
+         (compile name lambda))
+        ((and (eq desirability :slow)
+              (eq *compiler-speed* ':fast))
+         (compile name lambda))
+        (t
+          (compile-lambda-uncompiled lambda name))))
+
+(defun compile-lambda-uncompiled (uncompiled &optional name)
+  (let* ((function (coerce uncompiled 'function))
+         (form #'(lambda (&rest args) (apply function args))))
+    (if name
+        (progn
+          (setf (symbol-function name) form)
+          name)
+        form)))
+
+(defun compile-lambda-deferred (uncompiled &optional name)
+  (let* ((function (coerce uncompiled 'function))
+         (compiled nil)
+         (form
+           #'(lambda (&rest args)
+              (if compiled
+                  (apply (the compiled-function compiled) args)
+                  (if (in-the-compiler-p)
+                      (apply function args)
+                      (progn (setq compiled (compile name uncompiled))
+                             (apply (the compiled-function compiled) args)))))))
+    (if name
+        (progn
+          (setf (symbol-function name) form)
+          name)
+        form)))
 
 (defmacro precompile-random-code-segments (&optional system)
   `(progn
@@ -290,7 +685,25 @@
      (precompile-function-generators ,system)
      (precompile-dfun-constructors ,system)))
 
-
+(defmacro force-compile (fn-name)
+  "If the function named by FN-NAME isn't compiled, then compile it."
+  (once-only (fn-name)
+    `(unless (really-compiled-function-p (symbol-function ,fn-name))
+       #+(and (not XKCL) (or KCL IBCL))
+       (if (in-the-compiler-p)
+           (in-compiler-force-compile ,fn-name)
+           (compile ,fn-name))
+       #-(and (not XKCL) (or KCL IBCL))
+       (compile ,fn-name))))
+
+(defun in-compiler-force-compile (fn-name)
+  (let ((sym-fn (symbol-function fn-name)))
+    (if (and (consp sym-fn) (eq (car sym-fn) 'lambda-block))
+        (compile-lambda `(lambda ,@(cddr sym-fn)) fn-name)
+        (error "Uncompiled SYMBOL-FUNCTION of ~S in unexpected
+                form (FORCE-COMPILE)" fn-name))))
+
+
 
 (defun record-definition (type spec &rest args)
   (declare (ignore type spec args))
@@ -298,85 +711,10 @@
 
 (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
 
-;; From braid.lisp
-(defmacro built-in-or-structure-wrapper (x)
-  (once-only (x)
-    (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
-	`(if (structurep ,x)
-	     (wrapper-for-structure ,x)
-	     (if (symbolp ,x)
-		 (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
-		 (built-in-wrapper-of ,x)))
-	`(or (and (symbolp ,x)
-		  (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))
-
-(defun declare-structure (name included-name slot-description-list)
-  (setf (gethash name *structure-table*)
-	(cons included-name slot-description-list)))
-
-(unless (fboundp 'structure-functions-exist-p)
-  (setf (symbol-function 'structure-functions-exist-p) 
-	#'(lambda () nil)))
-
-(defun default-structurep (x)
-  (structure-type-p (type-of x)))
-
-(defun default-structure-instance-p (x)
-  (let ((type (type-of x)))
-    (and (not (eq type 'std-instance))
-	 (structure-type-p type))))
-
-(defun default-structure-type (x)
-  (type-of x))
-
-(unless (fboundp 'structurep)
-  (setf (symbol-function 'structurep) #'default-structurep))
-
-; excludes std-instance
-(unless (fboundp 'structure-instance-p)
-  (setf (symbol-function 'structure-instance-p) #'default-structure-instance-p))
-
-; returns a symbol
-(unless (fboundp 'structure-type)
-  (setf (symbol-function 'structure-type) #'default-structure-type))
-
-
-;Functions on symbols naming structures
-
-; Excludes structures types created with the :type option
-(defun structure-type-p (symbol)
-  (not (null (gethash symbol *structure-table*))))
-
-(defun structure-type-included-type-name (symbol)
-  (car (gethash symbol *structure-table*)))
-
-; direct slots only
-; The results of this function are used only by the functions below.
-(defun structure-type-slot-description-list (symbol)
-  (cdr (gethash symbol *structure-table*)))
-
-
-;Functions on slot-descriptions (returned by the function above)
-
-;returns a symbol
-(defun structure-slotd-name (structure-slot-description)
-  (first structure-slot-description))
-
-;returns a symbol
-(defun structure-slotd-accessor-symbol (structure-slot-description)
-  (second structure-slot-description))
-
-;returns a symbol or a list or nil
-(defun structure-slotd-writer-function (structure-slot-description)
-  (third structure-slot-description))
-
 
diff --git a/pcl/lucid-low.lisp b/pcl/lucid-low.lisp
index 0da862a9d..20107328a 100644
--- a/pcl/lucid-low.lisp
+++ b/pcl/lucid-low.lisp
@@ -106,7 +106,7 @@
 
 
 
-#+lcl3.0
+#+lcl4.0
 (progn
 
 (defvar *saved-compilation-speed* 3)
@@ -307,53 +307,51 @@
 (in-package 'pcl)
 
 (pushnew :structure-wrapper *features*)
-
-(defun structure-functions-exist-p ()
-  t)
-
-(defun structure-instance-p (x)
-  (and (structurep x)
-       (not (eq 'std-instance (structure-type x)))))
+(pushnew :structure-functions *features*)
 
 (defvar *structure-type* nil)
 (defvar *structure-length* nil)
 
-(defun structure-type-p (type)
+(defun known-structure-type-p (type)
+  (declare (special lucid::*defstructs*))
   (let ((s-data (gethash type lucid::*defstructs*)))
     (or (and s-data 
 	     (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
 	(and type (eq *structure-type* type)))))
 
 (defun structure-type-included-type-name (type)
+  (declare (special lucid::*defstructs*))
   (let ((s-data (gethash type lucid::*defstructs*)))
     (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this
 
 (defun structure-type-slot-description-list (type)
+  (declare (special lucid::*defstructs*))
   (let ((s-data (gethash type lucid::*defstructs*)))
     (if s-data
-	(nthcdr (let ((include (structure-ref s-data 6 'defstruct)))
-		  (if include
-		      (let ((inc-s-data (gethash include lucid::*defstructs*)))
-			(if inc-s-data
-			    (length (structure-ref inc-s-data 7 'defstruct))
-			    0))
-		      0))
-		(map 'list
-		     #'(lambda (slotd)
-			 (let* ((ds 'lucid::defstruct-slot)
-				(slot-name (system:structure-ref slotd 0 ds))
-				(position (system:structure-ref slotd 1 ds))
-				(accessor (system:structure-ref slotd 2 ds))
-				(read-only-p (system:structure-ref slotd 5 ds)))
-			   (list slot-name accessor
-				 #'(lambda (x)
-				     (system:structure-ref x position type))
-				 (unless read-only-p
-				   #'(lambda (v x)
-				       (setf (system:structure-ref x position type)
-					     v))))))
-		     (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
-	(let ((result (make-list *structure-length*)))
+	(nthcdr (the index
+                     (let ((include (structure-ref s-data 6 'defstruct)))
+		       (if include
+		           (let ((inc-s-data (gethash include lucid::*defstructs*)))
+		     	     (if inc-s-data
+			         (length (structure-ref inc-s-data 7 'defstruct))
+			         0))
+		           0)))
+		(map
+                 'list
+		 #'(lambda (slotd)
+		     (let* ((slot-name (system:structure-ref slotd 0 'lucid::defstruct-slot))
+			    (position (system:structure-ref slotd 1 'lucid::defstruct-slot))
+			    (accessor (system:structure-ref slotd 2 'lucid::defstruct-slot))
+			    (read-only-p (system:structure-ref slotd 5 'lucid::defstruct-slot)))
+		       (list slot-name accessor
+			     #'(lambda (x)
+			         (system:structure-ref x position type))
+			     (unless read-only-p
+			       #'(lambda (v x)
+			           (setf (system:structure-ref x position type)
+				         v))))))
+		 (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
+	(let ((result (make-list (the index *structure-length*))))
 	  (dotimes (i *structure-length* result)
 	    (let* ((name (format nil "SLOT~D" i))
 		   (slot-name (intern name (or (symbol-package type) *package*)))
diff --git a/pcl/macros.lisp b/pcl/macros.lisp
index 54fda076c..1bc49ba5b 100644
--- a/pcl/macros.lisp
+++ b/pcl/macros.lisp
@@ -69,19 +69,23 @@
 
 
 (defun make-caxr (n form)
+  (declare (type fixnum n))
   (if (< n 4)
       `(,(nth n '(car cadr caddr cadddr)) ,form)
-      (make-caxr (- n 4) `(cddddr ,form))))
+      (make-caxr (the fixnum (- n 4)) `(cddddr ,form))))
 
 (defun make-cdxr (n form)
+  (declare (type fixnum n))
   (cond ((zerop n) form)
 	((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
-	(t (make-cdxr (- n 4) `(cddddr ,form)))))
+	(t (make-cdxr (the fixnum (- n 4)) `(cddddr ,form)))))
 )
 
+
 (defun true (&rest ignore) (declare (ignore ignore)) t)
 (defun false (&rest ignore) (declare (ignore ignore)) nil)
 (defun zero (&rest ignore) (declare (ignore ignore)) 0)
+(defvar *keyword-package* (find-package 'keyword))
 
 (defun make-plist (keys vals)
   (if (null vals)
@@ -97,34 +101,168 @@
 ;;; lifted it from there but I am honest.  Not only that but this one is
 ;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more
 ;;; like rebuilding Rome.
+;;;
+;;; Modified 5/8/92 to work right on THE forms and to not  wrap an
+;;; extra lambda if none of the variables are complex -- TL.
+
+(defun un-the (form)
+  "Returns the actual form within a form that may start with THE."
+  (if (and (listp form) (eq (car form) 'the))
+      (un-the (third form))
+      form))
+
+(defun simple-eval-access-p (form)
+  "Returns whether evaluation of the form is 'simple', i.e. does not
+   require computation to calculate.  This is true of constants, variables,
+   and functions."
+  (or (constantp form)                ;; Form is a constant?
+      (symbolp   form)                ;; Form is a variable?
+      (and (listp form)
+           (eq (car form) 'function)) ;; Form is a function?
+      (and (listp form)               ;; If form starts with THE, the real form
+           (eq (car form) 'the)       ;;   third element.
+           (simple-eval-access-p (third form)))))
+
 (defmacro once-only (vars &body body)
   (let ((gensym-var (gensym))
-        (run-time-vars (gensym))
-        (run-time-vals (gensym))
+        (run-time-vars (gensym "RUN-TIME-VARS"))
+        (run-time-vals (gensym "RUN-TIME-VALS"))
         (expand-time-val-forms ()))
     (dolist (var vars)
-      (push `(if (or (symbolp ,var)
-                     (numberp ,var)
-                     (and (listp ,var)
-			  (member (car ,var) '(quote function))))
+      (push `(if (simple-eval-access-p ,var)
                  ,var
-                 (let ((,gensym-var (gensym)))
+                 (let ((,gensym-var (gensym ,(symbol-name var))))
                    (push ,gensym-var ,run-time-vars)
                    (push ,var ,run-time-vals)
                    ,gensym-var))
-            expand-time-val-forms))    
+            expand-time-val-forms))
     `(let* (,run-time-vars
             ,run-time-vals
             (wrapped-body
 	      (let ,(mapcar #'list vars (reverse expand-time-val-forms))
 		,@body)))
-       `(let ,(mapcar #'list (reverse ,run-time-vars)
-			     (reverse ,run-time-vals))
-	  ,wrapped-body))))
+       (if ,run-time-vars
+           `(let ,(mapcar #'list (reverse ,run-time-vars)
+                                 (reverse ,run-time-vals))
+             ,wrapped-body)
+         wrapped-body))))
+
+#-(or cmu)  ; And probably others, but this is the only I know.
+(unless (fboundp 'declaim)
+  (defmacro declaim (&rest decl-specs)
+    (let ((proclamations NIL))
+      (declare (list proclamations))
+      (dolist (decl-spec decl-specs)
+        #-(or cmu kcl)
+        (when (eq (car decl-spec) 'ftype)
+          (dolist (function-name (cddr decl-spec))
+            (setf (get function-name 'ftype-declaimed-p) T)))
+        (push `(proclaim ',decl-spec) proclamations))
+      (if (cdr proclamations)
+          `(progn ,@proclamations)
+          (car proclamations)))))
+
+#-(or cmu kcl)
+(defun function-ftype-declaimed-p (name)
+  "Returns whether the function given by name already has its ftype declaimed."
+  (get name 'ftype-declaimed-p))
+
+
+(deftype index () `(integer 0 ,most-positive-fixnum))
+
+(defmacro pop-key-value (key
+                         settable-lambda-list
+                         &optional
+                         default-value)
+  ;;   If key is on the settable-lambda-list, then it and its value is
+  ;; destructively removed from the list, and its value is returned.
+  ;;   Else, default-value is returned and the settable-lambda-list
+  ;; stays the same.
+  (once-only (key)
+    `(let ((list-ptr ,settable-lambda-list))
+        (if (eq (car list-ptr) ,key)
+            (progn
+              (setf ,settable-lambda-list (cddr list-ptr))
+              (cadr list-ptr))
+          (progn
+            (setf list-ptr (cdr list-ptr))
+            (let ((next-cdr (cdr list-ptr)))
+              (loop (when (null next-cdr)
+                      (return ,default-value))
+                    (when (eq (car next-cdr) ,key)
+                      (setf (cdr list-ptr) (cddr next-cdr))
+                      (return (cadr next-cdr)))
+                    (setf next-cdr
+                          (cdr (setf list-ptr (cdr next-cdr)))))))))))
+
+(defmacro copy-simple-vector (orig)
+  "Fast way to copy a simple-vector."
+  #-kcl
+  (once-only (orig)
+    `(let* ((i   0)
+            (n   (length (the simple-vector ,orig)))
+            (new (make-array n)))
+       (declare (type index i n) (type simple-vector new))
+       (tagbody
+         begin-loop
+           (if (>= i n) (go end-loop))
+           (setf (svref new i) (svref (the simple-vector ,orig) i))
+           (setf i (the index (1+ i)))
+           (go begin-loop)
+        end-loop)
+       new))
+  #+kcl
+  `(copy-seq (the simple-vector ,orig)))
+
+(defun lambda-list-legal-p (lambda-list
+                            &optional
+                            (options-allowed-p T)
+                            (keywords-allowed lambda-list-keywords))
+  (when (listp lambda-list)
+    (dolist (element lambda-list T)
+      (unless (or (symbolp element)
+                  (memq element keywords-allowed)
+                  (and options-allowed-p (listp element)))
+        (return NIL)))))
+
+
+(defun lambda-list-required-args (lambda-list)
+  (let ((collection NIL))
+    (dolist (element lambda-list)
+      (if (memq element lambda-list-keywords)
+          (return)
+        (push element collection)))
+    (nreverse collection)))
+
+(defun npermutation-p (list1 list2)
+  "Returns whether list1 is a permutation of list2"
+  (if (null list1)
+      (null list2)
+    (unless (null list2)
+      (when (memq (car list1) list2)
+         (npermutation-p (cdr list1)
+                         (delete (car list1) list2 :count 1))))))
+
+(defun permutation-p (list1 list2)
+  "Returns whether list1 is a permutation of list2"
+  (npermutation-p list1 (copy-list list2)))
+
+(defun count-non-nils (list)
+  "Returns the count of non nil elements in the list."
+  (if list
+      (let ((non-nil-count 0)
+            (list-ptr list))
+        (declare (type fixnum non-nil-count))
+        (loop (when (car list-ptr)
+                (setf non-nil-count (the fixnum (1+ non-nil-count))))
+              (unless (setf list-ptr (cdr list-ptr))
+                (return non-nil-count))))
+      0))
 
 (eval-when (compile load eval)
+(proclaim '(ftype (function (T &optional T) (values T T T)) extract-declarations))
 (defun extract-declarations (body &optional environment)
-  ;;(declare (values documentation declarations body))
+  (declare (values documentation declarations body))
   (let (documentation declarations form)
     (when (and (stringp (car body))
 	       (cdr body))
@@ -152,11 +290,9 @@
 	    body)))
 )
 
-#+Lucid
-(eval-when (compile load eval)
-  (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
-
-(defvar *keyword-package* (find-package 'keyword))
+;#+Lucid
+;(eval-when (compile load eval)
+;  (eval `(defstruct (,(intern "FASLESCAPE" (find-package 'lucid))))))
 
 (defun make-keyword (symbol)
   (intern (symbol-name symbol) *keyword-package*))
@@ -211,7 +347,7 @@
 
 (eval-when (compile load eval)
 (defun destructure (pattern form)
-  ;;(declare (values setqs binds))
+  (declare (values setqs binds))
   (let ((*destructure-vars* ())
 	(setqs ()))
     (declare (special *destructure-vars*))
@@ -232,6 +368,7 @@
 	(pending-pops 0)
 	(var nil)
 	(setqs ()))
+    (declare (type fixnum pending-pops))
     (labels
         ((make-pop (var form pop-into)
 	   (prog1 
@@ -348,6 +485,7 @@
 	  (char nil char)
 	  (i 0 (+ i 1)))
 	 ((= i length) string)
+      (declare (type fixnum i length))
       (setq char (elt string i))
       (cond ((both-case-p char)
 	     (if flag
@@ -360,26 +498,39 @@
 	     (unless dashes-p (setf (elt string i) #\space)))
 	    (t (setq flag nil))))))
 
-#-(or lucid kcl)
-(eval-when (compile load eval)
-;(warn "****** Things will go faster if you fix define-compiler-macro")
+#-(or lucid kcl excl cmu)
+(eval-when (compile)
+(warn "****** Things would go faster if you fix define-compiler-macro for
+your lisp")
 )
 
+#+(or lucid kcl excl cmu)
 (defmacro define-compiler-macro (name arglist &body body)
-  #+(or lucid kcl)
-  `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
+  `(#+lucid lcl:def-compiler-macro
+    #+kcl   si::define-compiler-macro
+    #+excl  excl::defcmacro
+    #+cmu   c:def-source-transform
         ,name ,arglist
-     ,@body)
-  #-(or kcl lucid)
-  nil)
-
+     ,@body))
 
-;;;
-;;; FIND-CLASS
-;;;
-;;; This is documented in the CLOS specification.
-;;;
-(defvar *find-class* (make-hash-table :test #'eq))
+#-(or lucid kcl excl cmu)
+(defmacro define-compiler-macro (name arglist &body body)
+  (declare (ignore name arglist body))
+  NIL)
+
+(defmacro safe-subtypep (type1 type2)
+  #+(or cmu kcl excl)
+  `(subtypep ,type1 ,type2)
+  #+lucid
+  (once-only (type1 type2)
+    `(if (and (lcl:type-specifier-p ,type1)
+              (lcl:type-specifier-p ,type2))
+         (subtypep ,type1 ,type2)
+         (values nil nil)))
+  #-(or cmu kcl excl lucid)
+  (declare (ignore type1 type2))
+  #-(or cmu kcl excl lucid)
+  `(values nil nil))
 
 (defun make-constant-function (value)
   #'(lambda (object)
@@ -390,80 +541,18 @@
   (declare (ignore x))
   nil)
 
+(defun documented-function-returning-nil (args next-methods)
+  (declare (ignore args next-methods))
+  nil)
+
 (defun function-returning-t (x)
   (declare (ignore x))
   t)
 
-(defmacro find-class-cell-class (cell)
-  `(car ,cell))
-
-(defmacro find-class-cell-predicate (cell)
-  `(cdr ,cell))
-
-(defmacro make-find-class-cell (class-name)
-  (declare (ignore class-name))
-  '(cons nil #'function-returning-nil))
-
-(defun find-class-cell (symbol &optional dont-create-p)
-  (or (gethash symbol *find-class*)
-      (unless dont-create-p
-	(unless (legal-class-name-p symbol)
-	  (error "~S is not a legal class name." symbol))
-	(setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
-
-(defvar *create-classes-from-internal-structure-definitions-p* t)
-
-(defun find-class-from-cell (symbol cell &optional (errorp t))
-  (or (find-class-cell-class cell)
-      (and *create-classes-from-internal-structure-definitions-p*
-           (structure-type-p symbol)
-           (find-structure-class symbol))
-      (cond ((null errorp) nil)
-	    ((legal-class-name-p symbol)
-	     (error "No class named: ~S." symbol))
-	    (t
-	     (error "~S is not a legal class name." symbol)))))
-
-(defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
-  (unless (find-class-cell-class cell)
-    (find-class-from-cell symbol cell errorp))
-  (find-class-cell-predicate cell))
-
-(defun legal-class-name-p (x)
-  (and (symbolp x)
-       (not (keywordp x))))
-
-(defun find-class (symbol &optional (errorp t) environment)
-  (declare (ignore environment))
-  (find-class-from-cell symbol (find-class-cell symbol errorp) errorp))
-
-(defun find-class-predicate (symbol &optional (errorp t) environment)
-  (declare (ignore environment))
-  (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp))
-
-#-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)
-  (if (legal-class-name-p symbol)
-      (setf (find-class-cell-class (find-class-cell symbol)) new-value)
-      (error "~S is not a legal class name." symbol)))
-
-#-setf
-(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
-  (declare (ignore errorp environment))
-  `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
-
-(defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)
-          (new-value symbol)
-  (if (legal-class-name-p symbol)
-      (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
-      (error "~S is not a legal class name." symbol)))
+(defun documented-function-returning-t (args next-methods)
+  (declare (ignore args next-methods))
+  t)
 
-(defun find-wrapper (symbol)
-  (class-wrapper (find-class symbol)))
 
 #|| ; Anything that used this should use eval instead.
 (defun reduce-constant (old)
@@ -487,12 +576,13 @@
   `(let* ((limit ,size)
 	  (result (make-array limit))
 	  (index 0))
+     (declare (type fixnum index))
      (values #'(lambda (value)
 		 (if (= index limit)
 		     (error "vectorizing more elements than promised.")
 		     (progn
 		       (setf (svref result index) value)
-		       (incf index)
+		       (setf index (the fixnum (1+ index)))
 		       value)))
 	     #'(lambda () result))))
 
@@ -517,13 +607,62 @@
 		     tail)
 	         (setq tail (funcall ,by tail))))))
 
+
+;;;
+;;; Functions and types for dealing with functions.
+;;;
+
+(defun really-function-p (x)
+  "Returns whether  X is really a function (as per X3J13)"
+  #+cmu   (functionp x)
+  #+lucid (procedurep x)
+  #-(or cmu lucid)
+  (and (functionp x) (not (or (symbolp x) (consp x)))))
+
+(defun really-compiled-function-p (function)
+  "Returns whether FUNCTION is really a compiled function and not an
+   interpreted function masquerading as a compiled function."
+  #-cmu
+  (compiled-function-p function)
+  #+cmu
+  (the boolean
+       (and (compiled-function-p function)
+            (not (eval:interpreted-function-p function)))))
+
+(deftype real-function ()
+         #+cmu            'function
+         #+lucid          'system:procedure
+         #-(or cmu lucid) `(satisfies really-function-p))
+
+(defmacro funcall-function (form &rest args)
+  #+cmu            `(funcall (the function ,form) ,@args)
+  #+lucid          `(funcall (the system:procedure ,form) ,@args)
+  #-(or cmu lucid) `(funcall ,form ,@args))
+
+(defmacro apply-function (form &rest args)
+  #+cmu            `(apply (the function ,form) ,@args)
+  #+lucid          `(apply (the system:procedure ,form) ,@args)
+  #-(or cmu lucid) `(apply ,form ,@args))
+
 (defmacro function-funcall (form &rest args)
-  #-cmu `(funcall ,form ,@args)
-  #+cmu `(funcall (the function ,form) ,@args))
+  `(funcall-function ,form ,@args))
 
 (defmacro function-apply (form &rest args)
-  #-cmu `(apply ,form ,@args)
-  #+cmu `(apply (the function ,form) ,@args))
+  `(apply-function ,form ,@args))
+
+(defmacro funcall-compiled (form &rest args)
+  `(funcall (the compiled-function ,form) ,@args))
+
+(defmacro apply-compiled (form &rest args)
+  `(apply (the compiled-function ,form) ,@args))
+
+(defmacro force-compile (fn-name)
+  "If the function named by FN-NAME isn't compiled, then compile it."
+  (once-only (fn-name)
+    `(unless (really-compiled-function-p (symbol-function ,fn-name))
+       (compile ,fn-name))))
+
+
 
 
 ;;;
@@ -590,7 +729,9 @@
   (declare (ignore function-name))
   #+setf nil
   #-setf
-  (unless (setfboundp function-name)
+  (unless (and (setfboundp function-name)
+	       (get function-name 'standard-setf))
+    (setf (get function-name 'standard-setf) t)
     (let* ((setf-function-name (get-setf-function-name function-name)))
     
       #+Genera
@@ -655,6 +796,8 @@
       )))
 
 (defun setfboundp (symbol)
+  #-(or Genera Lucid KCL Xerox :coral cmu)
+  (declare (ignore symbol))
   #+Genera (not (null (get-properties (symbol-plist symbol)
 				      'lt::(derived-setf-function trivial-setf-method
 					    setf-equivalence setf-method))))
@@ -701,6 +844,7 @@
 (defsetf slot-value set-slot-value)
 
 (defvar *redefined-functions* nil)
+(defvar *redefined-macros* nil)
 
 (defmacro original-definition (name)
   `(get ,name ':definition-before-pcl))
@@ -713,35 +857,45 @@
   (setf (symbol-function name)
 	(symbol-function new)))
 
-(defun reset-pcl-package () ; Try to do this safely
-  (let* ((vars '(*pcl-directory* *default-pathname-extensions* *pathname-extensions*))
+(defun redefine-macro (name new)
+  (pushnew name *redefined-macros*)
+  (unless (original-definition name)
+    (setf (original-definition name)
+	  (macro-function name)))
+  (setf (macro-function name)
+	(macro-function new)))
+
+(defun pcl::reset-pcl-package ()		; Try to do this safely
+  (let* ((vars '(pcl::*pcl-directory* 
+		 pcl::*default-pathname-extensions* 
+		 pcl::*pathname-extensions*
+		 pcl::*redefined-functions*))
 	 (names (mapcar #'symbol-name vars))
 	 (values (mapcar #'symbol-value vars)))
-    (when (boundp '*redefined-functions*)
-      (dolist (sym *redefined-functions*)
-	(setf (symbol-function sym) (original-definition sym)))
-      #||;; maybe even this isn't good enough
-      #+genera (scl:pkg-kill "PCL")
-      #+lucid (lcl:delete-package "PCL")
-      #-(or genera lucid) (rename-package "PCL" (symbol-name (gensym)))
-      (make-package "PCL" :use '("LISP"))
-      ||#
-      (let ((pkg (find-package "PCL")))
-	(do-symbols (sym pkg)
-	  (when (eq pkg (symbol-package sym))
-	    (unless (constantp sym)
-	      (makunbound sym))
-	    (fmakunbound sym)
-	    (setf (symbol-plist sym) nil))))
-      (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
+    (let ((pkg (find-package "PCL")))
+      (do-symbols (sym pkg)
+	(when (eq pkg (symbol-package sym))
+	  (if (constantp sym)
+	      (unintern sym pkg)
+	      (progn
+		(makunbound sym)
+		(unless (eq sym 'pcl::reset-pcl-package)
+		  (fmakunbound sym))
+		#+cmu (fmakunbound `(setf ,sym))
+		(setf (symbol-plist sym) nil))))))
+    (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
+      (when pkg
 	(do-symbols (sym pkg)
 	  (makunbound sym)
 	  (fmakunbound sym)
-	  (setf (symbol-plist sym) nil)))
-      (let ((pcl (find-package "PCL")))
-	(mapcar #'(lambda (name value)
-		    (let ((var (intern name pcl)))
-		      (proclaim `(special ,var))
-		      (set var value)))
-		names values)))
-      nil))
+	  (setf (symbol-plist sym) nil))))
+    (let ((pcl (find-package "PCL")))
+      (mapcar #'(lambda (name value)
+		  (let ((var (intern name pcl)))
+		    (proclaim `(special ,var))
+		    (set var value)))
+	      names values))      
+    (dolist (sym pcl::*redefined-functions*)
+      (setf (symbol-function sym) (get sym ':definition-before-pcl)))
+    nil))
+
diff --git a/pcl/march-92-notes.text b/pcl/march-92-notes.text
new file mode 100644
index 000000000..913ee4e97
--- /dev/null
+++ b/pcl/march-92-notes.text
@@ -0,0 +1,311 @@
+These notes correspond to the "March 92 PCL (beta1)" version of PCL.
+
+  This version of PCL is much closer than previous versions of PCL
+to the metaobject protocol specified in "The Art of the Metaobject Protocol", 
+chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. Bobrow.
+
+
+[Please read the file may-day-notes.text also.  Most of that file still applies.]
+
+Support for structures
+  You can use structure-class as a metaclass to create new classes.
+  Classes created this way create and evaluate defstruct forms which
+  have generated symbols for the structure accessors and constructor.
+  The generated symbols are used by the primary slot-value-using-class
+  methods and by the primary allocate-instance method for structures.
+  Defmethod optimizes usages of slot-value (when no user-defined 
+  slot-value-using-class methods exist) into direct calls of the
+  generated symbol accessor, which the compiler can then optimize further.
+  Even when there are user-defined methods on slot-value-using-class,
+  PCL does a variety of optimizations.
+  
+  If your implementation's version of the *-low.lisp file
+  contains definitions of certain structure functions (see the end of
+  low.lisp, cmu-low.lisp, lucid-low.lisp, and kcl-low.lisp), then
+  structure classes are supported for all defstructs.  In this case,
+  structure classes are created automatically, when necessary.
+
+New Classes:
+structure-class
+structure-object
+slot-class
+slot-object
+structure-direct-slot-definition
+structure-effective-slot-definition
+
+Improvements to slot-access
+  Optimization for slot-value outsize of defmethod
+  Optimization for slot-value inside of defmethod, but not of a specialized parameter.
+  Optimizations that work even when there are :around methods
+  on slot-value-using-class.
+
+New types: 
+   `(class ,class-object)
+   `(class-eq ,class-object)
+
+New specializer class: class-eq-specializer
+  Every class has a class-eq specializer which represents all
+  the direct instances of that class.
+  This is useful in *subtypep.  For example, here is the way 
+  generic-function initialization checks that the method-class is valid:
+   (and (classp method-class)
+	(*subtypep (class-eq-specializer method-class)
+		   (find-class 'standard-method)))
+  If you want to define methods having class-eq specializers,
+  see "Initialization of method metaobjects".  The default behavior of PCL
+  is to disallow this.
+
+compute-applicable-methods-using-types
+
+caching improvements
+
+no magic-generic-functions list
+  This simplifies some things, but complicates some other things.
+  I wanted to support user-defined classes which are their own metaclass.
+  You can now do:
+(defclass y (standard-class) ())
+(defmethod validate-superclass ((c y) (sc standard-class)) t)
+(defclass y (standard-class) () (:metaclass y))
+
+method-function changes (see the comments for make-method-lambda, below)
+
+final dfuns
+
+-------------------------
+
+gfs which obey AMOP ch 6
+  add-dependent
+  add-direct-method
+  add-direct-subclass
+  add-method
+  allocate-instance
+  compute-class-precedence-list
+  compute-default-initargs
+  compute-effective-slot-definition
+[Note: compute-effective-slot-definition relys on 
+ compute-effective-slot-definition-initargs and effective-slot-definition-class.
+ compute-effective-slot-definition-initargs is quite useful, but is not in
+ AMOP ch 6.]
+  compute-slots
+  direct-slot-definition-class
+  effective-slot-definition-class
+  ensure-class
+  ensure-class-using-class
+  ensure-generic-function
+  ensure-generic-function-using-class
+  eql-specializer-object
+  extract-lambda-list
+  extract-specializer-names
+  finalize-inheritance
+  find-method-combination
+  funcallable-standard-instance-access
+  {generic-function-method-class, generic-function-method-combination,
+   generic-function-lambda-list, generic-function-methods, generic-function-name}
+  intern-eql-specializer
+  make-instance
+  map-dependents
+  {method-function, method-generic-function, method-lambda-list,
+   method-specializers, method-qualifiers}
+  {class-default-initargs, class-direct-default-initargs, class-direct-slots,
+   class-direct-subclasses, class-direct-superclasses, class-finalized-p,
+   class-name, class-precedence-list, class-prototype, class-slots}
+  {slot-definition-allocation, slot-definition-initargs, slot-definition-initform,
+   slot-definition-initfunction, slot-definition-name, slot-definition-type}
+  {slot-definition-readers, slot-definition-writers}
+  {slot-definition-location}
+  remove-dependent
+  remove-direct-method
+  remove-direct-subclass
+  remove-method
+  set-funcallable-instance-function
+  (setf slot-value-using-class)
+  slot-boundp-using-class
+  slot-makunbound-using-class
+  specializer-direct-generic-functions
+  specializer-direct-methods
+  standard-instance-access
+  update-dependent
+
+gfs which DO NOT obey AMOP ch 6
+
+accessor-method-slot-definition
+  Not yet defined.  Use accessor-method-slot-name and method-specializers
+  to get the direct-slot-definition.
+
+compute-applicable-methods
+compute-applicable-methods-using-classes
+  Handles class-eq specializers without signalling an error.  
+  But see "Initialization of method metaobjects", below.
+
+compute-discriminating-function
+  [the resulting function works differently different because 
+   compute-effective-method is different, and because make-method-lambda 
+   does not exist.]
+
+compute-effective-method
+  Returns only one value.  The utility of bringing this into conformance with
+  AMOP ch 6 is limited by the lack of make-method-lambda.
+
+generic-function-argument-precedence-order
+  Not yet defined.  Can get this information from the arg-info structure.
+
+generic-function-declarations
+  Not yet defined.
+
+make-method-lambda
+  Does not exist.  This will be hard to add in a way that is compatible with
+  AMOP ch 6.
+  1. In March 92 PCL, there are two kinds of method-functions.  The first kind
+     is what method-function returns (which has no special restrinctions on its use).
+     The second kind is returned by method-function-for-caching, which is used
+     when the wrappers of the required arguments are known.  Each call to
+     method-function-for-caching might return a new function.  Both kinds of
+     method functions can be closures.  March 92 PCL currently uses this scheme
+     to do the pv-lookup ahead of time, thereby eliminating pv caching.
+     (pv-lookup means the lookup of the permutation vectors which are used for
+     fast instance varaible access.)   Method function closures can also be used
+     in the optimization of calls to generic-functions, but this has not yet been
+     implemented.
+  2. Since method-functions can be closures, we would need an extra step between
+     compiling (or coercing) the method-lambda into a function, before it can be 
+     applied to arguments with apply or funcall.     
+
+reader-method-class
+  Not yet defined.  Some bootstrapping considerations are involved, 
+  but adding this will not be very hard.
+
+(setf class-name)
+  Currently just a writer method.  Does not call reinitialize-instance or
+  (setf find-class).
+
+(setf generic-function-name)
+  Currently just a writer method.  Does not call reinitialize-instance.
+
+writer-method-class
+  Not yet defined.  Some bootstrapping considerations are involved, 
+  but adding this will not be very hard.
+
+---------------------------
+
+Initialization of method metaobjects
+  The following methods are defined:
+    legal-qualifiers-p (method standard-method) qualifiers
+    legal-lambda-list-p (method standard-method) lambda-list
+    legal-specializers-p (method standard-method) specializers
+    legal-method-function-p (method standard-method) function
+    legal-documentation-p (method standard-method) documentation
+
+    legal-specializer-p (method standard-method) specializer
+
+  You can override them if you want.
+  The method for legal-specializers-p calls legal-specializer-p
+  on each specializer.
+  The method for legal-specializer-p allows any kind of specializer
+  when the variable *allow-experimental-specializers-p* is t
+  (this variable is initially nil).
+
+---------------------------
+Optimizations on slot-value
+  Outside of a defmethod when define-compiler-macro is not implemented
+  or the slot-name is not constant, or
+  Inside a defmethod when the slot-name is not a constant:
+(1)   no optimization of slot-value, slot-value-using-class is called.
+      slot-value-using-class has a special dfun, though, which calls
+      the slot's slot-definition-reader-function.  This function is
+      a result of get-accessor-method-function.
+  Outside of a defmethod when define-compiler-macro is implemented and
+  the slot-name is a constant, or
+  Inside a defmethod when the slot-name is a constant but the object is 
+  not either (the value of a parameter specialized to a subclass of structure-object
+  for which no user-defined slot-value-using-class methods apply at defmethod time), 
+  or (the value of a parameter specialized to a subclass of standard-object).
+(2)   PCL arranges to call an automatically created generic function
+      which has one method: a reader method defined on class slot-object.
+  Inside a defmethod when the slot-name is a constant and the object 
+  is (the value of a parameter specialized to a subclass of structure-object
+  for which no user-defined slot-value-using-class methods apply).
+(3)   The slot-value form is converted to a call of the structure slot's 
+      accessor function, which the compiler can then optimize further.
+  Inside a defmethod when the slot-name is a constant and the object 
+  is (the value of a parameter specialized to a subclass of standard-object).
+(4)   The access requires two arefs, a call to (typep x 'fixnum), and a call to eq,
+      in the best case.  If user defined slot-value-using-class methods apply
+      at slot-value execution time, or the slot is unbound, the unoptimized 
+      slot-value function (1) is called.  This was in May Day PCL; what is new here
+      is that the PV (permutation vector) is looked up at defmethod load time
+      rather than at run time, if the effective method is cached.
+
+Generic functions containing only accessor methods for which no user-defined
+methods on slot-value-using-class apply and which involve only standard-classes:
+      A special dfun is called: one-class, two-class, one-index, or n-n.
+      These were all in May Day PCL.
+Generic functions excluded by the above, which contain accessor methods:
+      In place of each accessor method's method-function, a function returned by
+      get-accessor-method-function is used.
+
+get-accessor-method-function (gf type class slotd) ; type is reader, writer, or boundp.
+  If there is only one applicable method,
+      (This method will be the system supplied one)
+      the function that is returned is optimized for the current state of the
+      class.  When the class changes, it must be recomputed.
+  otherwise,
+      a secondary dispatch function for slot-value-using-class is computed
+      (using what is known about the types of the arguments) and converted 
+      into an accessor function.
+
+get-secondary-dispatch-function (gf methods types &optional method-alist wrappers)
+  The types argument describes what is known about the types of the arguments.
+  Method-alist is used (when supplied) to do things like replace the
+  standard slot-value-using-class method function with a function optimized
+  for what is known about the arguments.
+  Wrappers (when supplied) means that the resulting function is guaranteed to
+  be called only whith those wrappers.  Make-effective-method-function calls
+  the generic-function method-function-for-caching with method-alist and
+  wrappers to get a optimized method function.  (PV lookup is done at the time
+  method-function-for-caching is called).
+
+compute-applicable-methods:  Here I tried to stick with the MOP.
+  The function cache-miss-values looks at the second value of the result of 
+  compute-applicable-methods-using-classes.  If this value is null, we aren't 
+  supposed to cache the result of camuc.  So we don't.  Instead we cache a 
+  result of (default-secondary-dispatch-function gf), which in turn calls 
+  compute-applicable-methods each time it is called.
+---------------------------
+
+To do:
+
+1.   Make the metaobject protocol function symbols be the external symbols
+  of a package, so they can be used easily.
+
+Problem: sometimes there is no need to call a gf's dfun: the emf that is invoked
+         can be cached in the caller's method closure.
+         make-instance is slow.
+2.  In expand-defmethod-internal, optimize calls to generic-functions.
+  Add the support for this optimization.
+
+3.   Make sure that use-dispatch-dfun-p is doing the right thing.
+
+4.   [When CMUCL improves its setf handling, remove the comment in
+   the file macros.lisp beginning the line ";#+cmu (pushnew :setf *features*)"]
+
+
+
+--------------
+1) Generalize expand-defmethod-internal so that it can be used for non-defmethod
+code.  Maybe by (a) having a parameter that says whether it is being called by 
+defmethod, and (b) using the techniques used by the series package (shadowing 
+defun and some others, making the shadowed definitions call e-d-i, making it 
+easy for people to do the relevant package modifications)
+
+2) Extending generic-functions by allowing the user at defgeneric time to supply
+the name of a function which will be supplied (by the system) with a definition
+which will return equivalent results to those returned by the generic function,
+but which will (in some cases) have less checking than the generic function.
+One-class, two-class, and one-index gf dfuns will map to a result of 
+get-optimized-std-accessor-method-function, checking gf dfuns will map to their
+function, and any other dfun will remain the same.
+
+3) Extending expand-defmethod-internal to optimize calls to generic-functions.
+There are a variety of possibilities that need to be considered; one of them
+will be to arrange to call the optimized functions produced by (2) when it
+is known to be safe.  
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index 2d291f27a..577e28001 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -41,7 +41,7 @@
 (defclass method (metaobject) ()
   (:predicate-name method-p))
 
-(defclass standard-method (definition-source-mixin plist-mixin method)
+(defclass standard-method (definition-source-mixin documentation-mixin plist-mixin method)
      ((generic-function
 	:initform nil	
 	:accessor method-generic-function)
@@ -59,18 +59,51 @@
 	:reader method-lambda-list)
       (function
 	:initform nil
-	:initarg :function		;no writer
 	:reader method-function)
       (function-name
         :initform nil
         :accessor method-function-name)
+      (optimized-function
+	:initform nil
+	:accessor method-optimized-function)
       (closure-generator
         :initform nil
 	:reader method-closure-generator)
-;     (documentation
-;	:initform nil
-;	:initarg  :documentation
-;	:reader method-documentation)
+      (cached-functions-alist
+	:initform nil
+        :accessor method-cached-functions-alist
+	:documentation
+	  "Alist of all cached functions of method and the slot-locations/fetchers
+           they're cached for.")
+      (needs-next-methods-p
+        :initform T                             ;Better safe than sorry
+        :initarg :needs-next-methods-p
+        :reader method-needs-next-methods-p
+	:documentation
+	  "Does method call CALL-NEXT-METHOD or NEXT-METHOD-P?")
+      (optimized-slot-indices
+        :initform      NIL
+        :type          list
+        :initarg       :optimized-slot-indices
+        :reader        method-optimized-slot-indices
+        :documentation
+         "List of slot index forms optimized by optimize-instance-access
+          for slot-values within the method body.  Each index is in the
+          form '(index-var parameter slot-name).")
+      (optimized-method-lambda
+        :initform      NIL
+        :type          list
+        :initarg       :optimized-method-lambda
+        :reader        method-optimized-method-lambda
+        :documentation
+         "The optimized PCL method-lambda.  Only stored for methods for
+          which store-optimized-method-lambda-p is T.")
+      (identifier
+        :initform nil
+        :initarg :identifier
+	:reader method-identifier
+	:documentation
+         "Symbol identifier for method used for THIS-METHOD and NO-NEXT-METHOD.")
       )
   (:predicate-name standard-method-p))
 
@@ -89,12 +122,20 @@
 (defclass standard-boundp-method (standard-accessor-method) ()
   (:predicate-name standard-boundp-method-p))
 
+
 (defvar *the-class-method*                    (find-class 'method))
 (defvar *the-class-standard-method*           (find-class 'standard-method))
 (defvar *the-class-standard-reader-method*    (find-class 'standard-reader-method))
 (defvar *the-class-standard-writer-method*    (find-class 'standard-writer-method))
 (defvar *the-class-standard-boundp-method*    (find-class 'standard-boundp-method))
 
+(defmethod accessor-method-slot-definition ((method standard-accessor-method))
+  (let ((slot-name    (accessor-method-slot-name method))
+        (direct-class (car (last (method-specializers method)))))
+    (dolist (direct-slot (class-direct-slots direct-class))
+      (when (eq (slot-definition-name direct-slot) slot-name)
+        (return direct-slot)))))
+
 (defmethod print-object ((method standard-method) stream)
   (printing-random-thing (method stream)
     (let ((generic-function (method-generic-function method))
@@ -115,22 +156,215 @@
 	      (accessor-method-slot-name method)
 	      (unparse-specializers method)))))
 
+(defmethod method-cached-functions ((method standard-method))
+  (mapcar #'cdr (slot-value method 'cached-functions-alist)))
+
+(defvar *generic-functions-having-cached-closures* NIL)
+
+(declaim (ftype (function (T T) (values list list))
+                cached-slot-locations-and-fetchers-from-wrappers))
+(defmethod cached-slot-locations-and-fetchers-from-wrappers ((method standard-method)
+                                                             wrappers)
+  (declare (type list wrappers))
+  (if wrappers
+      (let ((slot-accesses    (method-optimized-slot-indices method))
+            (generic-function (method-generic-function method))
+            (lambda-list      (method-lambda-list method))
+            (accessed-classes NIL)
+            (slot-locations   NIL)
+            (slot-fetchers    NIL))
+        (declare (type list lambda-list accessed-classes
+                            slot-locations slot-fetchers))
+        (dolist (slot-access (reverse slot-accesses))
+          (let* ((wrapper (nth (the index
+                                    (posq (first slot-access) lambda-list))
+                               wrappers))
+                 (class   (wrapper-class wrapper))
+                 (slotd   (find-slot-definition class (second slot-access))))
+            (if (and slotd
+                     (or *safe-to-use-slot-wrapper-optimizations-p*
+                         (slot-values-safe-using-class-p class slotd)))
+                (progn
+                  (push (slot-definition-location slotd) slot-locations)
+                  (unless (memq class accessed-classes)
+                    (let ((cached-in-fns 
+                            (fast-slot-value class 'cached-in-generic-functions
+                                                   slow-slot-value)))
+                      (unless (memq generic-function cached-in-fns)
+                        (fast-set-slot-value class 'cached-in-generic-functions
+                                             (cons generic-function cached-in-fns)
+                                             slow-slot-value)))
+                    (push class accessed-classes)))
+                (push NIL slot-locations))
+           (push (slots-fetcher class) slot-fetchers)))
+        (values slot-locations slot-fetchers))
+    (let ((null-list
+            (make-list
+              (length (the list (method-optimized-slot-indices method))))))
+      (values null-list null-list))))
+
+(defmethod get-cached-function ((method standard-method)
+                                slot-locations
+                                &optional slot-fetchers)
+  (dolist (acons (method-cached-functions-alist method))
+    (when (and (list-eq (caar acons) slot-locations)
+               (or (equal (cdar acons) slot-fetchers)
+                   (null slot-fetchers)))
+      (return (cdr acons)))))
+
+(defmethod add-cached-function ((method standard-method)
+                                function
+                                slot-locations
+                                &optional slot-fetchers)
+  (let ((new-function
+          (set-function-name-1 
+            (method-function-storage-form function)
+            (method-function-name method)
+            nil))
+        (cached-functions
+          (method-cached-functions-alist method)))
+    #+(and kcl turbo-closure) (si:turbo-closure new-function)
+    (dolist (acons cached-functions
+              (setf (method-cached-functions-alist method)
+                    (cons (cons (cons slot-locations slot-fetchers) function)
+                          cached-functions)))
+      (when (and (every #'eql (caar acons) slot-locations)
+                 (or (equal (cdar acons) slot-fetchers)
+                     (null slot-fetchers)))
+        (setf (cdr acons) function)
+        (return)))
+    (setf (method-function-method new-function) method)
+    (pushnew (method-generic-function method)
+             *generic-functions-having-cached-closures* :test #'eq)
+    new-function))
+
+
 ;;; closure-generators are used only by method-function-for-caching
 ;;; and make-not-for-caching-method-function (in vector.lisp).
-(defmethod method-function-for-caching ((method standard-method) wrappers)
-  (let* ((function (slot-value method 'function))
-	 (closure-generator (slot-value method 'closure-generator)))
-    (if closure-generator
-	(let ((new-function (function-funcall closure-generator wrappers)))
-	  (setq new-function (set-function-name-1 new-function
-						  (method-function-name method) nil))
-	  #+(and kcl turbo-closure) (si:turbo-closure new-function)
-	  new-function)
-	function)))
 
 (defmethod method-function-for-caching-p ((method standard-method))
   (slot-value method 'closure-generator))
 
+(defmethod method-function-for-caching ((method standard-method) wrappers)
+  (let* ((closure-generator (slot-value method 'closure-generator)))
+    (if closure-generator
+        (multiple-value-bind (slot-locations slot-fetchers)
+            (cached-slot-locations-and-fetchers-from-wrappers method wrappers)
+          (or (get-cached-function method slot-locations slot-fetchers)
+              (add-cached-function
+                method
+                (method-function-funcall
+                   closure-generator
+                   (list slot-locations slot-fetchers method))
+                slot-locations
+                slot-fetchers)))
+        (let ((optimized-function (slot-value method 'optimized-function)))
+          (if optimized-function
+              optimized-function
+              (error "~A has neither closure-generator nor optimized-function."
+                     method))))))
+
+(defvar *cons-global-variable-table* (make-hash-table :test #'eq))
+
+(defun get-cons-global-variable (cons)
+  (declare (type cons cons))
+  (or (gethash cons *cons-global-variable-table*)
+      (setf (gethash cons *cons-global-variable-table*)
+            (let ((cons-var (gentemp ".CONS")))
+              (eval `(defvar ,cons-var))
+              (set cons-var cons)
+              cons-var))))
+
+(defmethod make-cached-method-function-from-stored-lambda
+           ((method standard-method)
+            slot-locations-and-fetchers)
+  (compile-lambda (make-cached-method-lambda-from-stored-lambda
+                    method slot-locations-and-fetchers)))
+
+(defmethod make-cached-method-lambda-from-stored-lambda
+           ((method standard-method)
+            slot-locations-and-fetchers)
+  (let* ((slot-locations (first  slot-locations-and-fetchers))
+         (slot-fetchers  (second slot-locations-and-fetchers))
+         (method-lambda  (slot-value method 'optimized-method-lambda))
+         (lambda-list    (cadr method-lambda))
+         (body           (cddr method-lambda))
+         (slot-indices
+           (slot-value method 'optimized-slot-indices))
+         (used-slot-locations
+           (mapcar #'(lambda (loc)
+                       (if (consp loc) (get-cons-global-variable loc) loc))
+                   slot-locations)))
+    (multiple-value-bind (documentation declarations real-body)
+       (extract-declarations body)
+      (flet ((access-form (x slot location slots-fetcher)
+               (cond ((typep location 'fixnum)
+                      `(svref (the simple-vector (,slots-fetcher ,x))
+                              ,location))
+                     ((and (symbolp location) (not (null location)))
+                      `(cdr ,location))
+                     ((null location)
+                      `(fast-slot-value ,x ',slot))
+                     (T (error "Unknown slot-location type ~S" location)))))
+       `(lambda ,lambda-list
+          ,@declarations
+          ,@documentation
+          (macrolet
+           ((optimized-parameter-read (x slot index)
+             (declare (ignore index))
+             (cond
+              ,@(mapcar
+                  #'(lambda (slot-index loc slots-fetcher)
+                      (let ((slot-param (first slot-index))
+                            (slot-name  (second slot-index)))
+                       `((and (eq x ',slot-param)
+                              (eq (second slot) ',slot-name))
+                         ,(if loc
+                              ``(let ((.value.
+                                        ,',(access-form slot-param slot-name
+                                                        loc slots-fetcher)))
+                                  (if (eq .value. *slot-unbound*)
+                                      (funcall #'slot-value ,',slot-param
+                                               ',',slot-name)
+                                      .value.))
+                              ``(fast-slot-value ,',slot-param
+                                                 ',',slot-name)))))
+                  slot-indices used-slot-locations slot-fetchers)))
+            (optimized-parameter-write (x slot index new)
+             (declare (ignore index))
+             (cond
+              ,@(mapcar
+                  #'(lambda (slot-index loc slots-fetcher)
+                      (let ((slot-param (first slot-index))
+                            (slot-name  (second slot-index)))
+                       `((and (eq x ',slot-param)
+                              (eq (second slot) ',slot-name))
+                         `(setf ,',(access-form slot-param slot-name
+                                                loc slots-fetcher)
+                                ,new))))
+                  slot-indices used-slot-locations slot-fetchers)))
+            (optimized-parameter-boundp (x slot index)
+             (declare (ignore index))
+             (cond
+              ,@(mapcar
+                  #'(lambda (slot-index loc slots-fetcher)
+                      (let ((slot-param (first slot-index))
+                            (slot-name  (second slot-index)))
+                       `((and (eq x ',slot-param)
+                              (eq (second slot) ',slot-name))
+                         ,(if loc
+                              ``(neq ,',(access-form slot-param slot-name
+                                                     loc slots-fetcher)
+                                     *slot-unbound*)
+                              ``(fast-slot-boundp ,',slot-param
+                                                  ',',slot-name)))))
+                  slot-indices used-slot-locations slot-fetchers))))
+           ,@real-body))))))
+
+
+(defmethod method-function-for-caching-p ((method standard-accessor-method))
+  t)
+
 (defmethod method-function-for-caching ((method standard-accessor-method) wrappers)
   (let* ((slot-name (slot-value method 'slot-name))
 	 (type (cond ((standard-reader-method-p method) 'reader)
@@ -139,11 +373,11 @@
 	 (class (wrapper-class (if (eq type 'writer) (cadr wrappers) (car wrappers))))
 	 (slotd (find-slot-definition class slot-name)))
     (if slotd
-	(slot-accessor-function slotd type)
-	(slot-value method 'function))))
-
-(defmethod method-function-for-caching-p ((method standard-accessor-method))
-  t)
+	(let ((slot-accessor-function (slot-accessor-function slotd type)))
+          (pushnew (cons NIL slot-accessor-function)
+                   (method-cached-functions-alist method) :test #'equal)
+	  slot-accessor-function)
+	(slot-value method 'optimized-function))))
 
 ;;;
 ;;; INITIALIZATION
@@ -160,19 +394,13 @@
           Method objects cannot be reinitialized."
 	 method))
 
-(defmethod legal-documentation-p ((object standard-method) x)
-  (if (or (null x) (stringp x))
-      t
-      "a string or NULL"))
-
 (defmethod legal-lambda-list-p ((object standard-method) x)
-  (declare (ignore x))
-  t)
+  (lambda-list-legal-p x))
 
 (defmethod legal-method-function-p ((object standard-method) x)
-  (if (functionp x)
+  (if (or (null x) (functionp x))
       t
-      "a function"))
+      "is not a function"))
 
 (defmethod legal-qualifiers-p ((object standard-method) x)
   (flet ((improper-list ()
@@ -221,8 +449,12 @@
 					   lambda-list
 					   specializers
 					   function
-					   documentation)
-  (declare (ignore slot-names))
+                                           optimized-function
+                                           closure-generator
+                                           optimized-slot-indices
+                                           documentation)
+  (declare (ignore slot-names closure-generator optimized-slot-indices
+                   documentation))
   (flet ((lose (initarg value string)
 	   (error "When initializing the method ~S:~%~
                    The ~S initialization argument was: ~S.~%~
@@ -232,36 +464,83 @@
 	  (check-lambda-list   (legal-lambda-list-p method lambda-list))
 	  (check-specializers  (legal-specializers-p method specializers))
 	  (check-function      (legal-method-function-p method function))
-	  (check-documentation (legal-documentation-p method documentation)))
+	  (check-optimized-function
+             (legal-method-function-p method optimized-function)))
       (unless (eq check-qualifiers t)
 	(lose :qualifiers qualifiers check-qualifiers))
       (unless (eq check-lambda-list t)
 	(lose :lambda-list lambda-list check-lambda-list))
       (unless (eq check-specializers t)
 	(lose :specializers specializers check-specializers))
+      (unless (eq check-optimized-function t)
+	(lose :optimized-function optimized-function check-optimized-function))
       (unless (eq check-function t)
-	(lose :function function check-function))
-      (unless (eq check-documentation t)
-	(lose :documentation documentation check-documentation)))))
+	(lose :function function check-function)))))
 
 (defmethod shared-initialize :before ((method standard-accessor-method)
 				      slot-names
-				      &key slot-name)
+				      &key
+                                      (check-initargs-legality-p T)
+                                      slot-name
+                                      (slot-definition () slot-def-supplied-p))
   (declare (ignore slot-names))
-  (let ((legalp (legal-slot-name-p method slot-name)))
-    (unless (eq legalp t)
-      (error "The value of the :SLOT-NAME initarg ~A." legalp))))
-
-(defmethod shared-initialize :after ((method standard-method) slot-names 
-				     &key qualifiers)
+  (when check-initargs-legality-p
+    (let ((legalp (legal-slot-name-p method slot-name)))
+      (unless (eq legalp t)
+        (error "The value of the :SLOT-NAME initarg ~A." legalp)))
+    (when (and slot-def-supplied-p
+               (not (*typep slot-definition 'direct-slot-definition)))
+      (error "When initializing the accessor method ~S:~%~
+              The initialization argument :slot-definition was ~A.~%~
+              It must be an instance of a subclass of DIRECT-SLOT-DEFINITION"
+             method slot-definition))))
+
+(defmethod shared-initialize :after ((method standard-method)
+                                     slot-names
+                                     &key
+				     function
+                                     optimized-function
+                                     closure-generator
+                                     identifier
+                                     (qualifiers () qualifiers-p)
+                                     (constant-value () constant-value-p))
   (declare (ignore slot-names))
-  (setf (plist-value method 'qualifiers) qualifiers)
-  (setf (slot-value method 'closure-generator) 
-	(method-function-closure-generator (slot-value method 'function))))
+  (when qualifiers-p
+    (setf (plist-value method 'qualifiers) qualifiers))
+  (when constant-value-p
+    (setf (plist-value method 'constant-value) constant-value))
+  (when function
+    (setf function (method-function-storage-form function))
+    (setf (slot-value method 'function) function)
+    (setf (method-function-method function) method)
+    (pushnew (cons nil function)
+             (method-cached-functions-alist method) :test #'equal))
+  (when optimized-function
+    (setf optimized-function (method-function-storage-form optimized-function))
+    (setf (slot-value method 'optimized-function) optimized-function)
+    (setf (method-function-method optimized-function) method)
+    (pushnew (cons nil optimized-function)
+             (method-cached-functions-alist method) :test #'equal))
+  (when closure-generator
+    (setf (slot-value method 'closure-generator)
+          (method-function-storage-form closure-generator)))
+  (when identifier
+    (setf (get-method-from-identifier identifier) method)))
 
 (defmethod method-qualifiers ((method standard-method))
   (plist-value method 'qualifiers))
 
+(declaim (ftype (function (T) (values T boolean)) method-constant-value))
+(defmethod method-constant-value ((method standard-method))
+  "First value returned is constant value returned by method if it does,
+   second value is whether or not the method has a constant value."
+  (let ((constant-value-or-default
+          (plist-value method 'constant-value 'no-constant-value)))
+    (if (eq constant-value-or-default 'no-constant-value)
+        (values NIL NIL)
+        (values constant-value-or-default T))))
+
+
 
 
 (defclass generic-function (dependent-update-mixin
@@ -286,6 +565,16 @@
       (method-combination
 	:initarg :method-combination
 	:accessor generic-function-method-combination)
+      (lambda-list
+	:initarg  :lambda-list
+        :reader generic-function-lambda-list)
+      (argument-precedence-order
+	:initarg  :argument-precedence-order
+        :reader generic-function-argument-precedence-order)
+      (declarations
+        :initform nil
+	:initarg  :declarations
+        :reader generic-function-declarations)
 
 ;     (permutation
 ;	:accessor gf-permutation)
@@ -313,26 +602,194 @@
 
 
 
+(defmethod store-method-function-p ((generic-function standard-generic-function)
+                                    (method           standard-method)
+                                    initargs)
+  ;; Should methods of this generic-function store their own method-function?
+  ;; Answer is normally T to keep stay compatible with the AMOP even
+  ;; though PCL actually uses the function in method-optimized-function
+  ;; for efficiency.  However, answer can be NIL if the programmer doesn't
+  ;; care about method-functions, which will cut down on binary sizes
+  ;; significantly since it would stop methods from carrying around
+  ;; an extra (unused) method-function.
+  (declare (ignore initargs))
+  *standard-store-method-function-p*)
+
+(defmethod store-method-optimized-function-p
+           ((generic-function standard-generic-function)
+            (method           standard-method)
+            initargs)
+  ;; Should methods of this generic-function store their own
+  ;; method-optimized-function?
+  ;;   Answer better be T unless a closure-generator is stored
+  ;; for the method instead, or if the programmer has redefined the
+  ;; discriminating method function dispatch code to use the
+  ;; documented method-functions rather than the optimized PCL
+  ;; method-optimized-functions,
+  (null (memq :optimized-slot-indices initargs)))
+
+(defmethod store-closure-generator-p
+           ((generic-function standard-generic-function)
+            (method           standard-method)
+            initargs)
+  ;; Should methods of this generic-function store their own
+  ;; method function closure generators?
+  ;;   Answer better be T unless a method-optimized-function is
+  ;; stored instead, or if the programmer has redefined the
+  ;; the discriminating method function dispatch code to use
+  ;; the documented method-functions rather than the optimized
+  ;; PCL method-optimized-functions.
+  (not (null (memq :optimized-slot-indices initargs))))
+
+(defmethod store-optimized-method-lambda-p
+           ((generic-function standard-generic-function)
+            (method           standard-method)
+            initargs)
+  ;;   Should methods of this generic-function store their own
+  ;; their optimized-method-lambdas?
+  ;;   Generally only stored when the method contains slot-value
+  ;; accesses on its parameter lists, in which case the lambda
+  ;; is used to compile the cached method for slot accesses of non
+  ;; :instance allocated slots or non-standard instances at
+  ;; runtime to directly optimize those accesses.
+  (and *compile-slot-access-method-functions-at-runtime-p*
+       (not (null (memq :optimized-slot-indices initargs)))))
+
+(declaim (ftype (function (T T T T) (values list list))
+                make-method-lambda
+                make-optimized-method-lambda))
+ 
+(defmethod make-method-lambda ((generic-function standard-generic-function)
+                               (method           standard-method)
+                               lambda-expression
+                               environment)
+  (multiple-value-bind (optimized-method-lambda initargs)
+      (make-optimized-method-lambda generic-function method
+                                    lambda-expression environment)
+   ;; Pass the optimized-method-lambda back through a global for
+   ;; for macro or accessor expansion.
+   (setf *optimized-method-lambda* optimized-method-lambda)
+   (values
+     (make-documented-standard-method-lambda
+        lambda-expression
+        environment
+        *standard-pcl-make-method-lambda-doc-string*
+        (getf initargs :identifier))
+     initargs)))
+
+(defmethod make-optimized-method-lambda
+           ((generic-function standard-generic-function)
+            (method           standard-method)
+            lambda-expression
+            environment)
+  (make-optimized-standard-method-lambda generic-function method
+                                         lambda-expression environment))
+
+(defmethod make-closure-generator-form
+           ((generic-function standard-generic-function)
+            (method           standard-method)
+            optimized-method-lambda
+            initargs)
+  ;; Closure generators must be in the form of functions whose arguments
+  ;; is a list of the wrappers of the objects passed to a generic function
+  ;; (or null), and which generates the method-optimized-function cached
+  ;; for the generic function when the gf is called with parameters having
+  ;; those wrappers.
+  (make-std-closure-generator-form
+    generic-function method optimized-method-lambda initargs))
+
+(defmethod optimize-instance-access ((generic-function standard-generic-function)
+                                     (method           standard-method)
+                                     (parameter-class  T)
+                                     parameter slots read/write slot-name new-value)
+  (optimize-std-instance-access parameter-class parameter slots read/write
+                                slot-name new-value))
+
+(defmethod optimize-instance-access ((generic-function standard-generic-function)
+                                     (method           standard-method)
+                                     (parameter-class  structure-class)
+                                     parameter slots read/write slot-name new-value)
+  (declare (ignore slots))
+  (let ((slotd (find-slot-definition parameter-class slot-name)))
+    (ecase read/write
+      (:read
+       `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
+      (:write
+       `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)
+         ,new-value))
+      (:boundp
+       'T))))
+
+(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
+  (declare (ignore direct-slot initargs))
+  *the-class-standard-reader-method*)
+
+(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
+  (declare (ignore direct-slot initargs))
+  *the-class-standard-writer-method*)
+
+(defmethod boundp-method-class ((class slot-class) direct-slot &rest initargs)
+  (declare (ignore direct-slot initargs))
+  *the-class-standard-boundp-method*)
+
+(defmethod reader-method-class ((class standard-class)
+                                (direct-slot standard-direct-slot-definition)
+                                &rest initargs)
+  (declare (ignore initargs))
+  *the-class-standard-reader-method*)
+
+(defmethod writer-method-class ((class standard-class)
+                                (direct-slot standard-direct-slot-definition)
+                                &rest initargs)
+  (declare (ignore initargs))
+  *the-class-standard-writer-method*)
+
+(defmethod boundp-method-class ((class standard-class)
+                                (direct-slot standard-direct-slot-definition)
+                                &rest initargs)
+  (declare (ignore initargs))
+  *the-class-standard-boundp-method*)
+
+
+(defmethod reader-method-class ((class funcallable-standard-class)
+                                (direct-slot standard-direct-slot-definition)
+                                &rest initargs)
+  (declare (ignore initargs))
+  *the-class-standard-reader-method*)
+
+(defmethod writer-method-class ((class funcallable-standard-class)
+                                (direct-slot standard-direct-slot-definition)
+                                &rest initargs)
+  (declare (ignore initargs))
+  *the-class-standard-writer-method*)
+
+(defmethod boundp-method-class ((class funcallable-standard-class)
+                                (direct-slot standard-direct-slot-definition)
+                                &rest initargs)
+  (declare (ignore initargs))
+  *the-class-standard-boundp-method*)
+
+
 (defmethod print-object ((generic-function generic-function) stream)
   (named-object-print-function
     generic-function
     stream
-    (list (length (generic-function-methods generic-function)))))
+    (list (length (the list (generic-function-methods generic-function))))))
 
 
 (defmethod shared-initialize :before
 	   ((generic-function standard-generic-function)
 	    slot-names
-	    &key (name nil namep)
+	    &key (check-initargs-legality-p T)
+                 (name nil namep)
 		 (lambda-list () lambda-list-p)
 		 argument-precedence-order
 		 declarations
 		 documentation
 		 (method-class nil method-class-supplied-p)
 		 (method-combination nil method-combination-supplied-p))
-  (declare (ignore slot-names
-		   declarations argument-precedence-order documentation
-		   lambda-list lambda-list-p name))
+
+  (declare (ignore slot-names documentation))
 
   (when namep
     (set-function-name generic-function name))
@@ -353,7 +810,7 @@
 			    "a subclass of the class METHOD"))
 	   (setf (slot-value generic-function 'method-class) method-class))
 	  ((slot-boundp generic-function 'method-class))
-	  (t
+	  (check-initargs-legality-p
 	   (initarg-error :method-class
 			  "not supplied"
 			  "a subclass of the class METHOD")))
@@ -363,10 +820,49 @@
 			    method-combination
 			    "a method combination object")))
 	  ((slot-boundp generic-function 'method-combination))
-	  (t
+	  (check-initargs-legality-p
 	   (initarg-error :method-combination
 			  "not supplied"
-			  "a method combination object")))))
+			  "a method combination object")))
+
+    (cond (lambda-list-p
+           (unless (legal-lambda-list-p generic-function lambda-list)
+             (initarg-error :lambda-list
+                            lambda-list
+                            "lambda list without default initial value forms"))
+           (when argument-precedence-order
+             (unless (and (listp argument-precedence-order)
+                          (permutation-p argument-precedence-order
+                                         (lambda-list-required-args
+                                            lambda-list)))
+               (initarg-error :argument-precedence-order
+                              argument-precedence-order
+                              "permutation of required :lambda-list args"))))
+           (argument-precedence-order
+             (initarg-error :argument-precedence-order
+                            argument-precedence-order
+                            "supplied only when :lambda-list is supplied")))
+    (when (and declarations
+               (not (legal-declarations-p generic-function declarations)))
+      (initarg-error :declarations
+                     declarations
+                     "a legal set of DEFGENERIC declarations"))))
+
+(defmethod shared-initialize :after
+	   ((generic-function standard-generic-function)
+	    slot-names
+	    &key (lambda-list () lambda-list-p)
+		 (argument-precedence-order () argument-precedence-order-p))
+  (declare (ignore slot-names argument-precedence-order))
+  (when (and lambda-list-p (not argument-precedence-order-p))
+    (setf (slot-value generic-function 'argument-precedence-order)
+          (lambda-list-required-args lambda-list))))
+
+(defmethod legal-declarations-p ((object standard-generic-function) x)
+  (listp x))
+
+(defmethod legal-lambda-list-p ((object standard-generic-function) x)
+  (lambda-list-legal-p x NIL (remove '&aux lambda-list-keywords)))
 
 
 #||
@@ -423,33 +919,43 @@
 	  (t
 	   (remove-method generic-function method)))))
 
+(defvar *reinitialize-gf-updates-dfun-p* T)
+
 (defun real-add-named-method (generic-function-name
+                              method-class
 			      qualifiers
 			      specializers
 			      lambda-list
 			      function
+			      optimized-function
+			      closure-generator
 			      &rest other-initargs)
   ;; What about changing the class of the generic-function if there is
   ;; one.  Whose job is that anyways.  Do we need something kind of
   ;; like class-for-redefinition?
-  (let* ((generic-function
+  (let* ((*reinitialize-gf-updates-dfun-p* NIL)
+         (generic-function
 	   (ensure-generic-function generic-function-name
-				    :lambda-list (method-ll->generic-function-ll
-						  lambda-list)))
+	     :lambda-list (method-ll->generic-function-ll lambda-list)))
 	 (specs (parse-specializers specializers))
-;	 (existing (get-method generic-function qualifiers specs nil))
-	 (proto (method-prototype-for-gf generic-function-name))
-	 (new (apply #'make-instance (class-of proto)
-				     :qualifiers qualifiers
-				     :specializers specs
-				     :lambda-list lambda-list
-				     :function function
-				     other-initargs)))
-;   (when existing (remove-method generic-function existing))
+	 (new (apply #'make-instance
+		     method-class
+		     :qualifiers qualifiers
+		     :specializers specs
+		     :lambda-list lambda-list
+		     :function function
+		     :function
+                       (method-function-storage-form function)
+                     :optimized-function
+                       (method-function-storage-form optimized-function)
+                     :closure-generator
+                       (method-function-storage-form closure-generator)
+		     other-initargs)))
     (add-method generic-function new)))
 
 	
 (defun make-specializable (function-name &key (arglist nil arglistp))
+  (declare (type boolean arglistp))
   (cond ((not (null arglistp)))
 	((not (fboundp function-name)))
 	((fboundp 'function-arglist)
@@ -469,6 +975,7 @@
 	(generic-function (make-instance 'standard-generic-function
 					 :name function-name))
 	(nrequireds 0))
+    (declare (type index nrequireds))
     (if (generic-function-p original)
 	original
 	(progn
@@ -481,11 +988,19 @@
 	  (when arglistp
 	    (setf (gf-pretty-arglist generic-function) arglist))
 	  (when original
-	    (add-named-method function-name
-			      ()
-			      (make-list nrequireds :initial-element 't)
-			      arglist
-			      original))
+	    (add-named-method
+              function-name
+              'standard-method
+	      ()
+	      (make-list nrequireds :initial-element 't)
+	      arglist
+              (when (call-store-method-function-p
+                      generic-function
+                      (class-prototype *the-class-standard-method*)
+                      nil)
+                (make-std-documented-method-function original))
+	      original
+              NIL))
 	  generic-function))))
 
 
@@ -521,26 +1036,32 @@
 ;;;       specializes (e.g. for a classical generic-function this is the
 ;;;       list: (1)).
 ;;;
+(declaim (ftype (function (T) (values index boolean list))
+                compute-discriminating-function-arglist-info))
 (defmethod compute-discriminating-function-arglist-info
 	   ((generic-function standard-generic-function))
-  ;;(declare (values number-of-required-arguments &rest-argument-p
-  ;;                 specialized-argument-postions))
+  (declare (values number-of-required-arguments
+                   rest-argument-p
+                   specialized-argument-postions))
   (let ((number-required nil)
         (restp nil)
         (specialized-positions ())
 	(methods (generic-function-methods generic-function)))
+    (declare (type boolean restp) (list specialized-positions methods))
     (dolist (method methods)
       (multiple-value-setq (number-required restp specialized-positions)
         (compute-discriminating-function-arglist-info-internal
 	  generic-function method number-required restp specialized-positions)))
-    (values number-required restp (sort specialized-positions #'<))))
+    (values (the index number-required) restp (sort specialized-positions #'<))))
 
+(declaim (ftype (function (T T T T T) (values index boolean list))
+                compute-discriminating-function-arglist-info-internal))
 (defun compute-discriminating-function-arglist-info-internal
        (generic-function method number-of-requireds restp
 	specialized-argument-positions)
   (declare (ignore generic-function) (type (or null fixnum) number-of-requireds))
   (let ((requireds 0))
-    (declare (fixnum requireds))
+    (declare (type index requireds))
     ;; Go through this methods arguments seeing how many are required,
     ;; and whether there is an &rest argument.
     (dolist (arg (method-lambda-list method))
@@ -548,7 +1069,7 @@
             ((memq arg '(&optional &rest &key))
              (return (setq restp t)))
 	    ((memq arg lambda-list-keywords))
-            (t (incf requireds))))
+            (t (setf requireds (the index (1+ requireds))))))
     ;; Now go through this method's type specifiers to see which
     ;; argument positions are type specified.  Treat T specially
     ;; in the usual sort of way.  For efficiency don't bother to
@@ -562,9 +1083,13 @@
     ;; for the exisiting methods and return them.  Note that if
     ;; num-of-requireds is NIL it means this is the first method
     ;; and we depend on that.
-    (values (min (or number-of-requireds requireds) requireds)
+    (values (the index (if (and number-of-requireds
+                               (< (the index number-of-requireds) requireds))
+                           number-of-requireds
+                           requireds))
             (or restp
-		(and number-of-requireds (/= number-of-requireds requireds)))
+		(and number-of-requireds
+                     (/= (the index number-of-requireds) requireds)))
             specialized-argument-positions)))
 
 (defun make-discriminating-function-arglist (number-required-arguments restp)
@@ -584,34 +1109,40 @@
 	     (:constructor make-arg-info ()))
   arg-info-precedence
   arg-info-metatypes
-  arg-info-number-optional
-  arg-info-key/rest-p
+  (arg-info-number-optional nil :type (or index null))
+  (arg-info-key/rest-p nil :type boolean)
   arg-info-keywords ;nil         no keyword or rest allowed
 	            ;(k1 k2 ..)  each method must accept these keyword arguments
 	            ;T           must have &key or &rest
 
   gf-info-simple-accessor-type ; nil, reader, writer, boundp
-  (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
+  (gf-precompute-dfun-and-emf-p nil :type boolean) ; set by set-arg-info
 
   gf-info-static-c-a-m-emf
-  gf-info-c-a-m-emf-std-p
+  (gf-info-c-a-m-emf-std-p nil :type boolean)
   (arg-info-lambda-list :no-lambda-list))
 
+(declaim (ftype (function (T) boolean) arg-info-valid-p))
 (defun arg-info-valid-p (arg-info)
   (not (null (arg-info-number-optional arg-info))))
 
+(declaim (ftype (function (T) boolean) arg-info-applyp))
 (defun arg-info-applyp (arg-info)
-  (or (plusp (arg-info-number-optional arg-info))
+  (or (plusp (the index (arg-info-number-optional arg-info)))
       (arg-info-key/rest-p arg-info)))
 
+(declaim (ftype (function (T) index) arg-info-number-required))
 (defun arg-info-number-required (arg-info)
-  (length (arg-info-metatypes arg-info)))
+  (length (the list (arg-info-metatypes arg-info))))
 
+(declaim (ftype (function (T) index) arg-info-nkeys))
 (defun arg-info-nkeys (arg-info)
   (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
 
 (defun set-arg-info (gf precedence metatypes number-optional key/rest-p keywords
 			&optional (lambda-list nil lambda-list-p))
+  (declare (type index number-optional)
+           (type boolean key/rest-p lambda-list-p))
   (let ((arg-info (gf-arg-info gf)))
     (setf (arg-info-precedence arg-info) precedence)
     (setf (arg-info-metatypes arg-info) metatypes)
@@ -621,19 +1152,24 @@
     (when lambda-list-p
       (setf (arg-info-lambda-list arg-info) lambda-list))
     (setf (gf-precompute-dfun-and-emf-p arg-info)
-	  (let* ((name (generic-function-name gf))
-		 (sym (if (atom name) name (cadr name)))
-		 (pkg-list (cons *the-pcl-package* 
-				 (package-use-list *the-pcl-package*))))
-	    (not (null (memq (symbol-package sym) pkg-list)))))
+          (the boolean
+	       (let* ((name (generic-function-name gf))
+		      (sym (if (atom name) name (cadr name)))
+		      (pkg-list (cons *the-pcl-package* 
+				      (package-use-list *the-pcl-package*))))
+	         (not (null (memq (symbol-package sym) pkg-list))))))
     arg-info))
 
 (defun new-arg-info-from-generic-function (gf lambda-list argument-precedence-order)
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
       (analyze-lambda-list lambda-list)
-    (declare (ignore allow-other-keys-p))
+    (declare (type index   nreq nopt)
+             (type boolean keysp restp)
+             (type list    keywords)
+             (ignore allow-other-keys-p))
     (let ((metatypes (make-list nreq))
-	  (precedence (compute-precedence lambda-list nreq argument-precedence-order)))
+	  (precedence
+            (compute-precedence lambda-list nreq argument-precedence-order)))
       (set-arg-info gf
 		    precedence
 		    metatypes
@@ -645,6 +1181,8 @@
 (defun new-arg-info-from-method (gf method)
   (multiple-value-bind (nreq nopt keysp restp)
       (analyze-lambda-list (method-lambda-list method))
+    (declare (type index   nreq nopt)
+             (type boolean keysp restp))
     (set-arg-info gf
 		  (compute-precedence (method-lambda-list method) nreq ())
 		  (mapcar #'raise-metatype 
@@ -664,13 +1202,19 @@
 			generic-function
 			(apply #'format nil string args)))
 	       (compare (x y)
+		 (declare (type index x y))
 		 (if (> x y) "more" "fewer")))
 	  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
 	      (analyze-lambda-list (method-lambda-list method))
+            (declare (type index   nreq nopt)
+                     (type boolean keysp restp allow-other-keys-p)
+                     (type list    keywords))
 	    (let ((gf-nreq (arg-info-number-required arg-info))
 		  (gf-nopt (arg-info-number-optional arg-info))
 		  (gf-key/rest-p (arg-info-key/rest-p arg-info))
 		  (gf-keywords (arg-info-keywords arg-info)))
+              (declare (type index   gf-nreq gf-nopt)
+	               (type boolean gf-key/rest-p))
 
 	      (unless (= nreq gf-nreq)
 		(lose "the method has ~A required arguments than the generic function."
@@ -705,6 +1249,7 @@
 			 (metatypes (make-list nreq))
 			 (old-methods (generic-function-methods generic-function))
 			 (methods (remove method old-methods)))
+		    (declare (type index nreq))
 		    (dolist (specls (mapcar #'method-specializers methods))
 		      (setq metatypes (mapcar #'raise-metatype metatypes specls)))
 		    metatypes)
@@ -712,22 +1257,6 @@
 		  (arg-info-key/rest-p arg-info)
 		  (arg-info-keywords arg-info))))
 
-(defmethod generic-function-lambda-list ((gf generic-function))
-  (let ((arg-info (gf-arg-info gf)))
-    (if (or (not (arg-info-valid-p arg-info))
-	    (and (eq ':no-lambda-list (arg-info-lambda-list arg-info))
-		 (null (generic-function-methods gf))))
-	(progn
-	  (warn "No way to determine the lambda list for ~S." gf)
-	  nil)
-	(if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
-	    (let* ((ll (method-lambda-list (car (last (generic-function-methods gf)))))
-		   (k (member '&key ll)))
-	      (if k 
-		  (append (ldiff ll (cdr k)) '(&allow-other-keys))
-		  ll))
-	    (arg-info-lambda-list arg-info)))))
-
 (defmethod initialize-instance :after ((gf standard-generic-function)
 				       &key (lambda-list nil lambda-list-p)
 				       argument-precedence-order)
@@ -737,6 +1266,7 @@
     (update-dfun gf)))
 
 (defmethod reinitialize-instance :after ((gf standard-generic-function)
+					 &rest args
 					 &key (lambda-list nil lambda-list-p)
 					 argument-precedence-order)
   (let* ((arg-info (gf-arg-info gf))
@@ -745,14 +1275,20 @@
       (if (not valid-p)
 	  (new-arg-info-from-generic-function gf lambda-list argument-precedence-order)
 	  (setf (arg-info-lambda-list arg-info) lambda-list)))
-    (when valid-p
+    (when (and *reinitialize-gf-updates-dfun-p*
+               valid-p args
+	       (or (not (eq (car args) 'lambda-list))
+		   (cddr args)))
       (update-dfun gf))))
 
 ;;;
 ;;;
 ;;;
 (defun compute-precedence (lambda-list nreq argument-precedence-order)
+  (declare (type list lambda-list argument-precedence-order))
+  (declare (ignore nreq))
   (let ((nreq (analyze-lambda-list lambda-list)))
+    (declare (type index nreq))
     (if (null argument-precedence-order)
 	(let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list)))
 	(mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))))
@@ -765,6 +1301,13 @@
 	  generic-function args)
   (apply generic-function args))
 
+(defmethod no-next-method ((generic-function standard-generic-function)
+                           (method standard-method)
+                           &rest args)
+  (error
+    "No next method for generic function ~S in method ~S"
+    generic-function method args))
+
 (proclaim '(special *lazy-dfun-compute-p*))
 
 (defun real-add-method (generic-function method)
@@ -793,6 +1336,14 @@
 	       (make-method-spec name
 				 qualifiers
 				 (unparse-specializers specializers))))
+        (unless (slot-boundp generic-function 'lambda-list)
+          (let ((gf-lambda-list
+                  (method-ll->generic-function-ll lambda-list)))
+            (fast-set-slot-value generic-function 'lambda-list gf-lambda-list
+                                 slow-slot-value)
+            (fast-set-slot-value generic-function 'argument-precedence-order
+                                 (lambda-list-required-args gf-lambda-list)
+                                 slow-slot-value)))
 	(add-arg-info generic-function method)
 	(pushnew method (generic-function-methods generic-function))
 	(dolist (specializer specializers)
@@ -801,7 +1352,7 @@
 	(update-dfun generic-function)
 	(maybe-update-constructors generic-function method)
 	method)))
-  
+
 (defun real-remove-method (generic-function method)
   (if  (neq generic-function (method-generic-function method))
        (error "The method ~S is attached to the generic function~@
@@ -819,33 +1370,47 @@
 	 (maybe-update-constructors generic-function method)
 	 generic-function)))
 
-
+;;;
+;;;
+;;;
+
+(declaim (ftype (function (T T) (values boolean boolean))
+                specializer-applicable-using-type-p))
+
 (defun compute-applicable-methods-function (generic-function arguments)
   (values (compute-applicable-methods-using-types 
 	   generic-function
 	   (types-from-arguments generic-function arguments 'eql))))
-  
+
 (defmethod compute-applicable-methods 
     ((generic-function generic-function) arguments)
   (values (compute-applicable-methods-using-types 
 	   generic-function
 	   (types-from-arguments generic-function arguments 'eql))))
 
+(declaim (ftype (function (T T) (values T boolean))
+                compute-applicable-methods-using-classes))
 (defmethod compute-applicable-methods-using-classes 
     ((generic-function generic-function) classes)
   (compute-applicable-methods-using-types 
    generic-function
    (types-from-arguments generic-function classes 'class-eq)))
 
+(declaim (ftype (function (T T) (values list boolean))
+                compute-applicable-methods-using-types))
 (defun compute-applicable-methods-using-types (generic-function types)
   (let ((definite-p t) (possibly-applicable-methods nil))
+    (declare (type boolean definite-p))
     (dolist (method (generic-function-methods generic-function))
       (let ((specls (method-specializers method))
 	    (types types)
 	    (possibly-applicable-p t) (applicable-p t))
+        (declare (type boolean possibly-applicable-p applicable-p))
 	(dolist (specl specls)
 	  (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
 	      (specializer-applicable-using-type-p specl (pop types))
+            (declare (type boolean specl-applicable-p
+                                   specl-possibly-applicable-p))
 	    (unless specl-applicable-p
 	      (setq applicable-p nil))
 	    (unless specl-possibly-applicable-p
@@ -863,8 +1428,11 @@
 (defvar *in-precompute-effective-methods-p* nil)
 
 ;used only in specializer-applicable-using-type-p
+(declaim (ftype (function (T T) (values boolean boolean))
+                class-applicable-using-class-p))
 (defun class-applicable-using-class-p (specl type)
-  (let ((pred (memq specl (class-precedence-list type))))
+  (let ((pred (class-on-class-precedence-list-p specl type)))
+    (declare (type boolean pred))
     (values pred
 	    (or pred
 		(if (not *in-precompute-effective-methods-p*)
@@ -874,89 +1442,128 @@
 		    (classes-have-common-subclass-p specl type))))))
 
 ;used only in map-all-orders
+(declaim (ftype (function (T T) boolean) class-might-precede-p))
 (defun class-might-precede-p (class1 class2)
   (if (not *in-precompute-effective-methods-p*)
-      (not (member class1 (cdr (class-precedence-list class2))))
+      (not (or (eq class1 class2)
+               (class-on-class-precedence-list-p class1 class2)))
       (class-can-precede-p class1 class2)))
 
-(defun saut-and (specl type)
-  (let ((applicable nil)
-	(possibly-applicable t))
+(declaim (ftype (function (T T) (values boolean boolean)) saut-and-p))
+(defun saut-and-p (specl type)
+  (let ((applicable-p nil)
+        (all-solid-p T))
+    (declare (type boolean applicable-p all-solid-p))
     (dolist (type (cdr type))
       (multiple-value-bind (appl poss-appl)
 	  (specializer-applicable-using-type-p specl type)
-	(when appl (return (setq applicable t)))
-	(unless poss-appl (return (setq possibly-applicable nil)))))
-    (values applicable possibly-applicable)))
-
-(defun saut-not (specl type)
+        (declare (type boolean appl poss-appl))
+	(when appl (return (setq applicable-p t)))
+	(unless poss-appl (setq all-solid-p nil))))
+    (values applicable-p (or applicable-p all-solid-p))))
+
+(declaim (ftype (function (T T) (values boolean boolean)) saut-or-p))
+(defun saut-or-p (specl type)
+  ;; T T if all are definitely applicable.
+  ;; If any are definitely unapplicable, then definitely unapplicable.
+  ;; Else NIL NIL.
+  (let ((any-unapplicable-p NIL)
+        (definitely-unapplicable-p NIL))
+    (declare (type boolean any-unapplicable-p definitely-unapplicable-p))
+    (dolist (type (cdr type))
+      (multiple-value-bind (appl poss-appl)
+	  (specializer-applicable-using-type-p specl type)
+        (declare (type boolean appl poss-appl))
+	(unless appl
+          (setq any-unapplicable-p t)
+          (when poss-appl
+            (return (setq definitely-unapplicable-p T))))))
+    (values (not any-unapplicable-p)
+            (or (not any-unapplicable-p) definitely-unapplicable-p))))
+
+(declaim (ftype (function (T T) (values boolean boolean)) saut-not-p))
+(defun saut-not-p (specl type)
   (let ((ntype (cadr type)))
     (values nil
-	    (case (car ntype)
-	      (class      (saut-not-class specl ntype))
-	      (class-eq   (saut-not-class-eq specl ntype))
-	      (eql        (saut-not-eql specl ntype))
-	      (t (error "~s cannot handle the second argument ~s"
-			'specializer-applicable-using-type-p type))))))
-
-(defun saut-not-class (specl ntype)
-  (let* ((class (type-class specl))
-	  (cpl (class-precedence-list class)))
-     (not (memq (cadr ntype) cpl))))
-
-(defun saut-not-class-eq (specl ntype)
+            (the boolean
+	         (case (car ntype)
+	           (class      (saut-not-class-p specl ntype))
+	           (class-eq   (saut-not-class-eq-p specl ntype))
+	           (eql        (saut-not-eql-p specl ntype))
+	           (t (error "~s cannot handle the second argument ~s"
+			     'specializer-applicable-using-type-p type)))))))
+
+(declaim (ftype (function (T T) boolean) saut-not-class-p))
+(defun saut-not-class-p (specl ntype)
+  (not (class-on-class-precedence-list-p (cadr ntype) (type-class specl))))
+
+(declaim (ftype (function (T T) boolean) saut-not-class-eq-p))
+(defun saut-not-class-eq-p (specl ntype)
   (let ((class (case (car specl)
 		 (eql      (class-of (cadr specl)))
 		 (class-eq (cadr specl)))))
     (not (eq class (cadr ntype)))))
 
-(defun saut-not-eql (specl ntype)
+(declaim (ftype (function (T T) boolean) saut-not-class-eql-p))
+(defun saut-not-eql-p (specl ntype)
   (case (car specl)
     (eql (not (eql (cadr specl) (cadr ntype))))
     (t   t)))
 
-(defun saut-class (specl type)
+(declaim (ftype (function (T T) (values boolean boolean)) saut-class-p))
+(defun saut-class-p (specl type)
   (case (car specl)
     (class (class-applicable-using-class-p (cadr specl) (cadr type)))
-    (t     (values nil (let ((class (type-class specl)))
-			 (memq (cadr type)
-			       (class-precedence-list class)))))))
+    (t (values
+          nil
+          (class-on-class-precedence-list-p (cadr type) (type-class specl))))))
 
-(defun saut-class-eq (specl type)
+(declaim (ftype (function (T T) (values boolean boolean)) saut-eq-p))
+(defun saut-class-eq-p (specl type)
   (if (eq (car specl) 'eql)
       (values nil (eq (class-of (cadr specl)) (cadr type)))
       (let ((pred (case (car specl)
-		    (class-eq   (eq (cadr specl) (cadr type)))
-		    (class      (or (eq (cadr specl) (cadr type))
-				    (memq (cadr specl) 
-					  (class-precedence-list (cadr type))))))))
+		    (class-eq (eq (cadr specl) (cadr type)))
+		    (class    (or (eq (cadr specl) (cadr type))
+                                  (class-on-class-precedence-list-p
+			            (cadr specl) (cadr type)))))))
+        (declare (type boolean pred))
 	(values pred pred))))
 
-(defun saut-eql (specl type) 
-  (let ((pred (case (car specl)
-		(eql        (eql (cadr specl) (cadr type)))
-		(class-eq   (eq (cadr specl) (class-of (cadr type))))
-		(class      (memq (cadr specl)
-				  (class-precedence-list 
-				   (class-of (cadr type))))))))
+(declaim (ftype (function (T T) (values boolean boolean)) saut-eql-p))
+(defun saut-eql-p (specl type) 
+  (let ((pred
+          (case (car specl)
+	    (eql      (eql (cadr specl) (cadr type)))
+	    (class-eq (eq (cadr specl) (class-of (cadr type))))
+            (class    (class-on-class-precedence-list-p
+	                (cadr specl) (class-of (cadr type)))))))
+    (declare (type boolean pred))
     (values pred pred)))
 
 (defun specializer-applicable-using-type-p (specl type)
+  (declare (values applicable-p maybe-applicable-p))
   (setq specl (type-from-specializer specl))
   (when (eq specl 't)
     (return-from specializer-applicable-using-type-p (values t t)))
   ;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
   ;; and has only what they need.
+  ;;   If it can't handle it, then it gives up and hopes the normal
+  ;; subtypep can figure it out.
   (if (or (atom type) (eq (car type) 't))
       (values nil t)
       (case (car type)
-	(and        (saut-and specl type))
-	(not        (saut-not specl type))
-	(class      (saut-class specl type))
-	(class-eq   (saut-class-eq specl type))
-	(eql        (saut-eql specl type))
-	(t          (error "~s cannot handle the second argument ~s"
-			   'specializer-applicable-using-type-p type)))))
+	(and        (saut-and-p specl type))
+	(or         (saut-or-p specl type))
+	(not        (saut-not-p specl type))
+	(class      (saut-class-p specl type))
+	(class-eq   (saut-class-eq-p specl type))
+	(eql        (saut-eql-p specl type))
+        (t          (multiple-value-bind (appl certain-p)
+                        (subtypep (convert-to-system-type type)
+                                  (convert-to-system-type specl))
+                      (declare (type boolean appl certain-p))
+                      (values appl (or appl (not certain-p))))))))
 
 (defun proclaim-incompatible-superclasses (classes)
   (setq classes (mapcar #'(lambda (class)
@@ -969,7 +1576,10 @@
       (unless (eq class other-class)
 	(pushnew other-class (class-incompatible-superclass-list class))))))
 
+(declaim (ftype (function (T T) boolean) superclasses-compatible-p))
 (defun superclasses-compatible-p (class1 class2)
+  (assure-finalized class1)
+  (assure-finalized class2)
   (let ((cpl1 (class-precedence-list class1))
 	(cpl2 (class-precedence-list class2)))
     (dolist (sc1 cpl1 t)
@@ -997,15 +1607,17 @@
    (string bit-vector)			; direct subclasses of vector
    ))
 
+(declaim (ftype (function (T T) boolean) classes-have-common-subclass-p))
 (defun classes-have-common-subclass-p (class1 class2)
   (or (eq class1 class2)
       (let ((class1-subs (class-direct-subclasses class1)))
-	(or (memq class2 class1-subs)
+	(or (not (null (memq class2 class1-subs)))
 	    (dolist (class1-sub class1-subs nil)
 	      (when (classes-have-common-subclass-p class1-sub class2)
 		(return t)))))))
 
 (defun order-specializers (specl1 specl2 index compare-classes-function)
+  (declare (type real-function compare-classes-function))
   (let ((type1 (specializer-type specl1))
 	(type2 (specializer-type specl2)))
     (cond ((eq specl1 specl2)
@@ -1031,6 +1643,7 @@
   (sort-methods methods
 		(arg-info-precedence (gf-arg-info generic-function))
 		#'(lambda (class1 class2 index)
+                    (declare (type index index))
 		    (let* ((class (type-class (nth index types)))
 			   (cpl (class-precedence-list class)))
 		      (if (memq class2 (memq class1 cpl))
@@ -1039,6 +1652,7 @@
 (defun sort-methods (methods precedence compare-classes-function)
   (flet ((sorter (method1 method2)
 	   (dolist (index precedence)
+             (declare (type index index))
 	     (let* ((specl1 (nth index (method-specializers method1)))
 		    (specl2 (nth index (method-specializers method2)))
 		    (order (order-specializers 
@@ -1048,6 +1662,7 @@
     (stable-sort methods #'sorter)))
 
 (defun map-all-orders (methods precedence function)
+  (declare (type real-function function))
   (let ((choices nil))
     (flet ((compare-classes-function (class1 class2 index)
 	     (declare (ignore index))
@@ -1105,17 +1720,22 @@
 (defmethod specializer-class ((specializer eql-specializer))
   (class-of (slot-value specializer 'object)))
 
+
+
+
 (defvar *in-gf-arg-info-p* nil)
-(defvar arg-info-reader (make-internal-reader-method-function 'arg-info))
+(defvar arg-info-reader (make-std-reader-method-function 'arg-info))
 
 (defun types-from-arguments (generic-function arguments &optional type-modifier)
   (let* ((arg-info (if *in-gf-arg-info-p*
-		       (function-funcall arg-info-reader generic-function)
+		       (method-function-funcall arg-info-reader generic-function)
 		       (let ((*in-gf-arg-info-p* t))
 			 (gf-arg-info generic-function))))
 	 (metatypes (arg-info-metatypes arg-info))
 	 (types-rev nil))
+    (declare (type list metatypes))
     (dolist (mt metatypes)
+      #-(or excl kcl)
       (declare (ignore mt))
       (unless arguments
 	(error "The function ~S requires at least ~D arguments"
@@ -1126,18 +1746,36 @@
     (values (nreverse types-rev) arg-info)))
 
 (defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
+  (declare (type index nkeys))
   (let* ((w wrappers) (w-tail w) (mt-tail metatypes))
     (dolist (class (if (listp classes) classes (list classes)))
       (unless (eq 't (car mt-tail))
 	(let ((c-w (class-wrapper class)))
-	  (unless c-w (return-from get-wrappers-from-classes nil))
-	  (if (eql nkeys 1)
+          (unless c-w (return-from get-wrappers-from-classes nil))
+	  (if (= nkeys 1)
 	      (setq w c-w)
 	      (setf (car w-tail) c-w
 		    w-tail (cdr w-tail)))))
       (setq mt-tail (cdr mt-tail)))
     w))
 
+(declaim (ftype (function (T T T) (values T T)) accessor-values))
+(defun accessor-values (arg-info classes methods)
+  (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
+	 (accessor-class (case accessor-type
+			   (reader (car classes))
+			   (writer (cadr classes))
+			   (boundp (car classes))))
+	 (slot-name (and accessor-class
+                         (class-standard-p accessor-class)
+			 (accessor-method-slot-name (car methods))))
+	 (slotd (and accessor-class
+		     (find-slot-definition accessor-class slot-name))))
+    (if (and slotd (slot-accessor-std-p slotd accessor-type))
+        (values accessor-type (slot-definition-location slotd))
+        (values nil nil))))
+
+
 ;;;
 ;;; Given a generic function and a set of arguments to that generic function,
 ;;; returns a mess of values.
@@ -1171,8 +1809,11 @@
 ;;;               in the object argument.
 ;;;
 
+(declaim (ftype (function (T T T)
+                          (values T boolean T T T T))
+                cache-miss-values))
 (defun cache-miss-values (gf args state)
-  (let* ((arg-info (function-funcall arg-info-reader gf))
+  (let* ((arg-info (method-function-funcall arg-info-reader gf))
 	 (metatypes (arg-info-metatypes arg-info))
 	 (for-accessor-p (eq state 'accessor))
 	 (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
@@ -1180,6 +1821,9 @@
 	 (args-tail args) (invalid-wrapper-p nil)
 	 (wrappers-rev nil) (dfun-wrappers-rev nil)
 	 (types-rev nil) (classes-rev nil))
+    (declare (type list    metatypes)
+             (type boolean for-accessor-p for-cache-p cam-std-p
+                           invalid-wrapper-p))
     (dolist (mt metatypes)
       (unless args-tail
 	(error "The function ~S requires at least ~D arguments"
@@ -1191,11 +1835,13 @@
 		(let ((wrapper (wrapper-of arg)))
 		  (when (invalid-wrapper-p wrapper)
 		    (setq invalid-wrapper-p t)
-		    (setq wrapper (check-wrapper-validity arg)))
+		    (setq wrapper (fast-check-wrapper-validity arg)))
 		  (push wrapper dfun-wrappers-rev)
 		  (let ((wclass (wrapper-class wrapper)))
 		    (values wrapper wclass `(class-eq ,wclass)))))
-	  (push wrapper wrappers-rev) (push class classes-rev) (push type types-rev))))
+	  (push wrapper wrappers-rev)
+          (push class classes-rev)
+          (push type types-rev))))
     (let* ((wrappers (nreverse wrappers-rev))
 	   (classes (nreverse classes-rev))
 	   (types (mapcar #'(lambda (class) `(class-eq ,class)) classes)))
@@ -1203,57 +1849,46 @@
 	  (if cam-std-p
 	      (compute-applicable-methods-using-types gf types)
 	      (compute-applicable-methods-using-classes gf classes))
+        (declare (type boolean all-applicable-and-sorted-p))
 	(let ((sdfun (if (or all-applicable-and-sorted-p cam-std-p)
-			 (function-funcall (get-secondary-dispatch-function1 
-					    gf methods types
-					    all-applicable-and-sorted-p)
-					   nil (and for-cache-p wrappers))
+                         (funcall-function
+                            (get-secondary-dispatch-function1 
+				    gf methods types
+				    all-applicable-and-sorted-p)
+                            nil
+                            (and for-cache-p wrappers))
 			 (default-secondary-dispatch-function gf))))
 	  (multiple-value-bind (accessor-type index)
-	      (and for-accessor-p all-applicable-and-sorted-p methods
-		   (accessor-values arg-info classes methods))
+              (if (and for-accessor-p all-applicable-and-sorted-p methods)
+		  (accessor-values arg-info classes methods)
+                  (values nil nil))
 	    (values (if (and dfun-wrappers-rev (null (cdr dfun-wrappers-rev)))
 			(car dfun-wrappers-rev)
 			(nreverse dfun-wrappers-rev))
 		    invalid-wrapper-p
 		    sdfun methods accessor-type index)))))))
 
-(defun accessor-values (arg-info classes methods)
-  (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
-	 (accessor-class (case accessor-type
-			   (reader (car classes))
-			   (writer (cadr classes))
-			   (boundp (car classes))))
-	 (slot-name (and accessor-class
-			 (member *the-class-standard-object*
-				 (class-precedence-list accessor-class))
-			 (accessor-method-slot-name (car methods))))
-	 (slotd (and accessor-class
-		     (find-slot-definition accessor-class slot-name))))
-    (when (and slotd 
-	       (slot-accessor-std-p slotd accessor-type))
-      (values accessor-type (slot-definition-location slotd)))))
-
 (defun sdfun-for-caching (gf classes)
   (let ((types (mapcar #'class-eq-type classes)))
     (multiple-value-bind (methods all-applicable-and-sorted-p)
 	(compute-applicable-methods-using-types gf types)
-      (function-funcall (get-secondary-dispatch-function1 
-			 gf methods types all-applicable-and-sorted-p)
-			nil (mapcar #'class-wrapper classes)))))
+      (method-function-funcall
+         (get-secondary-dispatch-function1 
+	   gf methods types all-applicable-and-sorted-p)
+	   nil (mapcar #'class-wrapper classes)))))
 
 (defun value-for-caching (gf classes)
   (let ((methods (compute-applicable-methods-using-types 
 		   gf (mapcar #'class-eq-type classes))))
-    (getf (method-function-plist (method-function (car methods)))
-	  :constant-value)))
+    (method-constant-value (car methods))))
 
 (defun default-secondary-dispatch-function (generic-function)
   #'(lambda (&rest args)
       (let ((methods (compute-applicable-methods generic-function args)))
 	(if methods
-	    (function-apply (get-effective-method-function generic-function methods)
-			    args)
+	    (method-function-apply
+              (get-effective-method-function generic-function methods)
+	      args)
 	    (apply #'no-applicable-method generic-function args)))))
 
 (defun list-eq (x y)
@@ -1264,6 +1899,8 @@
 
 (defvar *std-cam-methods* nil)
 
+(declaim (ftype (function (T) (values T boolean))
+                compute-applicable-methods-emf))
 (defun compute-applicable-methods-emf (generic-function)  
   (if (eq *boot-state* 'complete)
       (let* ((cam (gdefinition 'compute-applicable-methods))
@@ -1277,6 +1914,7 @@
 				    cam (list `(eql ,cam) t)))))))
       (values #'compute-applicable-methods-function t)))
 
+(declaim (ftype (function (T) boolean) compute-applicable-methods-emf-std-p))
 (defun compute-applicable-methods-emf-std-p (gf)
   (gf-info-c-a-m-emf-std-p (gf-arg-info gf)))
 
@@ -1285,21 +1923,22 @@
 (defun update-all-c-a-m-gf-info (c-a-m-gf)
   (let ((methods (generic-function-methods c-a-m-gf)))
     (if (every #'(lambda (old-method)
-		   (member old-method methods))
+		   (memq old-method methods))
 	       *old-c-a-m-gf-methods*)
 	(let ((gfs-to-do nil)
 	      (gf-classes-to-do nil))
 	  (dolist (method methods)
-	    (unless (member method *old-c-a-m-gf-methods*)
+	    (unless (memq method *old-c-a-m-gf-methods*)
 	      (let ((specl (car (method-specializers method))))
 		(if (eql-specializer-p specl)
 		    (pushnew (specializer-object specl) gfs-to-do)
 		    (pushnew (specializer-class specl) gf-classes-to-do)))))
 	  (map-all-generic-functions 
 	   #'(lambda (gf)
-	       (when (or (member gf gfs-to-do)
-			 (dolist (class gf-classes-to-do nil)
-			   (member class (class-precedence-list (class-of gf)))))
+	       (when (or (memq gf gfs-to-do)
+                         (let ((cpl (class-precedence-list (class-of gf))))
+			   (dolist (class gf-classes-to-do nil)
+                             (if (memq class cpl) (return T)))))
 		 (update-c-a-m-gf-info gf)))))
 	(map-all-generic-functions #'update-c-a-m-gf-info))
     (setq *old-c-a-m-gf-methods* methods)))
@@ -1311,6 +1950,7 @@
 (defun update-c-a-m-gf-info (gf)
   (multiple-value-bind (c-a-m-emf std-p)
       (compute-applicable-methods-emf gf)
+    (declare (type boolean std-p))
     (let ((arg-info (gf-arg-info gf)))
       (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
       (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))
@@ -1320,12 +1960,13 @@
     (setf (gf-info-simple-accessor-type arg-info)
 	  (let* ((methods (generic-function-methods gf))
 		 (class (and methods (class-of (car methods))))
-		 (type (and class (cond ((eq class *the-class-standard-reader-method*)
-					 'reader)
-					((eq class *the-class-standard-writer-method*)
-					 'writer)
-					((eq class *the-class-standard-boundp-method*)
-					 'boundp)))))
+		 (type (and class
+                           (cond ((eq class *the-class-standard-reader-method*)
+				  'reader)
+				 ((eq class *the-class-standard-writer-method*)
+				  'writer)
+				 ((eq class *the-class-standard-boundp-method*)
+				  'boundp)))))
 	    (when (and (gf-info-c-a-m-emf-std-p arg-info)
 		       type
 		       (dolist (method (cdr methods) t)
@@ -1334,57 +1975,137 @@
 			   *standard-method-combination*))
 	      type)))))
 
+(declaim (ftype (function (T T) boolean)
+                accessor-methods-safe-to-use-slot-wrapper-optimizations-p))
+(defun accessor-methods-safe-to-use-slot-wrapper-optimizations-p
+       (methods type)
+  ;; Returns whether all accessor-methods Methods are safe for the slot-value
+  ;; wrapper optimizations.
+  (let ((safe-specializers
+          (ecase type
+            (reader *safe-slot-value-using-class-specializers*)
+            (writer *safe-set-slot-value-using-class-specializers*)
+            (boundp *safe-slot-boundp-using-class-specializers*))))
+    (declare (type list safe-specializers))
+    (dolist (method methods T)
+      (unless (member (mapcar #'class-name (method-specializers method))
+                      safe-specializers :test #'equal)
+        (return NIL)))))
+
+(declaim (ftype (function (T T) boolean) slot-values-safe-using-class-p))
+(defun slot-values-safe-using-class-p (class slotd)
+  (let ((types1 (list class (class-prototype class) slotd)))
+    (and (or *safe-to-use-slot-value-wrapper-optimizations-p*
+             (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
+               (compute-applicable-methods #'slot-value-using-class types1)
+               'reader))
+         (or *safe-to-use-set-slot-value-wrapper-optimizations-p*
+             (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
+               (compute-applicable-methods
+                 (gdefinition '(setf slot-value-using-class)) (cons T types1))
+               'writer))
+         (or *safe-to-use-slot-boundp-wrapper-optimizations-p*
+             (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
+               (compute-applicable-methods #'slot-boundp-using-class types1)
+               'boundp)))))
+
+                                       
+(declaim (ftype (function (T T T T) (values function boolean))
+                get-accessor-method-function))
 (defun get-accessor-method-function (gf type class slotd)  
-  (let* ((std-method (standard-svuc-method type))
-	 (str-method (structure-svuc-method type))
-	 (types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
+  (let* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
 	 (types (if (eq type 'writer) `(t ,@types1) types1))
 	 (methods (compute-applicable-methods-using-types gf types))
-	 (std-p (null (cdr methods))))
+	 (std-p (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
+                  methods type)))
+    (declare (type list methods) (type boolean std-p))
     (values
      (if std-p
 	 (get-optimized-std-accessor-method-function class slotd type)
-	 (get-accessor-from-svuc-method-function
-	  class slotd
-	  (get-secondary-dispatch-function 
-	   gf methods types
-	   `((,(car (or (member std-method methods)
-			(member str-method methods)
-			(error "error in get-accessor-method-function")))
-	      ,(get-optimized-std-slot-value-using-class-method-function
-		class slotd type)))
+	 (let ((wrappers NIL))
 	   (unless (and (eq type 'writer)
 			(dolist (method methods t)
 			  (unless (eq (car (method-specializers method))
 				      *the-class-t*)
 			    (return nil))))
-	     (let ((wrappers (list (wrapper-of class)
-				   (class-wrapper class)
-				   (wrapper-of slotd))))
-	       (if (eq type 'writer)
-		   (cons (class-wrapper *the-class-t*) wrappers)
-		   wrappers))))
-	  type))
+             (setf wrappers (list (wrapper-of class)
+				  (class-wrapper class)
+				  (wrapper-of slotd)))
+	     (when (eq type 'writer)
+	       (setf wrappers (cons (class-wrapper *the-class-t*) wrappers))))
+	   (get-accessor-from-svuc-method-function
+	    class slotd
+	    (get-secondary-dispatch-function 
+	     gf methods types
+             (let ((alist ()))
+               (dolist (method (reverse methods))
+                 (push (list method
+                             (method-function-for-caching method wrappers))
+                       alist))
+               alist)
+             wrappers)
+	    type)))
      std-p)))
 
 (defvar *new-class* nil)
 
 ;used by optimize-slot-value-by-class-p (vector.lisp)
 (defun update-slot-value-gf-info (gf type)
-  (unless *new-class*
-    (update-std-or-str-methods gf type))
-  (when (and (standard-svuc-method type) (structure-svuc-method type))
-    (flet ((update-class (class)
-	     (when (class-finalized-p class)
-	       (dolist (slotd (class-slots class))
-		 (multiple-value-bind (function std-p)
-		     (get-accessor-method-function gf type class slotd)
-		   #+kcl (si:turbo-closure function)
-		   (setf (slot-accessor-std-p slotd type) std-p)
-		   (setf (slot-accessor-function slotd type) function))))))
-      (if *new-class*
-	  (update-class *new-class*)
-	  (map-all-classes #'update-class 'slot-object)))))
+  (let* ((old-safe-p
+           (ecase type
+             (reader *safe-to-use-slot-value-wrapper-optimizations-p*)
+             (writer *safe-to-use-set-slot-value-wrapper-optimizations-p*)
+             (boundp *safe-to-use-slot-boundp-wrapper-optimizations-p*)))
+         (newly-unsafe-p
+           (and old-safe-p
+                (not (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
+                     (generic-function-methods gf) type)))))
+    (declare (type boolean old-safe-p newly-unsafe-p))
+    (unless *new-class*
+      (update-std-or-str-methods gf type))
+    (when (and (standard-svuc-method type) (structure-svuc-method type))
+      (flet ((update-class (class)
+	       (when (class-finalized-p class)
+	         (dolist (slotd (class-slots class))
+		    (multiple-value-bind (function std-p)
+		        (get-accessor-method-function gf type class slotd)
+		      #+kcl (si:turbo-closure function)
+		      (setf (slot-accessor-std-p slotd type) std-p)
+                      (update-slot-accessor-function slotd type function T))
+                    (when newly-unsafe-p
+                      (ecase type
+                        (reader (initialize-internal-slot-reader-gfs
+                                  (slot-definition-name slotd)))
+                        (writer (initialize-internal-slot-writer-gfs
+                                  (slot-definition-name slotd)))
+                        (boundp (initialize-internal-slot-boundp-gfs
+                                  (slot-definition-name slotd)))))))))
+        (if *new-class*
+	    (update-class *new-class*)
+	    (map-all-classes #'update-class 'slot-object))))
+    (when newly-unsafe-p
+      (when *always-safe-to-use-slot-wrapper-optimizations-p*
+        (cerror "Continue even though previously compiled slot-value accesses
+                 might ignore it?"
+                "Defining user ~S method when PCL was told to assume there
+                 wouldn't be any (~S was set to T)."
+                (generic-function-name gf)
+                '*always-safe-to-use-slot-wrapper-optimizations-p*)
+        (setf *always-safe-to-use-slot-wrapper-optimizations-p* NIL))
+      (setf *safe-to-use-slot-wrapper-optimizations-p* NIL)
+      (ecase type
+        (reader
+	 (setf *safe-to-use-slot-value-wrapper-optimizations-p* NIL))
+        (writer
+	 (setf *safe-to-use-set-slot-value-wrapper-optimizations-p* NIL))
+        (boundp
+	 (setf *safe-to-use-slot-boundp-wrapper-optimizations-p* NIL))))
+    (unless *safe-to-use-slot-wrapper-optimizations-p*
+      (dolist (gf *generic-functions-having-cached-closures*)
+        (update-dfun gf)))
+    (fix-dfuns-needing-update)))
+
+
 
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
@@ -1456,35 +2177,42 @@
 (defmacro with-equal-hash-table ((table) &body forms)
   `(with-hash-table (,table equal) ,@forms))
 
+(declaim (ftype (function (T T &optional T)
+                          (values T T T T (or index null) boolean))
+                make-accessor-table))
 (defun make-accessor-table (generic-function type &optional table)
   (unless table (setq table (make-hash-table :test 'eq)))
   (let ((methods (generic-function-methods generic-function))
 	(all-index nil)
 	(no-class-slots-p t)
 	first second (size 0))
-    (declare (fixnum size))
+    (declare (type index size) (type boolean no-class-slots-p))
     ;; class -> {(specl slotd)}
     (dolist (method methods)
 	(let* ((specializers (method-specializers method))
 	       (specl (if (eq type 'reader)
 			  (car specializers)
 			  (cadr specializers)))
-	       (specl-cpl (class-precedence-list specl))
-	       (so-p (member *the-class-standard-object* specl-cpl))
+               (standard-object-p (class-standard-p specl))
 	       (slot-name (accessor-method-slot-name method)))
-	  (when (member *the-class-structure-object* specl-cpl)
+          (declare (type boolean standard-object-p))
+	  (when (and (not standard-object-p)
+                     (class-on-class-precedence-list-p
+                       *the-class-structure-object* specl))
 	    (return-from make-accessor-table nil))
-	  (maphash #'(lambda (class slotd)
-		       (let ((cpl (class-precedence-list class)))
-			 (when (memq specl cpl)
-			   (unless (and (or so-p
-					    (member *the-class-standard-object* cpl))
-					(slot-accessor-std-p slotd type))
-			     (return-from make-accessor-table nil))
-			   (push (cons specl slotd) (gethash class table)))))
-		   (gethash slot-name *name->class->slotd-table*))))
+          (let ((slotd-table (gethash slot-name *name->class->slotd-table*)))
+            (when slotd-table
+	      (maphash #'(lambda (class slotd)
+                           (when (class-on-class-precedence-list-p specl class)
+			     (unless (and (or standard-object-p
+                                              (class-standard-p class))
+					  (slot-accessor-std-p slotd type))
+			       (return-from make-accessor-table nil))
+			     (push (cons specl slotd) (gethash class table))))
+		       slotd-table)))))
     (maphash #'(lambda (class specl+slotd-list)
-		 (dolist (sclass (class-precedence-list class) 
+                 (assure-finalized class)
+		 (dolist (sclass (class-precedence-list class)
 			  (error "This can't happen"))
 		   (let ((a (assq sclass specl+slotd-list)))
 		     (when a
@@ -1496,7 +2224,7 @@
 			 (setq all-index (if (or (null all-index)
 						 (eql all-index index))
 					     index t))
-			 (incf size)
+			 (setf size (the index (1+ size)))
 			 (cond ((= size 1) (setq first class))
 			       ((= size 2) (setq second class)))
 			 (return nil))))))
@@ -1548,12 +2276,14 @@
 	 (wrappers (unless (eq nkeys 1) (make-list nkeys)))
 	 (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
 	 (default '(default)))
+    (declare (type index nkeys)
+             (type boolean precompute-p))
     (flet ((add-class-list (classes)
 	     (when (or (null new-class) (memq new-class classes))
 	       (let ((wrappers (get-wrappers-from-classes 
-				nkeys wrappers classes metatypes)))
+				 nkeys wrappers classes metatypes)))
 		 (when (and wrappers
-			    (eq default (probe-cache cache wrappers default)))
+                            (eq default (probe-cache cache wrappers default)))
 		   (let ((value (cond ((eq valuep t)
 				       (sdfun-for-caching generic-function classes))
 				      ((eq valuep :constant-value)
@@ -1566,6 +2296,7 @@
 		  (mec-all-class-lists (method-specializers method) precompute-p))))
       cache)))
 
+(declaim (ftype (function (T) boolean) methods-contain-eql-specializer-p))
 (defun methods-contain-eql-specializer-p (methods)
   (dolist (method methods nil)
     (when (dolist (spec (method-specializers method) nil)
@@ -1579,10 +2310,14 @@
 	 `(not (eq *the-class-built-in-class* 
 		(wrapper-class (std-instance-wrapper (class-of ,arg))))))
 	((eq class *the-class-standard-object*)
-	 `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
-	;; TYPEP is now faster than doing memq of the cpl
+	 `(or (std-instance-p ,arg)
+              (fsc-instance-p ,arg)
+              (typep ,arg 'standard-object)))
+	((or (structure-class-p class)
+             (eq (class-of class) *the-class-built-in-class*))
+	 `(typep ,arg ',(class-name class)))
 	(t
-	 `(typep ,arg ',(class-name class)))))
+	 `(memq ',class (class-precedence-list (class-of ,arg))))))
 
 (defmacro class-eq-test (arg class)
   `(eq (class-of ,arg) ',class))
@@ -1599,8 +2334,8 @@
   `(let ((.case-arg. ,arg))
      (cond ,@(mapcar #'(lambda (clause)
 			 (list* (cond ((listp (car clause))
-				       `(member .case-arg. ',(car clause)))
-				      ((member (car clause) '(t otherwise))
+				       `(memq .case-arg. ',(car clause)))
+				      ((memq (car clause) '(t otherwise))
 				       `t)
 				      (t
 				       `(eql .case-arg. ',(car clause))))
@@ -1644,7 +2379,7 @@
 					     (dnet-methods-p false-value)))
 				    'mcase
 				    'scase))
-		      (type-sym (if (member (cadr type) '(t nil otherwise))
+		      (type-sym (if (memq (cadr type) '(t nil otherwise))
 				    `(,(cadr type))
 				    (cadr type))))
 		 `(,case-sym ,arg
@@ -1713,74 +2448,83 @@
 	    new-type
 	    `(and ,new-type ,@so-far)))))
 
-#+lcl3.0 (dont-use-production-compiler)
-
-(defun generate-discrimination-net-internal 
+(defun generate-discrimination-net-internal-do-column (p-tail contenders known-types)
+  (declare (special types methods-function nreq metatypes))
+  (if p-tail
+      (let* ((position (car p-tail))
+	     (known-type (or (nth position types) t)))
+        (declare (type index position))
+	(if (eq (nth position metatypes) 't)
+	    (generate-discrimination-net-internal-do-column
+              (cdr p-tail) contenders (cons (cons position known-type) known-types))
+	    (generate-discrimination-net-internal-do-methods
+               p-tail contenders known-type () known-types)))
+      (funcall-function methods-function contenders 
+	       (let ((k-t (make-list (the index nreq))))
+		 (dolist (index+type known-types)
+		   (setf (nth (the index (car index+type)) k-t)
+		         (cdr index+type)))
+	         k-t))))
+
+(defun generate-discrimination-net-internal-do-methods
+   (p-tail contenders known-type winners known-types)
+  (declare (special test-function type-function))
+  ;;
+  ;; <contenders>
+  ;;   is a (sorted) list of methods that must be discriminated
+  ;; <known-type>
+  ;;   is the type of this argument, constructed from tests already made.
+  ;; <winners>
+  ;;   is a (sorted) list of methods that are potentially applicable
+  ;;   after the discrimination has been made.
+  ;;   
+  (if (null contenders)
+      (generate-discrimination-net-internal-do-column
+        (cdr p-tail) winners (cons (cons (car p-tail) known-type) known-types))
+      (let* ((position (car p-tail))
+	     (method (car contenders))
+	     (specl (nth position (method-specializers method)))
+             (type (funcall-function type-function (type-from-specializer specl))))
+        (declare (type index position))
+	(multiple-value-bind (app-p maybe-app-p)
+	   (specializer-applicable-using-type-p type known-type)
+          (declare (type boolean app-p maybe-app-p))
+	  (flet ((determined-to-be (truth-value)
+		   (if truth-value app-p (not maybe-app-p)))
+		 (do-if (truth &optional implied)
+		   (let ((ntype (if truth type `(not ,type))))
+		     (generate-discrimination-net-internal-do-methods p-tail
+			(cdr contenders)
+			(if implied
+			    known-type
+			    (augment-type ntype known-type))
+			(if truth
+			    (append winners `(,method))
+			    winners)
+			known-types))))
+	    (cond ((determined-to-be nil) (do-if nil t))
+		  ((determined-to-be t)   (do-if t   t))
+		  (t (funcall-function test-function position type 
+			               (do-if t) (do-if nil)))))))))
+
+(defun generate-discrimination-net-internal
     (gf methods types methods-function test-function type-function)
+  (declare (special types methods-function test-function type-function))
   (let* ((arg-info (gf-arg-info gf))
 	 (precedence (arg-info-precedence arg-info))
 	 (nreq (arg-info-number-required arg-info))
 	 (metatypes (arg-info-metatypes arg-info)))
-    (labels ((do-column (p-tail contenders known-types)
-	       (if p-tail
-		   (let* ((position (car p-tail))
-			  (known-type (or (nth position types) t)))
-		     (if (eq (nth position metatypes) 't)
-			 (do-column (cdr p-tail) contenders
-				    (cons (cons position known-type) known-types))
-			 (do-methods p-tail contenders 
-				     known-type () known-types)))
-		   (funcall methods-function contenders 
-			    (let ((k-t (make-list nreq)))
-			      (dolist (index+type known-types)
-				(setf (nth (car index+type) k-t) (cdr index+type)))
-			      k-t))))			      
-	     (do-methods (p-tail contenders known-type winners known-types)
-	       ;;
-               ;; <contenders>
-	       ;;   is a (sorted) list of methods that must be discriminated
-               ;; <known-type>
-	       ;;   is the type of this argument, constructed from tests already made.
-               ;; <winners>
-	       ;;   is a (sorted) list of methods that are potentially applicable
-	       ;;   after the discrimination has been made.
-	       ;;   
-               (if (null contenders)
-		   (do-column (cdr p-tail) winners
-			      (cons (cons (car p-tail) known-type) known-types))
-                   (let* ((position (car p-tail))
-			  (method (car contenders))
-			  (specl (nth position (method-specializers method)))
-                          (type (funcall type-function (type-from-specializer specl))))
-		     (multiple-value-bind (app-p maybe-app-p)
-			 (specializer-applicable-using-type-p type known-type)
-		       (flet ((determined-to-be (truth-value)
-				(if truth-value app-p (not maybe-app-p)))
-			      (do-if (truth &optional implied)
-				(let ((ntype (if truth type `(not ,type))))
-				  (do-methods p-tail
-				    (cdr contenders)
-				    (if implied
-					known-type
-					(augment-type ntype known-type))
-				    (if truth
-					(append winners `(,method))
-					winners)
-				    known-types))))
-			 (cond ((determined-to-be nil) (do-if nil t))
-			       ((determined-to-be t)   (do-if t   t))
-			       (t (funcall test-function position type 
-					   (do-if t) (do-if nil))))))))))
-      (do-column precedence methods ()))))
-
-#+lcl3.0 (use-previous-compiler)
+    (declare (type index nreq))
+    (declare (special nreq metatypes))
+      (generate-discrimination-net-internal-do-column precedence methods ())))
 
 (defun compute-secondary-dispatch-function (generic-function net &optional 
 					    method-alist wrappers)
-  (function-funcall (compute-secondary-dispatch-function1 generic-function net)
+  (funcall-function (compute-secondary-dispatch-function1 generic-function net)
 		    method-alist wrappers))
 
 (defvar *case-table-limit* 10)
+(declaim (type index *case-table-limit*))
 
 (defun net-test-converter (form)
   (cond ((and (consp form) (eq (car form) 'methods))
@@ -1788,10 +2532,11 @@
 	((and (consp form) (eq (car form) 'unordered-methods))
 	 '.umethods.)
 	((and (consp form) (eq (car form) 'mcase)
-	      (< *case-table-limit* (length (cddr form))))
+	      (< *case-table-limit* (length (the list (cddr form)))))
 	 '.mcase.)
 	(t (default-test-converter form))))
 
+(declaim (ftype (function (T T T) (values T list)) net-code-converter))
 (defun net-code-converter (form metatypes applyp)
   (cond ((and (consp form) (or (eq (car form) 'methods)
 			       (eq (car form) 'unordered-methods)))
@@ -1799,7 +2544,7 @@
 	   (values (make-dfun-call metatypes applyp gensym)
 		   (list gensym))))
 	((and (consp form) (eq (car form) 'mcase)
-	      (< *case-table-limit* (length (cddr form))))
+	      (< *case-table-limit* (length (the list (cddr form)))))
 	 (let ((gensym (gensym)) (default (gensym)))
 	   (values (make-dfun-call metatypes applyp 
 				   `(gethash ,(cadr form) ,gensym ,default))
@@ -1810,7 +2555,7 @@
   (or (let ((c (methods-converter form generic-function)))
 	(when c (list c)))
       (cond ((and (consp form) (eq (car form) 'mcase)
-		  (< *case-table-limit* (length (cddr form))))
+		  (< *case-table-limit* (length (the list (cddr form)))))
 	     (let* ((list (mapcar #'(lambda (clause)
 				      (let ((key (car clause))
 					    (meth (cadr clause)))
@@ -1852,6 +2597,7 @@
 	  (let* ((arg-info (gf-arg-info generic-function))
 		 (metatypes (arg-info-metatypes arg-info))
 		 (applyp (arg-info-applyp arg-info)))
+            (declare (type boolean applyp))
 	    (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp) ,net)
 			   #'net-test-converter
 			   #'(lambda (form)
@@ -1859,7 +2605,8 @@
 			   #'(lambda (form)
 			       (net-constant-converter form generic-function))))
 	#'(lambda (method-alist wrappers)
-	    (apply cfunction
+	    (apply-function
+                   cfunction
 		   (mapcar #'(lambda (constant)
 			       (or (convert-table constant method-alist wrappers)
 				   (convert-methods constant method-alist wrappers)))
@@ -1875,7 +2622,7 @@
       (let* ((types (types-from-arguments generic-function args 'eql))
 	     (smethods (sort-applicable-methods generic-function methods types))
 	     (emf (get-effective-method-function generic-function smethods)))
-	(function-apply emf args))))
+	(apply-function emf args))))
 
 ;;;
 ;;; NOTE: We are assuming a restriction on user code that the method
@@ -1890,9 +2637,10 @@
 ;;; Don't clear this table!  
 (defvar *effective-method-table* (make-hash-table :test 'eq))
 
+
 (defun get-secondary-dispatch-function (gf methods types &optional 
 							 method-alist wrappers)
-  (function-funcall (get-secondary-dispatch-function1 
+  (funcall-function (get-secondary-dispatch-function1 
 		     gf methods types
 		     (not (methods-contain-eql-specializer-p methods)))
 		    method-alist wrappers))
@@ -1931,7 +2679,7 @@
 	(compute-secondary-dispatch-function1 gf net))))
 
 (defun get-effective-method-function (gf methods &optional method-alist wrappers)
-  (function-funcall (get-secondary-dispatch-function1 gf methods nil t)
+  (funcall-function (get-secondary-dispatch-function1 gf methods nil t)
 		    method-alist wrappers))
 
 (defun get-effective-method-function1 (gf methods &optional (sorted-p t))
@@ -1939,7 +2687,7 @@
 
 (defun get-dispatch-function (gf)
   (let ((methods (generic-function-methods gf)))
-    (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil)
+    (funcall-function (get-secondary-dispatch-function1 gf methods nil nil nil)
 		      nil nil)))
 
 ;;;
@@ -2038,15 +2786,15 @@
 
 (defun slot-value-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-reader-function slotd) object))
+  (method-function-funcall (slot-definition-reader-function slotd) object))
 
 (defun setf-slot-value-using-class-dfun (new-value class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-writer-function slotd) new-value object))
+  (method-function-funcall (slot-definition-writer-function slotd) new-value object))
 
 (defun slot-boundp-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (function-funcall (slot-definition-boundp-function slotd) object))
+  (method-function-funcall (slot-definition-boundp-function slotd) object))
 
 (defmethod compute-discriminating-function ((gf standard-generic-function))
   (with-slots (dfun-state arg-info) gf
@@ -2080,14 +2828,17 @@
 (defun update-dfun (generic-function &optional dfun cache info)
   (let ((ocache (gf-dfun-cache generic-function)))
     (set-dfun generic-function dfun cache info)
-    (setq dfun (doctor-dfun-for-the-debugger 
-		generic-function
-		(set-function-name
-		 (compute-discriminating-function generic-function)
-		 (generic-function-name generic-function))))
-    (set-funcallable-instance-function generic-function dfun)
-    (when (and ocache (not (eq ocache cache))) (free-cache ocache))
-    dfun))
+    (let ((dfun (compute-discriminating-function generic-function))
+	  (gf-name (generic-function-name generic-function)))
+      (unless (eq 'default-method-only (type-of (gf-dfun-info generic-function)))
+	(setq dfun (doctor-dfun-for-the-debugger 
+		    generic-function
+		    #+cmu dfun #-cmu (set-function-name dfun gf-name))))
+      (set-funcallable-instance-function generic-function dfun)
+      #+cmu (set-function-name generic-function gf-name)
+      (when (and ocache (not (eq ocache cache))) (free-cache ocache))
+      (setf *dfuns-needing-update* (remove gf-name *dfuns-needing-update*))
+      dfun)))
 
 (defmethod update-gf-dfun ((class std-class) gf)
   (let ((*new-class* class)
@@ -2108,28 +2859,65 @@
 ;;;
 ;;;
 ;;;
+(declaim (ftype (function (T) (values list boolean)) function-keywords))
 (defmethod function-keywords ((method standard-method))
   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
       (analyze-lambda-list (method-lambda-list method))
+    (declare (type boolean allow-other-keys-p))
     (declare (ignore nreq nopt keysp restp))
     (values keywords allow-other-keys-p)))
 
 (defun method-ll->generic-function-ll (ll)
-  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
-      (analyze-lambda-list ll)
-    (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
-    (remove-if #'(lambda (s)
-		   (or (memq s keyword-parameters)
-		       (eq s '&allow-other-keys)))
-	       ll)))
+  ;; The generic-function lambda-list is the same as the method-lambda
+  ;; list, except that no default initial values or supplied-p
+  ;; parameters are allowed for optional or keyword arguments, and
+  ;; &aux parameters are not allowed (and therefore removed).
+  (let ((collection NIL))
+    (dolist (element ll)
+      (cond ((listp element)
+             (push (car element) collection))
+            ((eq element '&aux)
+             (return))
+            (T (push element collection))))
+    (nreverse collection)))
+
 
-
 ;;;
 ;;; This is based on the rules of method lambda list congruency defined in
 ;;; the spec.  The lambda list it constructs is the pretty union of the
 ;;; lambda lists of all the methods.  It doesn't take method applicability
 ;;; into account at all yet.
 ;;; 
+
+(declaim (ftype (function (T) (values list list boolean list boolean))
+                method-pretty-arglist))
+(defmethod method-pretty-arglist ((method standard-method))
+  (let ((required ())
+	(optional ())
+	(rest-p nil)
+	(key ())
+	(allow-other-keys-p nil)
+	(state 'required)
+	(arglist (method-lambda-list method)))
+    (declare (type boolean rest-p allow-other-keys-p))
+    (dolist (arg arglist)
+      (cond ((eq arg '&optional)         (setq state 'optional))
+	    ((eq arg '&rest)             (setq state 'rest))
+	    ((eq arg '&key)              (setq state 'key))
+	    ((eq arg '&allow-other-keys) (setq allow-other-keys-p 't))
+	    ((memq arg lambda-list-keywords))
+	    (t
+	     (ecase state
+	       (required (push arg required))
+	       (optional (push arg optional))
+	       (key      (push arg key))
+	       (rest     (setq rest-p arg))))))
+    (values (nreverse required)
+	    (nreverse optional)
+	    rest-p
+	    (nreverse key)
+	    allow-other-keys-p)))
+
 (defmethod generic-function-pretty-arglist
 	   ((generic-function standard-generic-function))
   (let ((methods (generic-function-methods generic-function))
@@ -2159,29 +2947,3 @@
 	(nconc required arglist)))))
   
 
-(defmethod method-pretty-arglist ((method standard-method))
-  (let ((required ())
-	(optional ())
-	(rest nil)
-	(key ())
-	(allow-other-keys nil)
-	(state 'required)
-	(arglist (method-lambda-list method)))
-    (dolist (arg arglist)
-      (cond ((eq arg '&optional)         (setq state 'optional))
-	    ((eq arg '&rest)             (setq state 'rest))
-	    ((eq arg '&key)              (setq state 'key))
-	    ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
-	    ((memq arg lambda-list-keywords))
-	    (t
-	     (ecase state
-	       (required (push arg required))
-	       (optional (push arg optional))
-	       (key      (push arg key))
-	       (rest     (setq rest arg))))))
-    (values (nreverse required)
-	    (nreverse optional)
-	    rest
-	    (nreverse key)
-	    allow-other-keys)))
-
diff --git a/pcl/notes.text b/pcl/notes.text
index 913ee4e97..99f527877 100644
--- a/pcl/notes.text
+++ b/pcl/notes.text
@@ -1,141 +1,85 @@
-These notes correspond to the "March 92 PCL (beta1)" version of PCL.
+
+These notes correspond to the "July 92 PCL" version of PCL.
 
   This version of PCL is much closer than previous versions of PCL
 to the metaobject protocol specified in "The Art of the Metaobject Protocol", 
 chapters 5 and 6, by Gregor Kiczales, Jim des Riveres, and Daniel G. Bobrow.
 
+[Please read the file march-92-notes.text and may-day-notes.text also.
+  Most of those files still apply.]
+
+Newly supported:
+
+accessor-method-slot-definition
+no-next-method
+generic-function-argument-precedence-order
+reader-method-class
+writer-method-class
+(setf class-name)
+
+defgeneric :method option
 
-[Please read the file may-day-notes.text also.  Most of that file still applies.]
-
-Support for structures
-  You can use structure-class as a metaclass to create new classes.
-  Classes created this way create and evaluate defstruct forms which
-  have generated symbols for the structure accessors and constructor.
-  The generated symbols are used by the primary slot-value-using-class
-  methods and by the primary allocate-instance method for structures.
-  Defmethod optimizes usages of slot-value (when no user-defined 
-  slot-value-using-class methods exist) into direct calls of the
-  generated symbol accessor, which the compiler can then optimize further.
-  Even when there are user-defined methods on slot-value-using-class,
-  PCL does a variety of optimizations.
-  
-  If your implementation's version of the *-low.lisp file
-  contains definitions of certain structure functions (see the end of
-  low.lisp, cmu-low.lisp, lucid-low.lisp, and kcl-low.lisp), then
-  structure classes are supported for all defstructs.  In this case,
-  structure classes are created automatically, when necessary.
-
-New Classes:
-structure-class
-structure-object
-slot-class
-slot-object
-structure-direct-slot-definition
-structure-effective-slot-definition
+class-default-initargs, class-precedence-list, class-prototype,
+   and class-slots now signal errors when class is not finalized
+   (as specified in AMOP ch 6).
 
 Improvements to slot-access
-  Optimization for slot-value outsize of defmethod
-  Optimization for slot-value inside of defmethod, but not of a specialized parameter.
-  Optimizations that work even when there are :around methods
-  on slot-value-using-class.
-
-New types: 
-   `(class ,class-object)
-   `(class-eq ,class-object)
-
-New specializer class: class-eq-specializer
-  Every class has a class-eq specializer which represents all
-  the direct instances of that class.
-  This is useful in *subtypep.  For example, here is the way 
-  generic-function initialization checks that the method-class is valid:
-   (and (classp method-class)
-	(*subtypep (class-eq-specializer method-class)
-		   (find-class 'standard-method)))
-  If you want to define methods having class-eq specializers,
-  see "Initialization of method metaobjects".  The default behavior of PCL
-  is to disallow this.
-
-compute-applicable-methods-using-types
-
-caching improvements
-
-no magic-generic-functions list
-  This simplifies some things, but complicates some other things.
-  I wanted to support user-defined classes which are their own metaclass.
-  You can now do:
-(defclass y (standard-class) ())
-(defmethod validate-superclass ((c y) (sc standard-class)) t)
-(defclass y (standard-class) () (:metaclass y))
-
-method-function changes (see the comments for make-method-lambda, below)
-
-final dfuns
+  Optimization for slot-value of specialized parameter inside of defmethod.
+  Optimization for standard cases of slot-value everywhere else.
+
+Additional support for structures
+  Redefines defstruct macro to give PCL access to all structure information
+  for structure classes in addition to calling the original lisp defstruct.
+
+All AMOP generic-functions now exported.
 
 -------------------------
+New gfs which obey AMOP ch 6, and some caveats:
 
-gfs which obey AMOP ch 6
-  add-dependent
-  add-direct-method
-  add-direct-subclass
-  add-method
-  allocate-instance
-  compute-class-precedence-list
-  compute-default-initargs
-  compute-effective-slot-definition
-[Note: compute-effective-slot-definition relys on 
- compute-effective-slot-definition-initargs and effective-slot-definition-class.
- compute-effective-slot-definition-initargs is quite useful, but is not in
- AMOP ch 6.]
-  compute-slots
-  direct-slot-definition-class
-  effective-slot-definition-class
-  ensure-class
-  ensure-class-using-class
-  ensure-generic-function
-  ensure-generic-function-using-class
-  eql-specializer-object
-  extract-lambda-list
-  extract-specializer-names
-  finalize-inheritance
-  find-method-combination
-  funcallable-standard-instance-access
-  {generic-function-method-class, generic-function-method-combination,
-   generic-function-lambda-list, generic-function-methods, generic-function-name}
-  intern-eql-specializer
-  make-instance
-  map-dependents
-  {method-function, method-generic-function, method-lambda-list,
-   method-specializers, method-qualifiers}
-  {class-default-initargs, class-direct-default-initargs, class-direct-slots,
-   class-direct-subclasses, class-direct-superclasses, class-finalized-p,
-   class-name, class-precedence-list, class-prototype, class-slots}
-  {slot-definition-allocation, slot-definition-initargs, slot-definition-initform,
-   slot-definition-initfunction, slot-definition-name, slot-definition-type}
-  {slot-definition-readers, slot-definition-writers}
-  {slot-definition-location}
-  remove-dependent
-  remove-direct-method
-  remove-direct-subclass
-  remove-method
-  set-funcallable-instance-function
-  (setf slot-value-using-class)
-  slot-boundp-using-class
-  slot-makunbound-using-class
-  specializer-direct-generic-functions
-  specializer-direct-methods
-  standard-instance-access
-  update-dependent
-
-gfs which DO NOT obey AMOP ch 6
+documentation
+  Stored in all classes, pcl::documentation works as defined.
 
-accessor-method-slot-definition
-  Not yet defined.  Use accessor-method-slot-name and method-specializers
-  to get the direct-slot-definition.
+generic-function-declarations
+  Stored, but ignored.
+
+make-method-lambda
+method-function
+  Compatible with AMOP, but will require additions to
+  compute-discriminating-function and compute-effective-method to
+  make fully useful.
+
+  In July 92 PCL, method-function returns the documented AMOP
+  method-function specified by the lambda returned by make-method-lambda.
+  However, that method-function is not actually used in method function
+  dispatch.  Instead, PCL's make-method-lambda and expand-defmethod also
+  create an optimized method function (method-optimized-function) or
+  closure generator (method-closure-generator) that it actually uses for
+  method function caching and dispatch.  This is the same optimized
+  function whose lambda-list is the lambda-list of the method used in
+  previous versions of PCL.  There are two cases to worry about with this:
+
+  1. The user specializes their own method on make-method-lambda without
+     redefining compute-discriminating-function or being careful to make
+     sure the method-optimized-function is set up properly (as done by the
+     standard make-method-lambda).  Expand-defmethod will detect this case
+     and create a method-optimized-function that calls the method-function
+     created by the new make-method-lambda with the parameters *of the
+     normal make-method-lambda*, i.e. (args methods).  This should work
+     for most cases, albeit slowly, but will fail if the user's modification
+     expects a different lambda list (as in the example of the AMOP, p. 209).
+
+  2. The user specializes their own method on make-method-lambda, but also
+     specializes compute-discriminating-function to call method-function
+     directly.  This should work.
+
+
+-------------------------
+Functions which DO NOT obey AMOP:
 
 compute-applicable-methods
 compute-applicable-methods-using-classes
   Handles class-eq specializers without signalling an error.  
-  But see "Initialization of method metaobjects", below.
+  See march-92-notes.text
 
 compute-discriminating-function
   [the resulting function works differently different because 
@@ -143,169 +87,145 @@ compute-discriminating-function
    does not exist.]
 
 compute-effective-method
-  Returns only one value.  The utility of bringing this into conformance with
-  AMOP ch 6 is limited by the lack of make-method-lambda.
+  Returns only one value.
 
-generic-function-argument-precedence-order
-  Not yet defined.  Can get this information from the arg-info structure.
+-------------------------
+Miscellaneous optimizations:
+
+Optimizations of slot-value of specialized parameter inside of
+  defmethod:
+
+  1. Closure variables are now used instead of lookup permutation
+     vectors to store slot indices when the effective methods are
+     cached each set of parameter classes they're called on (which
+     is now all the time, using March 92's optimizations), saving an
+     aref per slot access.
+  2. The cached effective methods optimize slot-access based on the type
+     of slot indices for the cached parameters.  There are three cases:
+       (a) The most common case -- all specialized parameter slot
+        accesses within the defmethod are on :instance allocated slots
+        on standard instances without user-defined slot-value-using-class
+        methods.  In this case, the cached closure for the method
+        directly accesses the slot through an aref on the standard
+        instance, without having to call (typep x 'fixnum) or figure out
+        what type of instance it is.
+       (b) If one of the slot accesses is on a non-:instance allocated slot,
+        on a non-standard instance, or has a user-defined slot-value-using-class
+        method, and store-optimized-method-lambda-p is true for the
+        generic-function and method (the default defined in low.lisp being
+        *compile-slot-access-method-functions-at-runtime-p* is T), then the
+        method to be cached is compiled at runtime to optimize the slot accesses
+        from a stored version of the method-lambda.  The compiled method to be
+        cached directly codes in each slot access for the particular index
+        and the type of the instance.
+       (c). If there are non-standard slot accesses, as in case (b), but
+        store-optimized-method-lambda-p for the generic-function and method
+        is NIL, then the cached methods are not compiled at runtime.  Instead,
+        the cached effective method is similar to previous PCL's, i.e.
+        having to check the index and instance type for each slot access,
+        though looking up the cached index in a closure variable rather than
+        a permutation vector to save an aref.
+
+Further optimizations of slot-value outside of defmethod or inside
+  of defmethod, but not of a specialized parameter:
+
+  1. If no non-standard specialized methods have been defined on
+     slot-value-using-class, then slot-value directly looks up the
+     value of the slot without calling any generic-functions or functions.
+
+  2. If non-standard specialized methods have been defined on
+     slot-value-using-class, then PCL arranges to call an automatically
+     created generic function that has one method: a reader method defined
+     on class slot-object (as in March 92 PCL).  This optimized generic-function
+     is now called whether or not the slot-name is constant.
+
+Make-instance, shared-initialize, and allocate-instance speeded up by:
+  1. Implementing suggested instance slot-vector allocation optimization
+     of the AMOP that copies a slot-vector whose side-effect-free slots
+     are already initialized.
+  2. Using internal copy of slot-definitions (as structures) to speed
+     up time-intensive internal slot accesses (also speeds up
+     slot-value-using-class).
+  3. Usually assuming and assuring that all slot init-functions are compiled.
+
+declarations of variable types throughout PCL where applicable.
+
+avoids unnecessary class updates by lazier class finalization, giving
+  faster compiling and loading.
 
-generic-function-declarations
-  Not yet defined.
 
-make-method-lambda
-  Does not exist.  This will be hard to add in a way that is compatible with
-  AMOP ch 6.
-  1. In March 92 PCL, there are two kinds of method-functions.  The first kind
-     is what method-function returns (which has no special restrinctions on its use).
-     The second kind is returned by method-function-for-caching, which is used
-     when the wrappers of the required arguments are known.  Each call to
-     method-function-for-caching might return a new function.  Both kinds of
-     method functions can be closures.  March 92 PCL currently uses this scheme
-     to do the pv-lookup ahead of time, thereby eliminating pv caching.
-     (pv-lookup means the lookup of the permutation vectors which are used for
-     fast instance varaible access.)   Method function closures can also be used
-     in the optimization of calls to generic-functions, but this has not yet been
-     implemented.
-  2. Since method-functions can be closures, we would need an extra step between
-     compiling (or coercing) the method-lambda into a function, before it can be 
-     applied to arguments with apply or funcall.     
+-------------------------
+Miscellaneous optional optimizations (see global variables at beginning
+of file low.lisp for full options):
+
+Variable *compile-all-method-functions-p* can be set to T, forcing all
+  method functions to be compiled and allowing method function dispatch
+  code to assume they are compiled.  Default is NIL.
+
+Generic function store-method-function-p (generic-function method initargs)
+  can be specialized to return NIL if the (normally unused) documented
+  method-functions are not needed.  Saves some space and compile time.
+  Default returns T.  Variable *standard-store-method-function-p*, which
+  is what the default store-method-function-p method looks up, can be
+  set to NIL if it is known that documented method functions will never
+  be needed.
+
+Generic function store-optimized-method-lambda-p (generic-function method initargs)
+  can be specialized to return NIL if it is not desireable to optimize
+  defmethod slot-accesses for non :instance allocated slots by compiling
+  the cached methods at runtime.  (This might be the case if your lisp's
+  compiler is slow, e.g. KCL, and each such method will only be called a
+  few times, so that the optimization isn't worth the added runtime compile
+  time.  Alternatively, *compile-slot-access-method-functions-at-runtime-p*
+  in low.lisp can be set to NIL to make this the default for all methods.
 
-reader-method-class
-  Not yet defined.  Some bootstrapping considerations are involved, 
-  but adding this will not be very hard.
+-------------------------
+Useful extensions to CLOS and AMOP:
 
-(setf class-name)
-  Currently just a writer method.  Does not call reinitialize-instance or
-  (setf find-class).
+boundp-method-class
+finalize-all-classes
 
-(setf generic-function-name)
-  Currently just a writer method.  Does not call reinitialize-instance.
+trace-methods
+  Traces all individual methods of a generic-function (as per trace-method).
+
+(setf standard-instance-access)
+(setf funcallable-standard-instance-access)
+  Functions to allow direct setting of instance slots
+  (as standard-instance-access and funcallable-standard-instance-access).
+
+standard-instance-slot-value
+(setf standard-instance-slot-value)
+standard-instance-slot-boundp
+funcallable-standard-instance-slot-value
+(setf funcallable-standard-instance-slot-value)
+funcallable-standard-instance-slot-boundp
+structure-instance-slot-value
+(setf structure-instance-slot-value)
+structure-instance-slot-boundp
+  Macros for highly optimized slot access given type of instance
+  (analogous to standard-instance-access):
+
+with-optimized-slots
+  Optimized version of with-slots with a couple of useful additions
+  to with-slots' functionality.
+
+with-standard-instance-slots
+  Slightly faster version of with-optimized-slots for use when instance
+  is guaranteed to be a standard-instance.
+
+this-method
+  Function locally defined within the body of methods to return the method
+  currently being executed.
+
+
+-------------------------
+Useful low-level extensions to PCL:
+
+Class wrappers now have one unreserved field available for programmer use
+  (accessed by wrapper-unreserved-field).
+
+Hooks built in to allow programmers to define their own USER-INSTANCE
+  low-level type of instances different from STD-INSTANCE, FSC-INSTANCE,
+  STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE (see file user-instances.lisp
+  as an example of their use to save space over standard instances).
 
-writer-method-class
-  Not yet defined.  Some bootstrapping considerations are involved, 
-  but adding this will not be very hard.
-
----------------------------
-
-Initialization of method metaobjects
-  The following methods are defined:
-    legal-qualifiers-p (method standard-method) qualifiers
-    legal-lambda-list-p (method standard-method) lambda-list
-    legal-specializers-p (method standard-method) specializers
-    legal-method-function-p (method standard-method) function
-    legal-documentation-p (method standard-method) documentation
-
-    legal-specializer-p (method standard-method) specializer
-
-  You can override them if you want.
-  The method for legal-specializers-p calls legal-specializer-p
-  on each specializer.
-  The method for legal-specializer-p allows any kind of specializer
-  when the variable *allow-experimental-specializers-p* is t
-  (this variable is initially nil).
-
----------------------------
-Optimizations on slot-value
-  Outside of a defmethod when define-compiler-macro is not implemented
-  or the slot-name is not constant, or
-  Inside a defmethod when the slot-name is not a constant:
-(1)   no optimization of slot-value, slot-value-using-class is called.
-      slot-value-using-class has a special dfun, though, which calls
-      the slot's slot-definition-reader-function.  This function is
-      a result of get-accessor-method-function.
-  Outside of a defmethod when define-compiler-macro is implemented and
-  the slot-name is a constant, or
-  Inside a defmethod when the slot-name is a constant but the object is 
-  not either (the value of a parameter specialized to a subclass of structure-object
-  for which no user-defined slot-value-using-class methods apply at defmethod time), 
-  or (the value of a parameter specialized to a subclass of standard-object).
-(2)   PCL arranges to call an automatically created generic function
-      which has one method: a reader method defined on class slot-object.
-  Inside a defmethod when the slot-name is a constant and the object 
-  is (the value of a parameter specialized to a subclass of structure-object
-  for which no user-defined slot-value-using-class methods apply).
-(3)   The slot-value form is converted to a call of the structure slot's 
-      accessor function, which the compiler can then optimize further.
-  Inside a defmethod when the slot-name is a constant and the object 
-  is (the value of a parameter specialized to a subclass of standard-object).
-(4)   The access requires two arefs, a call to (typep x 'fixnum), and a call to eq,
-      in the best case.  If user defined slot-value-using-class methods apply
-      at slot-value execution time, or the slot is unbound, the unoptimized 
-      slot-value function (1) is called.  This was in May Day PCL; what is new here
-      is that the PV (permutation vector) is looked up at defmethod load time
-      rather than at run time, if the effective method is cached.
-
-Generic functions containing only accessor methods for which no user-defined
-methods on slot-value-using-class apply and which involve only standard-classes:
-      A special dfun is called: one-class, two-class, one-index, or n-n.
-      These were all in May Day PCL.
-Generic functions excluded by the above, which contain accessor methods:
-      In place of each accessor method's method-function, a function returned by
-      get-accessor-method-function is used.
-
-get-accessor-method-function (gf type class slotd) ; type is reader, writer, or boundp.
-  If there is only one applicable method,
-      (This method will be the system supplied one)
-      the function that is returned is optimized for the current state of the
-      class.  When the class changes, it must be recomputed.
-  otherwise,
-      a secondary dispatch function for slot-value-using-class is computed
-      (using what is known about the types of the arguments) and converted 
-      into an accessor function.
-
-get-secondary-dispatch-function (gf methods types &optional method-alist wrappers)
-  The types argument describes what is known about the types of the arguments.
-  Method-alist is used (when supplied) to do things like replace the
-  standard slot-value-using-class method function with a function optimized
-  for what is known about the arguments.
-  Wrappers (when supplied) means that the resulting function is guaranteed to
-  be called only whith those wrappers.  Make-effective-method-function calls
-  the generic-function method-function-for-caching with method-alist and
-  wrappers to get a optimized method function.  (PV lookup is done at the time
-  method-function-for-caching is called).
-
-compute-applicable-methods:  Here I tried to stick with the MOP.
-  The function cache-miss-values looks at the second value of the result of 
-  compute-applicable-methods-using-classes.  If this value is null, we aren't 
-  supposed to cache the result of camuc.  So we don't.  Instead we cache a 
-  result of (default-secondary-dispatch-function gf), which in turn calls 
-  compute-applicable-methods each time it is called.
----------------------------
-
-To do:
-
-1.   Make the metaobject protocol function symbols be the external symbols
-  of a package, so they can be used easily.
-
-Problem: sometimes there is no need to call a gf's dfun: the emf that is invoked
-         can be cached in the caller's method closure.
-         make-instance is slow.
-2.  In expand-defmethod-internal, optimize calls to generic-functions.
-  Add the support for this optimization.
-
-3.   Make sure that use-dispatch-dfun-p is doing the right thing.
-
-4.   [When CMUCL improves its setf handling, remove the comment in
-   the file macros.lisp beginning the line ";#+cmu (pushnew :setf *features*)"]
-
-
-
---------------
-1) Generalize expand-defmethod-internal so that it can be used for non-defmethod
-code.  Maybe by (a) having a parameter that says whether it is being called by 
-defmethod, and (b) using the techniques used by the series package (shadowing 
-defun and some others, making the shadowed definitions call e-d-i, making it 
-easy for people to do the relevant package modifications)
-
-2) Extending generic-functions by allowing the user at defgeneric time to supply
-the name of a function which will be supplied (by the system) with a definition
-which will return equivalent results to those returned by the generic function,
-but which will (in some cases) have less checking than the generic function.
-One-class, two-class, and one-index gf dfuns will map to a result of 
-get-optimized-std-accessor-method-function, checking gf dfuns will map to their
-function, and any other dfun will remain the same.
-
-3) Extending expand-defmethod-internal to optimize calls to generic-functions.
-There are a variety of possibilities that need to be considered; one of them
-will be to arrange to call the optimized functions produced by (2) when it
-is known to be safe.  
diff --git a/pcl/pcl-env.lisp b/pcl/pcl-env.lisp
index 7bf4b476e..2ee226b4c 100644
--- a/pcl/pcl-env.lisp
+++ b/pcl/pcl-env.lisp
@@ -328,7 +328,9 @@ arg-types."
 (defun pcl-object-p (x)
   "Is the datum a PCL object?"
   (or (std-instance-p x)
-      (fsc-instance-p x)))
+      (fsc-instance-p x)
+      #+pcl-user-instances
+      (user-instance-p x)))
 
 (defun \\internal-inspect-object (x type where)
   (inspect-object x type where))
@@ -1330,8 +1332,8 @@ window"
 		  (found-method nil)
 		  ((eq (il:stkname current-pos) 'apply)
 		   (dolist (method methods)
-		     (when (eq (method-function method)
-			       (il:stkarg 1 current-pos))
+		     (when (memq (il:stkarg 1 current-pos)
+				 (method-cached-functions method))
 		       (setq method-pos current-pos)
 		       (setq found-method method)
 		       (return))))))))
@@ -1359,10 +1361,10 @@ window"
 	  (setq gf (generic-function-from-frame current-pos))
 	  (when gf
 	    (dolist (method (generic-function-methods gf))
-	      (when (function-matches-frame-p (method-function method)
-					      stack-pos)
-		(return-from interesting-frame-p
-		  (values t stack-pos stack-pos method))))
+	      (dolist (function (method-cached-functions method))
+	         (when (function-matches-frame-p function stack-pos)
+		   (return-from interesting-frame-p
+		                (values t stack-pos stack-pos method)))))
 	    (return))))
       ;; If we haven't already returned, use the default method.
       (xcl::interesting-frame-p stack-pos interp-flag))))
diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp
index 183aeeb97..9b5931e1c 100644
--- a/pcl/pkg.lisp
+++ b/pcl/pkg.lisp
@@ -29,6 +29,7 @@
 
 (export '(define-walker-template
 	  walk-form
+	  walk-form-expand-macros-p
 	  nested-walk-form
 	  variable-lexical-p
 	  variable-special-p
@@ -72,9 +73,12 @@
 
 #+Lucid 
 (import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist
-	  system:structurep system:structure-type system:structure-length)
+	  system:structurep system:structure-type system:structure-length
+          #-*lisp-hardware lucid::boolean
+          #+*lisp-hardware *lisp:boolean)
 	*the-pcl-package*)
-  
+
+
 #+lucid
 (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
     #+LCL3.0 ((lcl:warning #'(lambda (condition)
@@ -150,8 +154,16 @@
 #+cmu (shadow 'lisp:dotimes)
 
 #+cmu
-(import '(kernel:funcallable-instance-p ext:structurep)
+(import '(kernel:funcallable-instance-p ext:structurep c::boolean)
 	*the-pcl-package*)
+
+#+CMU
+(eval-when (compile)
+  (setq c:*suppress-values-declaration* T))
+
+#-(or cmu lucid)
+(deftype boolean () '(member t nil))
+
 
 
 (shadow 'documentation)
@@ -175,6 +187,7 @@
 		    defgeneric
 		    define-method-combination
 		    defmethod
+		    describe-object
 		    ensure-generic-function
 		    find-class
 		    find-method
@@ -226,62 +239,127 @@
 (mapc 'export (list *exports*) (list *the-pcl-package*))
 
 
+(eval-when (compile load eval)  
+  
+(defvar *class-exports*
+        '(standard-instance
+          funcallable-standard-instance
+          generic-function
+          standard-generic-function
+          method
+          standard-method
+          standard-accessor-method
+          standard-reader-method
+          standard-writer-method
+          method-combination
+          slot-definition
+          direct-slot-definition
+          effective-slot-definition
+          standard-slot-definition
+          standard-direct-slot-definition
+          standard-effective-slot-definition
+          specializer
+          eql-specializer
+          built-in-class
+          forward-referenced-class
+          standard-class
+          funcallable-standard-class))
 
-;(defvar *chapter-3-exports* '(
-;			  get-setf-function
-;			  get-setf-function-name
-;
-;			  class-prototype
-;			  class
-;			  object
-;
-;;			  essential-class
-;			   
-;			  class-name
-;			  class-precedence-list
-;			  class-local-supers
-;			  class-local-slots
-;			  class-direct-subclasses
-;			  class-direct-methods
-;			  class-slots
-;
-;			   
-;			  method-arglist
-;			  method-argument-specifiers			
-;			  method-function
-;			   
-;			  method-equal
-;			   
-;			  slotd-name
-;			  slot-missing
-;			   
-;;			  define-meta-class
-;;			  %allocate-instance
-;;			  %instance-ref
-;;			  %instancep
-;;			  %instance-meta-class
-;
-;			  allocate-instance
-;			  optimize-slot-value
-;			  optimize-setf-of-slot-value
-;			  add-named-class
-;			  class-for-redefinition
-;			  add-class
-;			  supers-changed
-;			  slots-changed
-;			  validate-superclass
-;			  make-slotd
-;			  compute-class-precedence-list
-;			  walk-method-body
-;			  walk-method-body-form
-;			  add-named-method
-;			  remove-named-method
-;
-;
-;			  ))
+(defvar *chapter-6-exports*
+        '(add-dependent
+          add-direct-method
+          add-direct-subclass
+          add-method
+          allocate-instance
+          class-default-initargs
+          class-direct-default-initargs
+          class-direct-slots
+          class-direct-subclasses
+          class-direct-superclasses
+          class-finalized-p
+          class-precedence-list
+          class-prototype
+          class-slots
+          compute-applicable-methods
+          compute-applicable-methods-using-classes
+          compute-class-precedence-list
+          compute-discriminating-function
+          compute-effective-method
+          compute-effective-slot-definition
+          compute-slots
+          direct-slot-definition-class
+          effective-slot-definition-class
+          ensure-class
+          ensure-class-using-class
+          ensure-generic-function
+          ensure-generic-function-using-class
+          eql-specializer-instance
+          extract-lambda-list
+          extract-specializer-names
+          finalize-inheritance
+          find-method-combination
+          funcallable-standard-instance-access
+          generic-function-argument-precedence-order
+          generic-function-declarations
+          generic-function-lambda-list
+          generic-function-method-class
+          generic-function-method-combination
+          generic-function-methods
+          generic-function-name
+          intern-eql-specializer
+          make-instance
+          make-method-lambda
+          map-dependents
+          method-function
+          method-generic-function
+          method-lambda-list
+          method-specializers
+          method-qualifiers
+          accessor-method-slot-definition
+          reader-method-class
+          remove-dependent
+          remove-direct-method
+          remove-direct-subclass
+          remove-method
+          set-funcallable-instance-function
+          slot-boundp-using-class
+          slot-definition-allocation
+          slot-definition-initargs
+          slot-definition-initform
+          slot-definition-initfunction
+          slot-definition-location
+          slot-definition-name
+          slot-definition-readers
+          slot-definition-writers
+          slot-definition-type
+          slot-exists-p-using-class
+          slot-makunbound-using-class
+          slot-value-using-class
+          specializer-direct-generic-function
+          specializer-direct-methods
+          standard-instance-access
+          update-dependent
+          validate-superclass
+          writer-method-class
+          ))
+
+);eval-when 
+
+#-(or KCL IBCL)
+(export *class-exports* *the-pcl-package*)
+
+#+(or KCL IBCL)
+(mapc 'export (list *class-exports*) (list *the-pcl-package*))
+
+#-(or KCL IBCL)
+(export *chapter-6-exports* *the-pcl-package*)
+
+#+(or KCL IBCL)
+(mapc 'export (list *chapter-6-exports*) (list *the-pcl-package*))
 
 (defvar *slot-accessor-name-package*
   (or (find-package :slot-accessor-name)
       (make-package :slot-accessor-name 
 		    :use '()
 		    :nicknames '(:s-a-n))))
+
diff --git a/pcl/plap.lisp b/pcl/plap.lisp
index c6170edbf..e491a5d1f 100644
--- a/pcl/plap.lisp
+++ b/pcl/plap.lisp
@@ -117,7 +117,7 @@
 			`(,(lap-reg reg)
 			  ,(lap-reg-initial-value-form reg)))
 		    (append i-regs v-regs fv-regs t-regs))
-	   (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
+	   (declare (type index ,@(mapcar #'lap-reg *lap-i-regs*))
 		    (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
 		    (type #+structure-wrapper cache-number-vector
 		          #-structure-wrapper (simple-array fixnum)
@@ -127,15 +127,13 @@
 
 (defvar *empty-vector* '#())
 (defvar *empty-fixnum-vector*
-  (make-array 8
-	      :element-type 'fixnum
-	      :initial-element 0))
+  (make-array 8 :initial-element 0))
  
 (defun lap-reg-initial-value-form (reg)
-  (cond ((member reg *lap-i-regs*) 0)
-        ((member reg *lap-v-regs*) '*empty-vector*)
-        ((member reg *lap-fv-regs*) '*empty-fixnum-vector*)
-        ((member reg *lap-t-regs*) nil)
+  (cond ((memq reg *lap-i-regs*) 0)
+        ((memq reg *lap-v-regs*) '*empty-vector*)
+        ((memq reg *lap-fv-regs*) '*empty-fixnum-vector*)
+        ((memq reg *lap-t-regs*) nil)
         (t
          (error "What kind of register is ~S?" reg))))
 
@@ -157,6 +155,9 @@
 
     (:std-instance-p (from label)
      `(when ,(lap-operands 'RUNTIME\ STD-INSTANCE-P from) (go ,label)))
+    #+pcl-user-instances
+    (:user-instance-p (from label)
+     `(when ,(lap-operands 'RUNTIME\ USER-INSTANCE-P from) (go ,label)))
     (:fsc-instance-p (from label)
      `(when ,(lap-operands 'RUNTIME\ FSC-INSTANCE-P from) (go ,label)))
     (:built-in-instance-p (from label)
@@ -194,17 +195,23 @@
     (:constant (c) `',c)
     ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper
       :built-in-or-structure-wrapper :std-slots :fsc-slots
-      :wrapper-cache-number-vector)
+      :wrapper-cache-number-vector
+      #+pcl-user-instances :user-wrapper
+      #+pcl-user-instances :user-slots)
      (x)
      (lap-operands (ecase (car operand)
 		     (:std-wrapper       'RUNTIME\ STD-WRAPPER)
 		     (:fsc-wrapper       'RUNTIME\ FSC-WRAPPER)
+                     #+pcl-user-instances
+		     (:user-wrapper      'RUNTIME\ USER-WRAPPER)
 		     (:built-in-wrapper  'RUNTIME\ BUILT-IN-WRAPPER)
 		     (:structure-wrapper 'RUNTIME\ STRUCTURE-WRAPPER)
 		     (:built-in-or-structure-wrapper
 		                         'RUNTIME\ BUILT-IN-OR-STRUCTURE-WRAPPER)
 		     (:std-slots         'RUNTIME\ STD-SLOTS)
 		     (:fsc-slots         'RUNTIME\ FSC-SLOTS)
+                     #+pcl-user-instances
+		     (:user-slots        'RUNTIME\ USER-SLOTS)
 		     (:wrapper-cache-number-vector 
 		      'RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR))
 		   x))
@@ -241,12 +248,10 @@
 (proclaim '(declaration pcl-fast-call))
 
 (defmacro RUNTIME\ FUNCALL (fn &rest args)
-  #+CMU `(funcall (the function ,fn) ,.args)
-  #-CMU `(funcall ,fn ,.args))
+  `(method-function-funcall ,fn ,.args))
 
 (defmacro RUNTIME\ APPLY (fn &rest args)
-  #+CMU `(apply (the function ,fn) ,.args)
-  #-CMU `(apply ,fn ,.args))
+  `(method-function-apply ,fn ,.args))
 
 (defmacro RUNTIME\ STD-WRAPPER (x)
   `(std-instance-wrapper ,x))
@@ -254,6 +259,10 @@
 (defmacro RUNTIME\ FSC-WRAPPER (x)
   `(fsc-instance-wrapper ,x))
 
+#+pcl-user-instances
+(defmacro RUNTIME\ USER-WRAPPER (x)
+  `(get-user-instance-wrapper ,x))
+
 (defmacro RUNTIME\ BUILT-IN-WRAPPER (x)
   `(built-in-wrapper-of ,x))
 
@@ -272,6 +281,10 @@
 (defmacro RUNTIME\ FSC-SLOTS (x)
   `(fsc-instance-slots ,x))
 
+#+pcl-user-instances
+(defmacro RUNTIME\ USER-SLOTS (x)
+  `(get-user-instance-slots ,x))
+
 (defmacro RUNTIME\ WRAPPER-CACHE-NUMBER-VECTOR (x)
   `(wrapper-cache-number-vector ,x))
 
@@ -281,11 +294,15 @@
 (defmacro RUNTIME\ FSC-INSTANCE-P (x)
   `(fsc-instance-p ,x))
 
+#+pcl-user-instances
+(defmacro RUNTIME\ USER-INSTANCE-P (x)
+  `(get-user-instance-p ,x))
+
 (defmacro RUNTIME\ IZEROP (x)
-  `(zerop (the fixnum ,x)))
+  `(zerop (the index ,x)))
 
 (defmacro RUNTIME\ FIX= (x y)
-  `(= (the fixnum ,x) (the fixnum ,y)))
+  `(= (the index ,x) (the index ,y)))
 
 ;;;
 ;;; These are the implementations of the index operands.  The portable
@@ -296,29 +313,29 @@
 ;;; Some compilers are so stupid...
 ;;;
 (defmacro RUNTIME\ IREF (vector index)
-  `(svref (the simple-vector ,vector) (the fixnum ,index)))
+  `(svref (the simple-vector ,vector) (the index ,index)))
 
 (defmacro RUNTIME\ ISET (vector index value)
-  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value))
+  `(setf (svref (the simple-vector ,vector) (the index ,index)) ,value))
 
-(defmacro RUNTIME\ SVREF (vector fixnum)
-  `(svref (the simple-vector ,vector) (the fixnum ,fixnum)))
+(defmacro RUNTIME\ SVREF (vector index)
+  `(svref (the simple-vector ,vector) (the index ,index)))
 
 (defmacro RUNTIME\ I+ (index1 index2)
-  `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2))))
+  `(the index (+ (the index ,index1) (the index ,index2))))
 
 (defmacro RUNTIME\ I- (index1 index2)  
-  `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2))))
+  `(the index (- (the index ,index1) (the index ,index2))))
 
 (defmacro RUNTIME\ I1+ (index)
-  `(the fixnum (1+ (the fixnum ,index))))
+  `(the index (1+ (the index ,index))))
 
 (defmacro RUNTIME\ ILOGAND (index1 index2)
-  #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))
+  #-Lucid `(the index (logand (the index ,index1) (the index ,index2)))
   #+Lucid `(%logand ,index1 ,index2))
 
 (defmacro RUNTIME\ ILOGXOR (index1 index2)
-  `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2))))
+  `(the index (logxor (the index ,index1) (the index ,index2))))
 
 ;;;
 ;;; In the portable implementation, indexes are just fixnums.
@@ -330,11 +347,15 @@
 (defun index->index-value (index) index)
 
 (defun make-index-mask (cache-size line-size)
+  (declare (type index cache-size line-size))
   (let ((cache-size-in-bits (floor (log cache-size 2)))
 	(line-size-in-bits (floor (log line-size 2)))
 	(mask 0))
-    (dotimes (i cache-size-in-bits) (setq mask (dpb 1 (byte 1 i) mask)))
-    (dotimes (i line-size-in-bits)  (setq mask (dpb 0 (byte 1 i) mask)))
+    (declare (type index cache-size-in-bits line-size-in-bits mask))
+    (dotimes (i cache-size-in-bits)
+      (setq mask (the index (dpb 1 (byte 1 i) mask))))
+    (dotimes (i line-size-in-bits)
+      (setq mask (the index (dpb 0 (byte 1 i) mask))))
     mask))
 
 
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
index e2e04a9e6..8c7f43153 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.3 1992/06/01 18:38:55 ram Exp $
+;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.4 1992/08/01 15:29:51 ram Exp $
 ;;
 ;; copyright (c) 1990 Franz Inc.
 ;;
@@ -30,7 +30,7 @@
   `(list nil ,constants ,lap nil nil ,cframe-size ,locals nil nil nil))
 
 
-(defstruct preg 
+(defstruct (preg)
   ;; pseudo reg descritpor
   treg		; associated treg
   index 	; :index if this is an index type reg
@@ -424,9 +424,12 @@
 				   (comp::mdparam 'md-function-const0-adj))
 				op2))
 	       ((:built-in-wrapper :structure-wrapper :built-in-or-structure-wrapper)
-		(qe call :arg 'pcl::built-in-or-structure-wrapper
+		(qe call :arg 'pcl::built-in-or-structure-wrapper-fun
 		    :u (list (get-treg-of (cadr op1)))
 		    :d (list (get-treg-of op2))))
+               #+pcl-user-instances
+               ((:user-wrapper :user-slots)
+                (warn "Trying to use pcl-user-instances in Sun4 Allegro."))
 	       (:other-wrapper
 		(warn "do other-wrapper"))
 	       ((:i+ :i- :ilogand :ilogxor)
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
index eece295c3..159da0af6 100644
--- a/pcl/slots.lisp
+++ b/pcl/slots.lisp
@@ -36,216 +36,832 @@
 ;;; std-class.  Many of these methods call these four functions.
 ;;;
 
-#||
-(proclaim '(inline get-wrapper get-slots))
-
-(defun get-wrapper (inst)
-  (cond ((std-instance-p inst) (std-instance-wrapper inst))
-	((fsc-instance-p inst) (fsc-instance-wrapper inst))
-	(t (error "What kind of instance is this?"))))
-
-(defun get-slots (inst)
-  (cond ((std-instance-p inst) (std-instance-slots inst))
-	((fsc-instance-p inst) (fsc-instance-slots inst))
-	(t (error "What kind of instance is this?"))))
-||#
-
-(defmacro get-wrapper (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst))
-	 (t (error "What kind of instance is this?"))))
-
-(defmacro get-slots (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))
-	 (t (error "What kind of instance is this?"))))
+(defun wrapper-error (&optional (object () object-p))
+  (if object-p
+      (error "What kind of instance is this: ~S" object)
+    (error "What kind of instance is this?")))
+
+
+(defmacro get-slots (inst &optional (else-clause '(wrapper-error)))
+  (once-only (inst)
+    `(cond ((std-instance-p ,inst)      (std-instance-slots ,inst))
+           ((fsc-instance-p ,inst)      (fsc-instance-slots ,inst))
+           #+pcl-user-instances
+           ((get-user-instance-p ,inst) (get-user-instance-slots ,inst))
+           (T ,else-clause))))
 
 (defmacro get-slots-or-nil (inst)
-  `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
-	 ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))
-	 (t nil)))
+  `(get-slots ,inst nil))
 
 (defun set-wrapper (inst new)
   (cond ((std-instance-p inst)
-	 (setf (std-instance-wrapper inst) new))
-	((fsc-instance-p inst)
-	 (setf (fsc-instance-wrapper inst) new))
-	(t
-	 (error "What kind of instance is this?"))))
+         (setf (std-instance-wrapper inst) new))
+        ((fsc-instance-p inst)
+         (setf (fsc-instance-wrapper inst) new))
+        #+pcl-user-instances
+        ((user-instance-p inst)
+         (setf (user-instance-wrapper inst) new))
+        (t
+         (wrapper-error inst))))
 
 (defun set-slots (inst new)
   (cond ((std-instance-p inst)
-	 (setf (std-instance-slots inst) new))
-	((fsc-instance-p inst)
-	 (setf (fsc-instance-slots inst) new))
-	(t
-	 (error "What kind of instance is this?"))))
-
-
-
-
-
-
-(defun get-class-slot-value-1 (object wrapper slot-name)
-  (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
-    (if (null entry)
-	(slot-missing (wrapper-class wrapper) object slot-name 'slot-value)
-	(if (eq (cdr entry) *slot-unbound*)
-	    (slot-unbound (wrapper-class wrapper) object slot-name)
-	    (cdr entry)))))
-
-(defun set-class-slot-value-1 (new-value object wrapper slot-name)
-  (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
-    (if (null entry)
-	(slot-missing (wrapper-class wrapper)
-		      object
-		      slot-name
-		      'setf
-		      new-value)
-	(setf (cdr entry) new-value))))
+         (setf (std-instance-slots inst) new))
+        ((fsc-instance-p inst)
+         (setf (fsc-instance-slots inst) new))
+        #+pcl-user-instances
+        ((user-instance-p inst)
+         (setf (user-instance-slots inst) new))
+        (t
+         (wrapper-error inst))))
+
+
+
+(defmacro get-class-slot-value-1 (object wrapper slot-name
+                                  &optional
+                                  (ignore-unbound-p NIL)
+                                  (ignore-missing-p NIL)
+                                  (return-cons-p    NIL)
+                                  (operation        ''slot-value))
+  ;; Search for slot-name in the class-slots of the object, returning
+  ;; its value if found and the slot is bound, calling slot-unbound if
+  ;; it was unbound (unless ignore-unbound is T), and calling slot-missing
+  ;; if it wasn't found in the class slots at all.
+  (once-only (object slot-name)
+    `(block nil
+       (locally (declare #.*optimize-speed*)
+         (let ((slots-left (wrapper-class-slots ,wrapper)))
+           (tagbody
+               (if (null slots-left)
+                   (go loop-slot-missing))
+             begin-class-loop
+               (if (eq (caar slots-left) ,slot-name)
+                   ,(cond
+                      (return-cons-p
+                        `(progn
+                           (setf slots-left (car slots-left))
+                           (go return-slot-value)))
+                      (ignore-unbound-p
+                        `(progn
+                           (setf slots-left (cdar slots-left))
+                           (go return-slot-value)))
+                      (T
+                       `(if (eq (setf slots-left (cdar slots-left))
+                                ',*slot-unbound*)
+                            (return
+                              (slot-unbound (wrapper-class ,wrapper)
+                                            ,object ,slot-name))
+                          (go return-slot-value)))))
+               (if (null (setf slots-left (cdr slots-left)))
+                   (go loop-slot-missing))
+               (go begin-class-loop)
+             loop-slot-missing
+               ,@(unless ignore-missing-p
+                  `((return (slot-missing (wrapper-class ,wrapper)
+                                          ,object
+                                          ,slot-name
+                                          ,operation))))
+             return-slot-value)
+           slots-left)))))
+
+(defmacro set-class-slot-value-1 (object wrapper slot-name new-value)
+  ;; Search for slot-name in the class-slots of the object, setting it
+  ;; to new-value if found, calling slot-missing otherwise.
+  (once-only (object slot-name new-value)
+    `(block nil
+       (locally (declare #.*optimize-speed*)
+         (let ((slots-left (wrapper-class-slots ,wrapper)))
+           (tagbody
+               (if (null slots-left)
+                   (go loop-slot-missing))
+             begin-class-loop
+               (if (eq (caar slots-left) ,slot-name)
+                   (return (setf (cdar slots-left) ,new-value)))
+               (if (null (setf slots-left (cdr slots-left)))
+                   (go loop-slot-missing))
+               (go begin-class-loop)
+             loop-slot-missing
+               (return (slot-missing (wrapper-class ,wrapper)
+                                     ,object
+                                     ,slot-name
+                                     'setf
+                                     ,new-value))))))))
+
+(defmacro slot-value-from-wrapper-and-slots
+          (object slot-name wrapper slots-layout slots get-slots-fn)
+  "Extra fast and ugly way to return the value of object's slot when given
+   its wrapper and possibly slots-layout and slots vector."
+  (once-only (wrapper)
+   `(block nil
+     (locally (declare #.*optimize-speed*)
+       (let ((slots-left ,(if slots-layout
+                              slots-layout
+                              `(wrapper-instance-slots-layout ,wrapper))))
+         (tagbody
+             (if slots-left
+                 (let ((index 0))
+                   (declare (type index index))
+                   (tagbody
+                     begin-local-loop
+                       (if (eq (car slots-left) ,slot-name)
+                           (if (eq (setf slots-left
+                                         (%svref
+                                           ,(if slots
+                                                slots
+                                              `(,(or get-slots-fn 'get-slots)
+                                                ,object))
+                                           index))
+                                   ',*slot-unbound*)
+                                 (go loop-slot-unbound)
+                             (go return-slot-value)))
+                       (setf index (the index (1+ index)))
+                       (if (null (setf slots-left (cdr slots-left)))
+                           (go check-class-loop))
+                       (go begin-local-loop))))
+           check-class-loop
+             (if (null (setf slots-left (wrapper-class-slots ,wrapper)))
+                 (go loop-slot-missing))
+           begin-class-loop
+             (if (eq (caar slots-left) ,slot-name)
+                 (if (eq (setf slots-left (cdar slots-left))
+                         ',*slot-unbound*)
+                     (go loop-slot-unbound)
+                     (go return-slot-value)))
+             (if (null (setf slots-left (cdr slots-left)))
+                 (go loop-slot-missing))
+             (go begin-class-loop)
+           loop-slot-missing
+             (return (slot-missing (wrapper-class ,wrapper)
+                                   ,object
+                                   ,slot-name
+                                   'slot-value))
+           loop-slot-unbound
+             (return (slot-unbound (wrapper-class ,wrapper) ,object ,slot-name))
+           return-slot-value)
+         slots-left)))))
+
+(defmacro set-slot-value-from-wrapper-and-slots
+  (object slot-name wrapper slots-layout slots get-slots-fn new-value)
+  "Extra fast and ugly way to set the value of object's slot when given its
+   wrapper and possibly slots-layout and slots vector."
+  (once-only (wrapper new-value)
+   `(block nil
+     (locally (declare #.*optimize-speed*)
+       (let ((slots-left ,(if slots-layout
+                              slots-layout
+                              `(wrapper-instance-slots-layout ,wrapper))))
+         (tagbody
+             (if slots-left
+                 (let ((index 0))
+                   (declare (type index index))
+                   (tagbody
+                     begin-local-loop
+                       (if (eq (car slots-left) ,slot-name)
+                           (progn
+                             (setf (%svref ,(if slots
+                                                slots
+                                              `(,(or get-slots-fn 'get-slots)
+                                                ,object))
+                                           index)
+                                   ,new-value)
+                             (go return-slot-value)))
+                       (setf index (the index (1+ index)))
+                       (if (null (setf slots-left (cdr slots-left)))
+                           (go check-class-loop))
+                       (go begin-local-loop))))
+           check-class-loop
+             (if (null (setf slots-left (wrapper-class-slots ,wrapper)))
+                 (go loop-slot-missing))
+           begin-class-loop
+             (if (eq (caar slots-left) ,slot-name)
+                 (progn
+                   (setf (cdar slots-left) ,new-value)
+                   (go return-slot-value)))
+             (if (null (setf slots-left (cdr slots-left)))
+                 (go loop-slot-missing))
+             (go begin-class-loop)
+           loop-slot-missing
+             (return (slot-missing (wrapper-class ,wrapper)
+                                   ,object
+                                   ,slot-name
+                                   'setf
+                                   ,new-value))
+           return-slot-value)
+         ,new-value)))))
+
+(defmacro slot-boundp-from-wrapper-and-slots
+          (object slot-name wrapper slots-layout slots get-slots-fn)
+  "Extra fast and ugly way to return whether object's slot is boundp when
+   given its wrapper and possibly slots-layout and slots vector."
+  (once-only (wrapper)
+   `(block nil
+     (locally (declare #.*optimize-speed*)
+       (let ((slots-left ,(if slots-layout
+                              slots-layout
+                              `(wrapper-instance-slots-layout ,wrapper))))
+         (tagbody
+             (if slots-left
+                 (let ((index 0))
+                   (declare (type index index))
+                   (tagbody
+                     begin-local-loop
+                       (when (eq (car slots-left) ,slot-name)
+                         (return
+                           (neq (%svref ,(if slots
+                                             slots
+                                           `(,(or get-slots-fn 'get-slots)
+                                             ,object))
+                                        index)
+                                ',*slot-unbound*)))
+                       (setf index (the index (1+ index)))
+                       (if (null (setf slots-left (cdr slots-left)))
+                           (go check-class-loop))
+                       (go begin-local-loop))))
+           check-class-loop
+             (if (null (setf slots-left (wrapper-class-slots ,wrapper)))
+                 (go loop-slot-missing))
+           begin-class-loop
+             (when (eq (caar slots-left) ,slot-name)
+               (return (neq (cdar slots-left) ',*slot-unbound*)))
+             (if (null (setf slots-left (cdr slots-left)))
+                 (go loop-slot-missing))
+             (go begin-class-loop)
+           loop-slot-missing
+             (return (slot-missing (wrapper-class ,wrapper)
+                                   ,object
+                                   ,slot-name
+                                   'slot-value))))))))
+
+
+(defsetf slot-value-from-wrapper-and-slots
+         set-slot-value-from-wrapper-and-slots)
 
 (defmethod class-slot-value ((class std-class) slot-name)
   (let ((wrapper (class-wrapper class))
-	(prototype (class-prototype class)))
+        (prototype (class-prototype class)))
     (get-class-slot-value-1 prototype wrapper slot-name)))
 
 (defmethod (setf class-slot-value) (nv (class std-class) slot-name)
   (let ((wrapper (class-wrapper class))
-	(prototype (class-prototype class)))
+        (prototype (class-prototype class)))
     (set-class-slot-value-1 nv prototype wrapper slot-name)))
 
-
-(defmacro slot-symbol (slot-name type)
-  `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
-       (intern (format nil "~A ~A slot ~a" 
-		       (package-name (symbol-package ,slot-name))
-		       (symbol-name ,slot-name)
-		       ,(symbol-name type))
-	        *slot-accessor-name-package*)
-       (progn 
-	 (error "non-symbol and non-interned symbol slot name accessors~
-                 are not yet implemented")
-	 ;;(make-symbol (format nil "~a ~a" ,slot-name ,type))
-	 )))
-
-(defun slot-reader-symbol (slot-name)
-  (slot-symbol slot-name reader))
-
-(defun slot-writer-symbol (slot-name)
-  (slot-symbol slot-name writer))
-
-(defun slot-boundp-symbol (slot-name)
-  (slot-symbol slot-name boundp))
 
-(defun find-slot-definition (class slot-name)
-  (dolist (slot (class-slots class) nil)
-    (when (eql slot-name (slot-definition-name slot))
-      (return slot))))
+;;;
+;;; The following highly optimized methods for accessing the slots
+;;;   of standard instances and funcallable standard instances aren't
+;;;   in the MOP, but it would be nice if they were...  - TL
+;;;
+
+(defmacro safe-funcallable-standard-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be funcallable-standard-instances with normal slots."
+  (once-only (instance)
+    `(locally (declare #.*optimize-speed*)
+       (slot-value-from-wrapper-and-slots
+          ,instance ,slot-name
+          (fast-check-wrapper-validity ,instance fsc-instance-wrapper)
+          NIL NIL fsc-instance-slots))))
+
+(defmacro set-safe-funcallable-standard-instance-slot-value
+          (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be funcallable-standard-instances with normal slots."
+  (once-only (instance)
+    `(locally (declare #.*optimize-speed*)
+       (setf (slot-value-from-wrapper-and-slots
+                ,instance ,slot-name
+                (fast-check-wrapper-validity ,instance fsc-instance-wrapper)
+                NIL NIL fsc-instance-slots)
+             ,new-value))))
+
+(defmacro safe-funcallable-standard-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be funcallable-standard-instances with normal slots."
+  (once-only (instance slot-name)
+    `(locally (declare #.*optimize-speed*)
+       (slot-boundp-from-wrapper-and-slots
+          ,instance ,slot-name
+          (fast-check-wrapper-validity ,instance fsc-instance-wrapper)
+          NIL NIL fsc-instance-slots))))
+
+(defsetf safe-funcallable-standard-instance-slot-value
+         set-safe-funcallable-standard-instance-slot-value)
+
+
+(defmacro funcallable-standard-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be funcallable-standard-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(safe-funcallable-standard-instance-slot-value ,instance ,slot-name))
+        (*safe-to-use-slot-value-wrapper-optimizations-p*
+         (once-only (instance slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-value-wrapper-optimizations-p*
+                 (safe-funcallable-standard-instance-slot-value ,instance ,slot-name)
+                 (accessor-slot-value ,instance ,slot-name)))))
+        (T `(accessor-slot-value ,instance ,slot-name))))
+
+(defmacro set-funcallable-standard-instance-slot-value
+          (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be funcallable-standard-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(setf (safe-funcallable-standard-instance-slot-value ,instance ,slot-name)
+                ,new-value))
+        (*safe-to-use-set-slot-value-wrapper-optimizations-p*
+         (once-only (instance slot-name new-value)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
+                 (setf (safe-funcallable-standard-instance-slot-value
+                           ,instance ,slot-name)
+                       ,new-value)
+                 (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
+        (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value))))
+
+(defmacro funcallable-standard-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be funcallable-standard-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(safe-funcallable-standard-instance-slot-boundp ,instance ,slot-name))
+        (*safe-to-use-slot-boundp-wrapper-optimizations-p*
+         (once-only (instance slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
+                 (safe-funcallable-standard-instance-slot-boundp ,instance ,slot-name)
+                 (accessor-slot-boundp ,instance ,slot-name)))))
+        (T `(accessor-slot-boundp ,instance ,slot-name))))
+
+(defsetf funcallable-standard-instance-slot-value
+         set-funcallable-standard-instance-slot-value)
+
+
+(defmacro safe-standard-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be standard instances with normal slots."
+  (once-only (instance)
+    `(locally (declare #.*optimize-speed*)
+       (slot-value-from-wrapper-and-slots
+          ,instance ,slot-name
+          (fast-check-wrapper-validity ,instance std-instance-wrapper)
+          NIL NIL std-instance-slots))))
+
+(defmacro set-safe-standard-instance-slot-value (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be standard instances with normal slots."
+  (once-only (instance)
+    `(locally (declare #.*optimize-speed*)
+       (setf (slot-value-from-wrapper-and-slots
+                ,instance ,slot-name
+                (fast-check-wrapper-validity ,instance std-instance-wrapper)
+                NIL NIL std-instance-slots)
+            ,new-value))))
+
+(defmacro safe-standard-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be standard-instances with normal slots."
+  (once-only (instance slot-name)
+    `(locally (declare #.*optimize-speed*)
+       (slot-boundp-from-wrapper-and-slots
+          ,instance ,slot-name
+          (fast-check-wrapper-validity ,instance std-instance-wrapper)
+          NIL NIL std-instance-slots))))
+
+(defsetf safe-standard-instance-slot-value set-safe-standard-instance-slot-value)
+
+(defmacro standard-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be standard-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(safe-standard-instance-slot-value ,instance ,slot-name))
+        (*safe-to-use-slot-value-wrapper-optimizations-p*
+         (once-only (instance slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-value-wrapper-optimizations-p*
+                 (safe-standard-instance-slot-value ,instance ,slot-name)
+                 (accessor-slot-value ,instance ,slot-name)))))
+        (T `(accessor-slot-value ,instance ,slot-name))))
+
+(defmacro set-standard-instance-slot-value
+          (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be standard-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(setf (safe-standard-instance-slot-value ,instance ,slot-name)
+                ,new-value))
+        (*safe-to-use-set-slot-value-wrapper-optimizations-p*
+         (once-only (instance slot-name new-value)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
+                 (setf (safe-standard-instance-slot-value
+                           ,instance ,slot-name)
+                       ,new-value)
+                 (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
+        (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value))))
+
+(defmacro standard-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be standard-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(safe-standard-instance-slot-boundp ,instance ,slot-name))
+        (*safe-to-use-slot-boundp-wrapper-optimizations-p*
+         (once-only (instance slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
+                 (safe-standard-instance-slot-boundp ,instance ,slot-name)
+                 (accessor-slot-boundp ,instance ,slot-name)))))
+        (T `(accessor-slot-boundp ,instance ,slot-name))))
+
+(defsetf standard-instance-slot-value set-standard-instance-slot-value)
+
+
+#+pcl-user-instances
+(progn
+(defmacro safe-user-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be user instances with normal slots."
+  (once-only (instance)
+    `(locally (declare #.*optimize-speed*)
+       (slot-value-from-wrapper-and-slots
+          ,instance ,slot-name
+          (fast-check-wrapper-validity ,instance get-user-instance-wrapper)
+          NIL NIL get-user-instance-slots))))
+
+(defmacro set-safe-user-instance-slot-value (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be user instances with normal slots."
+  (once-only (instance)
+    `(locally (declare #.*optimize-speed*)
+       (setf (slot-value-from-wrapper-and-slots
+                ,instance ,slot-name
+                (fast-check-wrapper-validity ,instance get-user-instance-wrapper)
+                NIL NIL get-user-instance-slots)
+            ,new-value))))
+
+(defmacro safe-user-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be user-instances with normal slots."
+  (once-only (instance slot-name)
+    `(locally (declare #.*optimize-speed*)
+       (slot-boundp-from-wrapper-and-slots
+          ,instance ,slot-name
+          (fast-check-wrapper-validity ,instance get-user-instance-wrapper)
+          NIL NIL get-user-instance-slots))))
+
+(defsetf safe-user-instance-slot-value set-safe-user-instance-slot-value)
+
+
+(defmacro user-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be user-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(safe-user-instance-slot-value ,instance ,slot-name))
+        (*safe-to-use-slot-value-wrapper-optimizations-p*
+         (once-only (instance slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-value-wrapper-optimizations-p*
+                 (safe-user-instance-slot-value ,instance ,slot-name)
+                 (accessor-slot-value ,instance ,slot-name)))))
+        (T `(accessor-slot-value ,instance ,slot-name))))
+
+(defmacro set-user-instance-slot-value
+          (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be user-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(setf (safe-user-instance-slot-value ,instance ,slot-name) ,new-value))
+        (*safe-to-use-set-slot-value-wrapper-optimizations-p*
+         (once-only (instance slot-name new-value)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
+                 (setf (safe-user-instance-slot-value ,instance ,slot-name)
+                       ,new-value)
+                 (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
+        (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value))))
+
+(defmacro user-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be user-instances."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(safe-user-instance-slot-boundp ,instance ,slot-name))
+        (*safe-to-use-slot-boundp-wrapper-optimizations-p*
+         (once-only (instance slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
+                 (safe-user-instance-slot-boundp ,instance ,slot-name)
+                 (accessor-slot-boundp ,instance ,slot-name)))))
+        (T `(accessor-slot-boundp ,instance ,slot-name))))
+
+(defsetf user-instance-slot-value set-user-instance-slot-value)
+) #+pcl-user-instances
+
+#+(and excl sun4) (values)  ;; Weird bug in Allegro CL 3.1.13.1 [Sun4] requires this.
+
+(defun make-slot-symbol (slot-name type pname)
+  (unless (symbol-package slot-name)
+    (slot-symbol-error slot-name))
+  (setf (get slot-name pname)
+        (intern (format nil "~A::~A slot ~a" 
+                        (package-name (symbol-package slot-name))
+                        (symbol-name slot-name)
+                        type)
+                *slot-accessor-name-package*)))
+
+(defmacro slot-symbol (slot-name type pname)
+  (once-only (slot-name)
+    `(if (symbolp ,slot-name)
+         (or (get ,slot-name ,pname)
+             (make-slot-symbol ,slot-name ,type ,pname))
+         (slot-symbol-error ,slot-name))))
+
+(defun slot-symbol-error (slot-name)
+  (error "non-symbol slot-names (~S) are not yet implemented" slot-name))
+
+(defmacro slot-reader-symbol (slot-name)
+  `(slot-symbol ,slot-name 'reader 'reader-slot-symbol))
+
+(defmacro slot-writer-symbol (slot-name)
+  `(slot-symbol ,slot-name 'writer 'writer-slot-symbol))
+
+(defmacro slot-boundp-symbol (slot-name)
+  `(slot-symbol ,slot-name 'boundp 'boundp-slot-symbol))
 
-(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.)"
-	 slot-name sym))
+(defun find-slot-definition (class slot-name)
+  (declare #.*optimize-speed*)
+  (macrolet ((find-def (class-internal-slotds slot-name)
+               `(let ((ptr ,class-internal-slotds))
+                  (loop (when (null ptr)
+                          (return NIL))
+                        (when (eq (internal-slotd-name (car ptr)) ,slot-name)
+                          (return (internal-slotd-slot-definition (car ptr))))
+                        (setf ptr (cdr ptr))))))
+    (if (or (eq class *the-class-standard-class*)
+            (eq class *the-class-funcallable-standard-class*)
+            (eq class *the-class-standard-effective-slot-definition*))
+        (find-def (safe-standard-instance-slot-value class 'internal-slotds)
+                  slot-name)
+        (find-def (class-internal-slotds class) slot-name))))
+
+(defun no-slot-accessor (object slot-name sym operation &optional new-value)
+  (if (and (not (or (std-instance-p  object)
+                    (fsc-instance-p  object)
+                    #+pcl-user-instances
+                    (user-instance-p object)))
+           (typep object 'structure))
+      (let ((structure-class (find-class (type-of object) nil)))
+        (if structure-class
+            (ecase operation
+              (slot-value  (slot-value object slot-name))
+              (setf        (setf (slot-value object slot-name) new-value))
+              (slot-boundp (slot-boundp object slot-name)))
+            (error
+              "Trying to do ~S for slot ~S on ~S, an instance of structure ~S
+               that was defined before PCL was loaded and that PCL can't make
+               a class for in this lisp."
+              (if (eq operation 'setf) '(setf slot-value) operation)
+              slot-name object (type-of object))))
+      (error "Trying to do ~S on ~S, but 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.)"
+              (if (eq operation 'setf) '(setf slot-value) operation)
+              object slot-name sym)))
+
+(defun no-slot-value-accessor (object slot-name sym)
+  (no-slot-accessor object slot-name sym 'slot-value))
+
+(defun no-set-slot-value-accessor (object slot-name sym new-value)
+  (no-slot-accessor object slot-name sym 'setf new-value))
+
+(defun no-slot-boundp-accessor (object slot-name sym)
+  (no-slot-accessor object slot-name sym 'slot-boundp))
+
+
+(defun slow-slot-value (object slot-name)
+  (let ((class (class-of object)))
+    (if (eq class *the-class-standard-effective-slot-definition*)
+        (safe-standard-instance-slot-value object slot-name)
+        (let ((slot-definition (find-slot-definition class slot-name)))
+          (if (null slot-definition)
+              (slot-missing class object slot-name 'slot-value)
+              (slot-value-using-class class object slot-definition))))))
+
+(defmacro accessor-slot-value (object slot-name-form)
+  (if (and (constantp slot-name-form)
+           (let ((slot-name (eval slot-name-form)))
+             (and (symbolp slot-name) (symbol-package slot-name))))
+      (let* ((slot-name (eval slot-name-form))
+             (sym (slot-reader-symbol slot-name)))
+        (once-only (object)
+          `(if (fboundp ',sym)
+               (funcall-compiled (symbol-function ',sym) ,object)
+               (no-slot-value-accessor ,object ',slot-name ',sym))))
+      (let ((sym (gensym "READER-SYMBOL")))
+        (once-only (object slot-name-form)
+          `(let ((,sym (slot-reader-symbol ,slot-name-form)))
+             (declare (type symbol ,sym))
+             (if (fboundp ,sym)
+                 (funcall-compiled (symbol-function ,sym) ,object)
+                 (no-slot-value-accessor ,object ,slot-name-form ',sym)))))))
+
+(defmacro wrapper-optimized-slot-value (object slot-name
+                                        &optional
+                                        (alternate-sv 'accessor-slot-value))
+  (once-only (object slot-name)
+    `(locally (declare #.*optimize-speed*)
+       (let ((wrapper NIL)
+             (slots   NIL))
+         (if (or (and (std-instance-p ,object)
+                      (setf wrapper (fast-check-wrapper-validity
+                                       ,object std-instance-wrapper))
+                      (setf slots (std-instance-slots ,object)))
+                 (and (fsc-instance-p ,object)
+                      (setf wrapper (fast-check-wrapper-validity
+                                      ,object fsc-instance-wrapper))
+                      (setf slots (fsc-instance-slots ,object)))
+                 #+pcl-user-instances
+                 (and (get-user-instance-p ,object)
+                      (setf wrapper (fast-check-user-wrapper-validity ,object))
+                      (setf slots (get-user-instance-slots ,object))))
+             (slot-value-from-wrapper-and-slots
+               ,object ,slot-name wrapper NIL slots NIL)
+             (,alternate-sv ,object ,slot-name))))))
+
+(defmacro fast-slot-value (object slot-name
+                           &optional (alternate-sv 'accessor-slot-value))
+  "Optimized macro version of slot-value."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(wrapper-optimized-slot-value ,object ,slot-name ,alternate-sv))
+        (*safe-to-use-slot-value-wrapper-optimizations-p*
+         (once-only (object slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-value-wrapper-optimizations-p*
+                 (wrapper-optimized-slot-value ,object ,slot-name ,alternate-sv)
+                 (,alternate-sv ,object ,slot-name)))))
+        (T `(,alternate-sv ,object ,slot-name))))
 
 (defun slot-value (object slot-name)
+  (fast-slot-value object slot-name))
+
+(define-compiler-macro slot-value (object-form slot-name-form)
+  `(fast-slot-value ,object-form ,slot-name-form))
+
+
+(defun slow-set-slot-value (object slot-name new-value)
   (let* ((class (class-of object))
-	 (slot-definition (find-slot-definition class slot-name)))
+         (slot-definition (find-slot-definition class slot-name)))
     (if (null slot-definition)
-	(slot-missing class object slot-name 'slot-value)
-	(slot-value-using-class class object slot-definition))))
-
-(setf (symbol-function 'slot-value-normal) #'slot-value)
-
-(defmacro accessor-slot-value (object slot-name)
-  (unless (constantp slot-name)
-    (error "~s requires its slot-name argument to be a constant" 
-	   'accessor-slot-value))
-  (let* ((slot-name (eval slot-name))
-	 (sym (slot-reader-symbol slot-name)))
-    `(function-funcall (if (fboundp ',sym)
-			   (symbol-function ',sym)
-			   (no-slot ',slot-name ',sym))
-                       ,object)))
+        (slot-missing class object slot-name 'setf)
+        (setf (slot-value-using-class class object slot-definition) new-value))))
 
-(define-compiler-macro slot-value (object-form slot-name-form)
+(defsetf slow-slot-value slow-set-slot-value)
+
+(defmacro accessor-set-slot-value (object slot-name-form new-value)
   (if (and (constantp slot-name-form)
-	   (let ((slot-name (eval slot-name-form)))
-	     (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-slot-value ,object-form ,slot-name-form)
-      `(slot-value-normal ,object-form ,slot-name-form)))
+           (let ((slot-name (eval slot-name-form)))
+             (and (symbolp slot-name) (symbol-package slot-name))))
+      (let* ((slot-name (eval slot-name-form))
+             (sym (slot-writer-symbol slot-name)))
+        (once-only (object new-value)
+          `(if (fboundp ',sym)
+               (funcall-compiled (symbol-function ',sym) ,new-value ,object)
+               (no-set-slot-value-accessor ,object ',slot-name ',sym ,new-value))))
+      (let ((sym (gensym "WRITER-SYM")))
+        (once-only (object new-value slot-name-form)
+          `(let ((,sym (slot-writer-symbol ,slot-name-form)))
+             (declare (type symbol ,sym))
+             (if (fboundp ,sym)
+                 (funcall-compiled (symbol-function ,sym) ,new-value ,object)
+                 (no-set-slot-value-accessor ,object ,slot-name-form ',sym
+                                             ,new-value)))))))
+
+(defmacro wrapper-optimized-set-slot-value (object slot-name new-value
+                                            &optional
+                                            (alternate-sv
+                                              'accessor-slot-value))
+  (once-only (object slot-name)
+    `(locally (declare #.*optimize-speed*)
+       (let ((wrapper NIL)
+             (slots   NIL))
+         (if (or (and (std-instance-p ,object)
+                      (setf wrapper (fast-check-wrapper-validity
+                                       ,object std-instance-wrapper))
+                      (setf slots (std-instance-slots ,object)))
+                 (and (fsc-instance-p ,object)
+                      (setf wrapper (fast-check-wrapper-validity
+                                      ,object fsc-instance-wrapper))
+                      (setf slots (fsc-instance-slots ,object)))
+                 #+pcl-user-instances
+                 (and (get-user-instance-p ,object)
+                      (setf wrapper (fast-check-user-wrapper-validity ,object))
+                      (setf slots (get-user-instance-slots ,object))))
+             (setf (slot-value-from-wrapper-and-slots
+                     ,object ,slot-name wrapper NIL slots NIL)
+                   ,new-value)
+             (setf (,alternate-sv ,object ,slot-name) ,new-value))))))
+
+(defmacro fast-set-slot-value (object slot-name new-value
+                               &optional
+                               (alternate-sv 'accessor-slot-value))
+  "Optimized macro version of set-slot-value."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(wrapper-optimized-set-slot-value ,object ,slot-name
+                                            ,new-value ,alternate-sv))
+        (*safe-to-use-slot-value-wrapper-optimizations-p*
+         (once-only (object slot-name new-value)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-value-wrapper-optimizations-p*
+                 (wrapper-optimized-set-slot-value ,object ,slot-name
+                                                   ,new-value ,alternate-sv)
+                 (setf (,alternate-sv ,object ,slot-name) ,new-value)))))
+        (T `(setf (,alternate-sv ,object ,slot-name) ,new-value))))
+
+(defmacro do-fast-set-slot-value (object slot-name new-value)
+  `(fast-set-slot-value ,object ,slot-name ,new-value))
+
+(defsetf accessor-slot-value accessor-set-slot-value)
+(defsetf fast-slot-value do-fast-set-slot-value)
+
+
 
 (defun set-slot-value (object slot-name new-value)
-  (let* ((class (class-of object))
-	 (slot-definition (find-slot-definition class slot-name)))
-    (if (null slot-definition)
-	(slot-missing class object slot-name 'setf)
-	(setf (slot-value-using-class class object slot-definition) 
-	      new-value))))
-
-(setf (symbol-function 'set-slot-value-normal) #'set-slot-value)
-
-(defmacro accessor-set-slot-value (object slot-name new-value &environment env)
-  (unless (constantp slot-name)
-    (error "~s requires its slot-name argument to be a constant" 
-	   'accessor-set-slot-value))
-  (setq object (macroexpand object env))
-  (setq slot-name (macroexpand slot-name env))
-  (let* ((slot-name (eval slot-name))
-	 (bindings (unless (or (constantp new-value) (atom new-value))
-		     (let ((object-var (gensym)))
-		       (prog1 `((,object-var ,object))
-			 (setq object object-var)))))
-	 (sym (slot-writer-symbol slot-name))
-	 (form `(function-funcall (if (fboundp ',sym)
-				      (symbol-function ',sym)
-				      (no-slot ',slot-name ',sym))
-		                  ,new-value
-		                  ,object)))
-    (if bindings
-	`(let ,bindings ,form)
-	form)))
+  (fast-set-slot-value object slot-name new-value))
 
 (define-compiler-macro set-slot-value (object-form slot-name-form new-value-form)
-  (if (and (constantp slot-name-form)
-	   (let ((slot-name (eval slot-name-form)))
-	     (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)
-      `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form)))
+  `(fast-set-slot-value ,object-form ,slot-name-form ,new-value-form))
 
-(defconstant *optimize-slot-boundp* nil)
+(eval-when (compile load eval)
+(defconstant *optimize-slot-boundp* nil))
 
-(defun slot-boundp (object slot-name)
+(defun slow-slot-boundp (object slot-name)
   (let* ((class (class-of object))
-	 (slot-definition (find-slot-definition class slot-name)))
+         (slot-definition (find-slot-definition class slot-name)))
     (if (null slot-definition)
-	(slot-missing class object slot-name 'slot-boundp)
-	(slot-boundp-using-class class object slot-definition))))
-
-(setf (symbol-function 'slot-boundp-normal) #'slot-boundp)
-
-(defun get-boundp-function1 (symbol slot-name)
-  (setf (symbol-function symbol) (get-boundp-function slot-name)))
-
-(defmacro accessor-slot-boundp (object slot-name)
-  (unless (constantp slot-name)
-    (error "~s requires its slot-name argument to be a constant" 
-	   'accessor-slot-boundp))
-  (let* ((slot-name (eval slot-name))
-	 (sym (slot-boundp-symbol slot-name)))
-    (if (not *optimize-slot-boundp*)
-	`(slot-boundp-normal ,object ',slot-name)
-	`(function-funcall (if (fboundp ',sym)
-			       (symbol-function ',sym)
-			       (no-slot ',slot-name ',sym))
-	                   ,object))))
+        (slot-missing class object slot-name 'slot-boundp)
+        (slot-boundp-using-class class object slot-definition))))
+
+(defmacro accessor-slot-boundp (object slot-name-form)
+  (cond ((not *optimize-slot-boundp*)
+         `(slow-slot-boundp ,object ,slot-name-form))
+        ((and (constantp slot-name-form)
+              (let ((slot-name (eval slot-name-form)))
+                (and (symbolp slot-name) (symbol-package slot-name))))
+         (let* ((slot-name (eval slot-name-form))
+                (sym (slot-boundp-symbol slot-name)))
+           (once-only (object)
+              `(if (fboundp ',sym)
+                   (funcall-compiled (symbol-function ',sym) ,object)
+                   (no-slot-boundp-accessor ,object ',slot-name ',sym)))))
+        (T
+         (let ((sym (gensym "BOUNDP-SYM")))
+           (once-only (object slot-name-form)
+             `(let ((,sym (slot-boundp-symbol ,slot-name-form)))
+                (declare (type symbol ,sym))
+                (if (fboundp ,sym)
+                    (funcall-compiled (symbol-function ,sym) ,object)
+                    (no-slot-boundp-accessor ,object ,slot-name-form ',sym))))))))
+
+(defmacro wrapper-optimized-slot-boundp (object slot-name
+                                        &optional
+                                        (alternate-sv 'accessor-slot-boundp))
+  (once-only (object slot-name)
+    `(locally (declare #.*optimize-speed*)
+       (let ((wrapper NIL)
+             (slots   NIL))
+         (if (or (and (std-instance-p ,object)
+                      (setf wrapper (fast-check-wrapper-validity
+                                       ,object std-instance-wrapper))
+                      (setf slots (std-instance-slots ,object)))
+                 (and (fsc-instance-p ,object)
+                      (setf wrapper (fast-check-wrapper-validity
+                                      ,object fsc-instance-wrapper))
+                      (setf slots (fsc-instance-slots ,object)))
+                 #+pcl-user-instances
+                 (and (get-user-instance-p ,object)
+                      (setf wrapper (fast-check-user-wrapper-validity ,object))
+                      (setf slots (get-user-instance-slots ,object))))
+             (slot-boundp-from-wrapper-and-slots
+               ,object ,slot-name wrapper NIL slots NIL)
+             (,alternate-sv ,object ,slot-name))))))
+
+(defmacro fast-slot-boundp (object slot-name
+                           &optional (alternate-sv 'accessor-slot-boundp))
+  "Optimized macro version of slot-boundp."
+  (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
+         `(wrapper-optimized-slot-boundp ,object ,slot-name ,alternate-sv))
+        (*safe-to-use-slot-boundp-wrapper-optimizations-p*
+         (once-only (object slot-name)
+          `(locally (declare #.*optimize-speed*)
+             (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
+                 (wrapper-optimized-slot-boundp ,object ,slot-name ,alternate-sv)
+                 (,alternate-sv ,object ,slot-name)))))
+        (T `(,alternate-sv ,object ,slot-name))))
+
+(defun slot-boundp (object slot-name)
+  (fast-slot-boundp object slot-name))
 
 (define-compiler-macro slot-boundp (object-form slot-name-form)
-  (if (and (constantp slot-name-form)
-	   (let ((slot-name (eval slot-name-form)))
-	     (and (symbolp slot-name) (symbol-package slot-name))))
-      `(accessor-slot-boundp ,object-form ,slot-name-form)
-      `(slot-boundp-normal ,object-form ,slot-name-form)))
+  `(fast-slot-boundp ,object-form ,slot-name-form))
+
 
 (defun slot-makunbound (object slot-name)
   (let* ((class (class-of object))
@@ -258,7 +874,7 @@
   (let* ((class (class-of object))
          (slot-definition (find-slot-definition class slot-name)))
     (and slot-definition
-	 (slot-exists-p-using-class class object slot-definition))))
+         (slot-exists-p-using-class class object slot-definition))))
 
 ;;;
 ;;; This isn't documented, but is used within PCL in a number of print
@@ -269,7 +885,7 @@
       (slot-value object slot-name)
       default))
 
-
+
 ;;;
 ;;; 
 ;;; 
@@ -279,149 +895,206 @@
 (defun funcallable-standard-instance-access (instance location)
   (%svref (fsc-instance-slots instance) location))
 
+(defun set-standard-instance-access (instance location new-value)
+  (setf (%svref (std-instance-slots instance) location) new-value))
+
+(defun set-funcallable-standard-instance-access (instance location new-value)
+  (setf (%svref (fsc-instance-slots instance) location) new-value))
+
+(defsetf standard-instance-access set-standard-instance-access)
+(defsetf funcallable-standard-instance-access set-funcallable-standard-instance-access)
+
+#+pcl-user-instances
+(defun user-instance-access (instance location)
+  (%svref (user-instance-slots instance) location))
+
+#+pcl-user-instances
+(defun set-user-instance-access (instance location new-value)
+  (setf (%svref (user-instance-slots instance) location) new-value))
+
+#+pcl-user-instances
+(defsetf user-instance-access set-user-instance-access)
+
 (defmethod slot-value-using-class ((class std-class)
                                    (object standard-object)
                                    (slotd standard-effective-slot-definition))
   (let* ((location (slot-definition-location slotd))
-	 (value (typecase location
-		  (fixnum 
-		   (cond ((std-instance-p object)
-			  (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%svref (std-instance-slots object) location))
-			 ((fsc-instance-p object)
-			  (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%svref (fsc-instance-slots object) location))
-			 (t (error "What kind of instance is this?"))))
-		  (cons
-		   (cdr location))
-		  (t
-		   (error "The slot ~s has neither :instance nor :class allocation, ~@
+         (value (typecase location
+                  (fixnum 
+                   (cond ((std-instance-p object)
+                          (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+                            (check-wrapper-validity object))
+                          (%svref (std-instance-slots object) location))
+                         ((fsc-instance-p object)
+                          (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+                            (check-wrapper-validity object))
+                          (%svref (fsc-instance-slots object) location))
+                         #+pcl-user-instances
+                         ((user-instance-p object)
+                          (unless (eq 't (wrapper-state (user-instance-wrapper object)))
+                            (check-wrapper-validity object))
+                          (%svref (user-instance-slots object) location))
+                         (t (wrapper-error object))))
+                  (cons
+                   (cdr location))
+                  (t
+                   (error "The slot ~s has neither :instance nor :class allocation, ~@
                            so it can't be read by the default ~s method."
-			  slotd 'slot-value-using-class)))))
+                          slotd 'slot-value-using-class)))))
     (if (eq value *slot-unbound*)
-	(slot-unbound class object (slot-definition-name slotd))
-	value)))
+        (slot-unbound class object (slot-definition-name slotd))
+        value)))
 
 (defmethod (setf slot-value-using-class)
-	   (new-value (class std-class)
-		      (object standard-object)
-		      (slotd standard-effective-slot-definition))
+           (new-value (class std-class)
+                      (object standard-object)
+                      (slotd standard-effective-slot-definition))
   (let ((location (slot-definition-location slotd)))
     (typecase location
       (fixnum 
        (cond ((std-instance-p object)
-	      (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%svref (std-instance-slots object) location) new-value))
-	     ((fsc-instance-p object)
-	      (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%svref (fsc-instance-slots object) location) new-value))
-	     (t (error "What kind of instance is this?"))))
+              (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+                (check-wrapper-validity object))
+              (setf (%svref (std-instance-slots object) location) new-value))
+             ((fsc-instance-p object)
+              (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+                (check-wrapper-validity object))
+              (setf (%svref (fsc-instance-slots object) location) new-value))
+             #+pcl-user-instances
+             ((user-instance-p object)
+              (unless (eq 't (wrapper-state (user-instance-wrapper object)))
+                (check-wrapper-validity object))
+              (setf (%svref (user-instance-slots object) location) new-value))
+             (t (wrapper-error object))))
       (cons
        (setf (cdr location) new-value))
       (t
        (error "The slot ~s has neither :instance nor :class allocation, ~@
                            so it can't be written by the default ~s method."
-	      slotd '(setf slot-value-using-class))))))
+              slotd '(setf slot-value-using-class))))))
 
 (defmethod slot-boundp-using-class
-	   ((class std-class) 
-	    (object standard-object) 
-	    (slotd standard-effective-slot-definition))
+           ((class std-class) 
+            (object standard-object) 
+            (slotd standard-effective-slot-definition))
   (let* ((location (slot-definition-location slotd))
-	 (value (typecase location
-		  (fixnum 
-		   (cond ((std-instance-p object)
-			  (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%svref (std-instance-slots object) location))
-			 ((fsc-instance-p object)
-			  (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-			    (check-wrapper-validity object))
-			  (%svref (fsc-instance-slots object) location))
-			 (t (error "What kind of instance is this?"))))
-		  (cons
-		   (cdr location))
-		  (t
-		   (error "The slot ~s has neither :instance nor :class allocation, ~@
+         (value (typecase location
+                  (fixnum 
+                   (cond ((std-instance-p object)
+                          (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+                            (check-wrapper-validity object))
+                          (%svref (std-instance-slots object) location))
+                         ((fsc-instance-p object)
+                          (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+                            (check-wrapper-validity object))
+                          (%svref (fsc-instance-slots object) location))
+                         #+pcl-user-instances
+                         ((user-instance-p object)
+                          (unless (eq 't (wrapper-state (user-instance-wrapper object)))
+                            (check-wrapper-validity object))
+                          (%svref (user-instance-slots object) location))
+                         (t (wrapper-error object))))
+                  (cons
+                   (cdr location))
+                  (t
+                   (error "The slot ~s has neither :instance nor :class allocation, ~@
                            so it can't be read by the default ~s method."
-			  slotd 'slot-boundp-using-class)))))
+                          slotd 'slot-boundp-using-class)))))
     (not (eq value *slot-unbound*))))
 
 (defmethod slot-makunbound-using-class
-	   ((class std-class)
-	    (object standard-object) 
-	    (slotd standard-effective-slot-definition))
+           ((class std-class)
+            (object standard-object) 
+            (slotd standard-effective-slot-definition))
   (let ((location (slot-definition-location slotd)))
     (typecase location
       (fixnum 
        (cond ((std-instance-p object)
-	      (unless (eq 't (wrapper-state (std-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%svref (std-instance-slots object) location) *slot-unbound*))
-	     ((fsc-instance-p object)
-	      (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
-		(check-wrapper-validity object))
-	      (setf (%svref (fsc-instance-slots object) location) *slot-unbound*))
-	     (t (error "What kind of instance is this?"))))
+              (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+                (check-wrapper-validity object))
+              (setf (%svref (std-instance-slots object) location) *slot-unbound*))
+             ((fsc-instance-p object)
+              (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+                (check-wrapper-validity object))
+              (setf (%svref (fsc-instance-slots object) location) *slot-unbound*))
+             #+pcl-user-instances
+             ((user-instance-p object)
+              (unless (eq 't (wrapper-state (user-instance-wrapper object)))
+                (check-wrapper-validity object))
+              (setf (%svref (user-instance-slots object) location) *slot-unbound*))
+             (t (wrapper-error object))))
       (cons
        (setf (cdr location) *slot-unbound*))
       (t
        (error "The slot ~s has neither :instance nor :class allocation, ~@
                            so it can't be written by the default ~s method."
-	      slotd 'slot-makunbound-using-class))))
+              slotd 'slot-makunbound-using-class))))
   nil)
 
 (defmethod slot-exists-p-using-class
-	   ((class std-class)
-	    (object standard-object)
-	    (slotd standard-effective-slot-definition))
+           ((class std-class)
+            (object standard-object)
+            (slotd standard-effective-slot-definition))
   t)
 
+
+(defmacro structure-instance-slot-value (instance slot-name)
+  "Highly-optimized macro for returning the slot-value of instances that
+   are guaranteed to be structure instances with normal slots."
+  `(accessor-slot-value ,instance ,slot-name))
+
+(defmacro set-structure-instance-slot-value (instance slot-name new-value)
+  "Highly-optimized macro for setting the slot-value of instances that
+   are guaranteed to be structure instances with normal slots."
+  `(accessor-set-slot-value ,instance ,slot-name ,new-value))
+
+(defmacro structure-instance-slot-boundp (instance slot-name)
+  "Highly-optimized macro for checking whether a slot is bound for instances
+   that are guaranteed to be structure-instances with normal slots."
+  `(accessor-slot-boundp ,instance ,slot-name))
+
+(defsetf structure-instance-slot-value set-structure-instance-slot-value)
+
+
 (defmethod slot-value-using-class
     ((class structure-class)
      (object structure-object)
      (slotd structure-effective-slot-definition))
   (let ((function (slot-definition-internal-reader-function slotd)))
-    #+cmu (declare (type function function))
-    (funcall function object)))
+    (method-function-funcall function object)))
 
 (defmethod (setf slot-value-using-class)
     (new-value (class structure-class)
-	       (object structure-object)
-	       (slotd structure-effective-slot-definition))
+               (object structure-object)
+               (slotd structure-effective-slot-definition))
   (let ((function (slot-definition-internal-writer-function slotd)))
-    #+cmu (declare (type function function))
-    (funcall function new-value object)))
+    (method-function-funcall function new-value object)))
 
 (defmethod slot-boundp-using-class
-	   ((class structure-class) 
-	    (object structure-object)
-	    (slotd structure-effective-slot-definition))
+           ((class structure-class) 
+            (object structure-object)
+            (slotd structure-effective-slot-definition))
   t)
 
 (defmethod slot-makunbound-using-class
-	   ((class structure-class)
-	    (object structure-object)
-	    (slotd structure-effective-slot-definition))
+           ((class structure-class)
+            (object structure-object)
+            (slotd structure-effective-slot-definition))
   (error "Structure slots can't be unbound"))
-
+
 
 (defmethod slot-missing
-	   ((class t) instance slot-name operation &optional new-value)
+           ((class t) instance slot-name operation &optional new-value)
   (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
-	 (ecase operation
-	   (slot-value "read the slot's value (slot-value)")
-	   (setf (format nil
-			 "set the slot's value to ~S (setf of slot-value)"
-			 new-value))
-	   (slot-boundp "test to see if slot is bound (slot-boundp)")
-	   (slot-makunbound "make the slot unbound (slot-makunbound)"))
-	 slot-name
-	 instance))
+         (ecase operation
+           (slot-value "read the slot's value (slot-value)")
+           (setf (format nil
+                         "set the slot's value to ~S (setf of slot-value)"
+                         new-value))
+           (slot-boundp "test to see if slot is bound (slot-boundp)")
+           (slot-makunbound "make the slot unbound (slot-makunbound)"))
+         slot-name
+         instance))
 
 (defmethod slot-unbound ((class t) instance slot-name)
   (error "The slot ~S is unbound in the object ~S." slot-name instance))
@@ -431,227 +1104,216 @@
   (declare (ignore object))
   t)
 
+(declaim (ftype (function (T T T) (values function boolean))
+		get-optimized-std-accessor-method-function))
 (defun get-optimized-std-accessor-method-function (class slotd name)
   (if (structure-class-p class)
-      (ecase name
-	(reader (slot-definition-internal-reader-function slotd))
-	(writer (slot-definition-internal-writer-function slotd))
-	(boundp #'structure-slot-boundp))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  (t (error "~S is not a standard-class" class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function (ecase name
-			 (reader 'make-optimized-std-reader-method-function)
-			 (writer 'make-optimized-std-writer-method-function)
-			 (boundp 'make-optimized-std-boundp-method-function)))
-	     (value (funcall function fsc-p slot-name index)))
-	(values value index))))
-
-(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
+      (values
+        (ecase name
+          (reader (slot-definition-internal-reader-function slotd))
+          (writer (slot-definition-internal-writer-function slotd))
+          (boundp #'structure-slot-boundp))
+        nil)
+      (let* ((instance-type (class-instance-type class))
+             (slot-name (slot-definition-name slotd))
+             (index (slot-definition-location slotd))
+             (function (ecase name
+                         (reader #'get-optimized-std-reader-method-function)
+                         (writer #'get-optimized-std-writer-method-function)
+                         (boundp #'get-optimized-std-boundp-method-function)))
+             (value (funcall-function function instance-type slot-name index)))
+        (values value (not (null index))))))
+
+(defvar *optimized-std-reader-table* (make-hash-table :test 'equal))
+(defvar *optimized-std-writer-table* (make-hash-table :test 'equal))
+(defvar *optimized-std-boundp-table* (make-hash-table :test 'equal))
+
+(defun get-optimized-std-reader-method-function (instance-type slot-name index)
+  (etypecase index
+    (fixnum
+      (let ((table-index (list instance-type slot-name index)))
+        (or (gethash table-index *optimized-std-reader-table*)
+            (setf (gethash table-index *optimized-std-reader-table*)
+                  (make-optimized-std-reader-method-function
+                     instance-type slot-name index)))))
+    (cons
+      (make-optimized-std-reader-method-function
+         instance-type slot-name index))))
+
+(defun get-optimized-std-writer-method-function (instance-type slot-name index)
+  (etypecase index
+    (fixnum
+      (let ((table-index (list instance-type slot-name index)))
+        (or (gethash table-index *optimized-std-writer-table*)
+            (setf (gethash table-index *optimized-std-writer-table*)
+                  (make-optimized-std-writer-method-function
+                     instance-type slot-name index)))))
+    (cons
+      (make-optimized-std-writer-method-function
+         instance-type slot-name index))))
+
+(defun get-optimized-std-boundp-method-function (instance-type slot-name index)
+  (etypecase index
+    (fixnum
+      (let ((table-index (list instance-type slot-name index)))
+        (or (gethash table-index *optimized-std-boundp-table*)
+            (setf (gethash table-index *optimized-std-boundp-table*)
+                  (make-optimized-std-boundp-method-function
+                     instance-type slot-name index)))))
+    (cons
+      (make-optimized-std-boundp-method-function
+         instance-type slot-name index))))
+
+(defun make-optimized-std-reader-method-function (instance-type slot-name index)
   (declare #.*optimize-speed*)
   (set-function-name
    (etypecase index
-     (fixnum (if fsc-p
-		 #'(lambda (instance)
-		     (let ((value (%svref (fsc-instance-slots instance) index)))
-		       (if (eq value *slot-unbound*)
-			   (slot-unbound (class-of instance) instance slot-name)
-			   value)))
-		 #'(lambda (instance)
-		     (let ((value (%svref (std-instance-slots instance) index)))
-		       (if (eq value *slot-unbound*)
-			   (slot-unbound (class-of instance) instance slot-name)
-			   value)))))
+     (fixnum (ecase instance-type
+               (std-instance
+                 #'(lambda (instance)
+                     (let ((value (%svref (std-instance-slots instance) index)))
+                       (if (eq value *slot-unbound*)
+                           (slot-unbound (class-of instance) instance slot-name)
+                           value))))
+               (fsc-instance
+                 #'(lambda (instance)
+                     (let ((value (%svref (fsc-instance-slots instance) index)))
+                       (if (eq value *slot-unbound*)
+                           (slot-unbound (class-of instance) instance slot-name)
+                           value))))
+               #+pcl-user-instances
+               (user-instance
+                 (make-optimized-user-reader-method-function slot-name index))))
      (cons   #'(lambda (instance)
-		 (let ((value (cdr index)))
-		   (if (eq value *slot-unbound*)
-		       (slot-unbound (class-of instance) instance slot-name)
-		       value)))))
+                 (let ((value (cdr index)))
+                   (if (eq value *slot-unbound*)
+                       (slot-unbound (class-of instance) instance slot-name)
+                       value)))))
    `(reader ,slot-name)))
 
-(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
+(defun make-optimized-std-writer-method-function (instance-type slot-name index)
   (declare #.*optimize-speed*)
   (set-function-name
    (etypecase index
-     (fixnum (if fsc-p
-		 #'(lambda (nv instance)
-		     (setf (%svref (fsc-instance-slots instance) index) nv))
-		 #'(lambda (nv instance)
-		     (setf (%svref (std-instance-slots instance) index) nv))))
+     (fixnum (ecase instance-type
+               (std-instance
+                 #'(lambda (nv instance)
+                     (setf (%svref (std-instance-slots instance) index) nv)))
+               (fsc-instance
+                 #'(lambda (nv instance)
+                     (setf (%svref (fsc-instance-slots instance) index) nv)))
+               #+pcl-user-instances
+               (user-instance
+                 (make-optimized-user-writer-method-function index))))
      (cons   #'(lambda (nv instance)
-		 (declare (ignore instance))
-		 (setf (cdr index) nv))))
+                 (declare (ignore instance))
+                 (setf (cdr index) nv))))
    `(writer ,slot-name)))
 
-(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
+(defun make-optimized-std-boundp-method-function (instance-type slot-name index)
   (declare #.*optimize-speed*)
   (set-function-name
    (etypecase index
-     (fixnum (if fsc-p
-		 #'(lambda (instance)
-		     (not (eq *slot-unbound*
-			      (%svref (fsc-instance-slots instance) index))))
-		 #'(lambda (instance)
-		     (not (eq *slot-unbound* 
-			      (%svref (std-instance-slots instance) index))))))
+     (fixnum (ecase instance-type
+               (std-instance
+                 #'(lambda (instance)
+                     (not (eq *slot-unbound* 
+                              (%svref (std-instance-slots instance) index)))))
+               (fsc-instance
+                 #'(lambda (instance)
+                     (not (eq *slot-unbound*
+                              (%svref (fsc-instance-slots instance) index)))))
+               #+pcl-user-instances
+               (user-instance
+                 (make-optimized-user-boundp-method-function index))))
      (cons   #'(lambda (instance)
-		 (declare (ignore instance))
-		 (not (eq *slot-unbound* (cdr index))))))
+                 (declare (ignore instance))
+                 (not (eq *slot-unbound* (cdr index))))))
    `(boundp ,slot-name)))
 
-(defun make-optimized-structure-slot-value-using-class-method-function (function)
-  #+cmu (declare (type function function))
-  #'(lambda (class object slotd)
-      (declare (ignore class slotd))
-      (funcall function object)))
-
-(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
-  #+cmu (declare (type function function))
-  #'(lambda (nv class object slotd)
-      (declare (ignore class slotd))
-      (funcall function nv object)))
-
-(defun optimized-structure-slot-boundp-using-class-method-function (class object slotd)
-  (declare (ignore class object slotd))
-  t)
-
-(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (make-optimized-structure-slot-value-using-class-method-function
-		 (slot-definition-internal-reader-function slotd)))
-	(writer (make-optimized-structure-setf-slot-value-using-class-method-function
-		 (slot-definition-internal-writer-function slotd)))
-	(boundp #'optimized-structure-slot-boundp-using-class-method-function))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  (t (error "~S is not a standard-class" class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function 
-	      (ecase name
-		(reader 
-		 #'make-optimized-std-slot-value-using-class-method-function)
-		(writer 
-		 #'make-optimized-std-setf-slot-value-using-class-method-function)
-		(boundp 
-		 #'make-optimized-std-slot-boundp-using-class-method-function))))
-	#+cmu (declare (type function function))
-	(values (funcall function fsc-p slot-name index) index))))
-
-(defun make-optimized-std-slot-value-using-class-method-function
-    (fsc-p slot-name index)
+#+pcl-user-instances
+(defun make-optimized-user-reader-method-function (slot-name index)
   (declare #.*optimize-speed*)
-  (etypecase index
-    (fixnum (if fsc-p
-		#'(lambda (class instance slotd)
-		    (declare (ignore slotd))
-		    (unless (fsc-instance-p instance) (error "not fsc"))
-		    (let ((value (%svref (fsc-instance-slots instance) index)))
-		      (if (eq value *slot-unbound*)
-			  (slot-unbound class instance slot-name)
-			  value)))
-		#'(lambda (class instance slotd)
-		    (declare (ignore slotd))
-		    (unless (std-instance-p instance) (error "not std"))
-		    (let ((value (%svref (std-instance-slots instance) index)))
-		      (if (eq value *slot-unbound*)
-			  (slot-unbound class instance slot-name)
-			  value)))))
-    (cons   #'(lambda (class instance slotd)
-		(declare (ignore slotd))
-		(let ((value (cdr index)))
-		  (if (eq value *slot-unbound*)
-		      (slot-unbound class instance slot-name)
-		      value))))))
-
-(defun make-optimized-std-setf-slot-value-using-class-method-function
-    (fsc-p slot-name index)
+  (progn slot-name)
+  #'(lambda (instance)
+      (let ((value (%svref (user-instance-slots instance) index)))
+        (if (eq value *slot-unbound*)
+            (slot-unbound (class-of instance) instance slot-name)
+            value))))
+
+#+pcl-user-instances
+(defun make-optimized-user-writer-method-function (index)
   (declare #.*optimize-speed*)
-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-		#'(lambda (nv class instance slotd)
-		    (declare (ignore class slotd))
-		    (setf (%svref (fsc-instance-slots instance) index) nv))
-		#'(lambda (nv class instance slotd)
-		    (declare (ignore class slotd))
-		    (setf (%svref (std-instance-slots instance) index) nv))))
-    (cons   #'(lambda (nv class instance slotd)
-		(declare (ignore class instance slotd))
-		(setf (cdr index) nv)))))
-
-(defun make-optimized-std-slot-boundp-using-class-method-function
-    (fsc-p slot-name index)
+  #'(lambda (nv instance)
+      (setf (%svref (user-instance-slots instance) index) nv)))
+
+#+pcl-user-instances
+(defun make-optimized-user-boundp-method-function (index)
   (declare #.*optimize-speed*)
-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-		#'(lambda (class instance slotd)
-		    (declare (ignore class slotd))
-		    (not (eq *slot-unbound* 
-			     (%svref (fsc-instance-slots instance) index))))
-		#'(lambda (class instance slotd)
-		    (declare (ignore class slotd))
-		    (not (eq *slot-unbound* 
-			     (%svref (std-instance-slots instance) index))))))
-    (cons   #'(lambda (class instance slotd)
-		(declare (ignore class instance slotd))
-		(not (eq *slot-unbound* (cdr index)))))))
+  #'(lambda (instance)
+      (not (eq *slot-unbound* (%svref (user-instance-slots instance) index)))))
+
+
+(defvar *accessor-from-svuc-table* (make-hash-table :test 'equal))
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
-  #+cmu (declare (type function sdfun))
+  (declare (type real-function sdfun))
+  (let ((table-index (list class slotd sdfun name)))
+    (or (gethash table-index *accessor-from-svuc-table*)
+        (setf (gethash table-index *accessor-from-svuc-table*)
+              (make-accessor-from-svuc-method-function
+                 class slotd sdfun name)))))
+
+(defun make-accessor-from-svuc-method-function (class slotd sdfun name)
+  (declare #.*optimize-speed*)
+  (declare (type real-function sdfun))
   (set-function-name
    (case name
-     (reader #'(lambda (instance) (funcall sdfun class instance slotd)))
-     (writer #'(lambda (nv instance) (funcall sdfun nv class instance slotd)))
-     (boundp #'(lambda (instance) (funcall sdfun class instance slotd))))
+     (reader #'(lambda (instance)
+                 (method-function-funcall sdfun class instance slotd)))
+     (writer #'(lambda (nv instance)
+                 (method-function-funcall sdfun nv class instance slotd)))
+     (boundp #'(lambda (instance)
+                 (method-function-funcall sdfun class instance slotd))))
    `(,name ,(class-name class) ,(slot-definition-name slotd))))
 
-(defun make-internal-reader-method-function (slot-name)
+
+(defun make-std-reader-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (fast-slot-value instance slot-name slow-slot-value)))
+
+(defun make-std-writer-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (nv instance)
+      (fast-set-slot-value instance slot-name nv slow-slot-value)))
+
+(defun make-std-boundp-method-function (slot-name)
+  (declare #.*optimize-speed*)
   #'(lambda (instance)
-      (let ((wrapper (cond ((std-instance-p instance) 
-			    (std-instance-wrapper instance))
-			   ((fsc-instance-p instance) 
-			    (fsc-instance-wrapper instance)))))
-	(if wrapper
-	    (let* ((class (wrapper-class wrapper))
-		   (index (or (instance-slot-index wrapper slot-name)
-			      (assq slot-name (wrapper-class-slots wrapper)))))
-	      (typecase index
-		(fixnum 	
-		 (let ((value (%svref (get-slots instance) index)))
-		   (if (eq value *slot-unbound*)
-		       (slot-unbound (class-of instance) instance slot-name)
-		       value)))
-		(cons
-		 (let ((value (cdr index)))
-		   (if (eq value *slot-unbound*)
-		       (slot-unbound (class-of instance) instance slot-name)
-		       value)))
-		(t
-		 (error "The wrapper for class ~S does not have the slot ~S"
-			class slot-name))))
-	    (slot-value instance slot-name)))))
-
-
-
-
-(defmethod allocate-instance ((class standard-class) &rest initargs)
-  (declare (ignore initargs))
-  (unless (class-finalized-p class) (finalize-inheritance class))
-  (let* ((class-wrapper (class-wrapper class))
-	 (instance (%allocate-instance--class
-		     (class-no-of-instance-slots class))))
-    (setf (std-instance-wrapper instance) class-wrapper)
-    instance))
-
-(defmethod allocate-instance ((class structure-class) &rest initargs)
-  (declare (ignore initargs))
-  (let ((constructor (class-defstruct-constructor class)))
-    (if constructor
-	(funcall constructor)
-	(error "Can't allocate an instance of class ~S" (class-name class)))))
+      (fast-slot-boundp instance slot-name slow-slot-boundp)))
+
+
+(defun make-documented-std-reader-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (args next-methods)
+      (declare (ignore next-methods))
+      (let ((instance (car args)))
+        (fast-slot-value instance slot-name slow-slot-value))))
+
+(defun make-documented-std-writer-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (args next-methods)
+      (declare (ignore next-methods))
+      (let ((instance  (cadr args))
+            (new-value (car args)))
+        (fast-set-slot-value instance slot-name new-value slow-slot-value))))
+
+(defun make-documented-std-boundp-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (args next-methods)
+      (declare (ignore next-methods))
+      (let ((instance (car args)))
+        (fast-slot-boundp instance slot-name slow-slot-boundp))))
+
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 1ac86df22..cc73962d1 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -33,29 +33,39 @@
     (writer (slot-definition-writer-function slotd))
     (boundp (slot-definition-boundp-function slotd))))
 
-(defmethod (setf slot-accessor-function) (function 
-					  (slotd effective-slot-definition) type)
+(defvar *dfuns-needing-update* NIL)
+(defvar *classes-being-updated* NIL)
+
+(defmethod update-slot-accessor-function ((slotd effective-slot-definition)
+                                          type function
+                                          &optional (update-accessors-p T))
   (ecase type
-    (reader (setf (slot-definition-reader-function slotd) function))
-    (writer (setf (slot-definition-writer-function slotd) function))
+    (reader (setf (slot-definition-reader-function slotd) function)
+            (when (and update-accessors-p (eq *boot-state* 'complete))
+              (dolist (reader (slot-definition-readers slotd))
+                (pushnew reader *dfuns-needing-update* :test #'eq))))
+    (writer (setf (slot-definition-writer-function slotd) function)
+            (when (and update-accessors-p (eq *boot-state* 'complete))
+              (dolist (writer (slot-definition-writers slotd))
+                (pushnew writer *dfuns-needing-update*))))
     (boundp (setf (slot-definition-boundp-function slotd) function))))
 
 (defconstant *slotd-reader-function-std-p* 1)
 (defconstant *slotd-writer-function-std-p* 2)
 (defconstant *slotd-boundp-function-std-p* 4)
-(defconstant *slotd-all-function-std-p* 7)
+(defconstant *slotd-all-function-std-p*    7)
 
 (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
   (let ((flags (slot-value slotd 'accessor-flags)))
-    (declare (type fixnum flags))
+    (declare (type index flags))
     (if (eq type 'all)
-	(eql *slotd-all-function-std-p* flags)
+	(= *slotd-all-function-std-p* flags)
 	(let ((mask (ecase type
 		      (reader *slotd-reader-function-std-p*)
 		      (writer *slotd-writer-function-std-p*)
 		      (boundp *slotd-boundp-function-std-p*))))
-	  (declare (type fixnum mask))
-	  (not (zerop (the fixnum (logand mask flags))))))))
+	  (declare (type index mask))
+	  (not (zerop (the index (logand mask flags))))))))
 
 (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
   (let ((mask (ecase type
@@ -63,31 +73,20 @@
 		(writer *slotd-writer-function-std-p*)
 		(boundp *slotd-boundp-function-std-p*)))
 	(flags (slot-value slotd 'accessor-flags)))
-    (declare (type fixnum mask flags))
+    (declare (type index mask flags))
     (setf (slot-value slotd 'accessor-flags)
 	  (if value
-	      (the fixnum (logior mask flags))
-	      (the fixnum (logand (the fixnum (lognot mask)) flags)))))
+	      (the index (logior mask flags))
+	      (the index (logand (the index (lognot mask)) flags)))))
   value)
 
 (defvar *name->class->slotd-table* (make-hash-table))
-(defvar *isl-cache-update-info* nil)
-
-(defun update-isl-cache-info (class)
-  (let ((slot-names-for-isl-update nil)
-	(new-icui nil))
-    (dolist (icu *isl-cache-update-info*)
-      (if (eq (car icu) class)
-	  (push (cdr icu) slot-names-for-isl-update)
-	  (push icu new-icui)))
-    (setq *isl-cache-update-info* new-icui)
-    (update-all-isl-caches class slot-names-for-isl-update)))
 
 (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
   (let* ((name (slot-value slotd 'name))
 	 (class (slot-value slotd 'class))
-	 (old-slotd (find-slot-definition class name))
-	 (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
+	 (old-slotd (and (slot-boundp class 'slots)
+                         (find-slot-definition class name))))
     (let ((table (or (gethash name *name->class->slotd-table*)
 		     (setf (gethash name *name->class->slotd-table*)
 			   (make-hash-table :test 'eq :size 5)))))
@@ -103,28 +102,44 @@
 		(get-accessor-method-function gf type class slotd))
 	      (get-optimized-std-accessor-method-function class slotd type))
 	(setf (slot-accessor-std-p slotd type) std-p)
-	(setf (slot-accessor-function slotd type) function)))
-    (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
-      (push (cons class name) *isl-cache-update-info*))
-    (initialize-internal-slot-gfs name)))
+        (let ((old-function
+                (if old-slotd (slot-accessor-function old-slotd type))))
+	  (update-slot-accessor-function slotd type function
+            (and old-function (neq function old-function))))))))
+
+(defmethod initialize-internal-slot-functions :after
+          ((slotd standard-effective-slot-definition))
+  (let ((name (slot-definition-name slotd)))
+    (unless *safe-to-use-slot-value-wrapper-optimizations-p*
+      (initialize-internal-slot-reader-gfs name))
+    (unless *safe-to-use-set-slot-value-wrapper-optimizations-p*
+      (initialize-internal-slot-writer-gfs name))
+    (unless *safe-to-use-slot-boundp-wrapper-optimizations-p*
+      (initialize-internal-slot-boundp-gfs name))))
+
+(defmethod (setf slot-definition-reader-function) :after 
+    (new-value (slotd effective-slot-definition))
+  (setf (internal-slotd-reader-function (slot-value slotd 'internal-slotd))
+        new-value))
+
+(defmethod (setf slot-definition-writer-function) :after 
+    (new-value (slotd effective-slot-definition))
+  (setf (internal-slotd-writer-function (slot-value slotd 'internal-slotd))
+        new-value))
+
+(defmethod (setf slot-definition-boundp-function) :after 
+    (new-value (slotd effective-slot-definition))
+  (setf (internal-slotd-boundp-function (slot-value slotd 'internal-slotd))
+        new-value))
 
 (defmethod (setf slot-definition-location) :after 
     (location (slotd standard-effective-slot-definition))
-  (declare (ignore location))
+  (setf (internal-slotd-location (slot-value slotd 'internal-slotd))
+        location)
   (initialize-internal-slot-functions slotd))
 
-(defmethod slot-definition-allocation ((slotd structure-slot-definition))
-  :instance)
 
 
-
-(defmethod shared-initialize :after ((object documentation-mixin)
-                                     slot-names
-                                     &key (documentation nil documentation-p))
-  (declare (ignore slot-names))
-  (when documentation-p
-    (setf (plist-value object 'documentation) documentation)))
-
 (defmethod documentation (object &optional doc-type)
   (lisp:documentation object doc-type))
 
@@ -133,50 +148,57 @@
   (error "Can't change the documentation of ~S." object))
 
 
-(defmethod documentation ((object documentation-mixin) &optional doc-type)
-  (declare (ignore doc-type))
-  (plist-value object 'documentation))
-
-(defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type)
-  (declare (ignore doc-type))
-  (setf (plist-value object 'documentation) new-value))
+(defmethod documentation ((object documentation-mixin)
+                          &optional (doc-type NIL doc-type-p))
+  (if doc-type-p
+      (error
+        "Doc-type parameter (~S) supplied to documentation called
+         on PCL object ~S"
+        doc-type object)
+     (slot-value object 'documentation)))
+
+(defmethod (setf documentation) (new-value (object documentation-mixin)
+                                 &optional (doc-type NIL doc-type-p))
+  (if doc-type-p
+      (error
+        "Doc-type parameter (~S) supplied to (setf documentation) called
+         on PCL object ~S"
+        doc-type object)
+      (setf (slot-value object 'documentation) new-value)))
+
+(defmethod shared-initialize :before ((object documentation-mixin)
+                                      slot-names
+                                      &key documentation)
+  (declare (ignore slot-names))
+  (unless (legal-documentation-p object documentation)
+    (error "When initializing the ~A ~S:~%~
+            The ~S initialization argument was: ~A.~%~
+            It must be a string or nil."
+       (string-downcase (symbol-name (class-name (class-of object))))
+       object :documentation documentation)))
 
+(defmethod legal-documentation-p ((object documentation-mixin) x)
+  (or (null x) (stringp x)))
 
-(defmethod documentation ((slotd standard-slot-definition) &optional doc-type)
-  (declare (ignore doc-type))
-  (slot-value slotd 'documentation))
 
-(defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type)
-  (declare (ignore doc-type))
-  (setf (slot-value slotd 'documentation) new-value))
 
 
 ;;;
 ;;; Various class accessors that are a little more complicated than can be
 ;;; done with automatically generated reader methods.
 ;;;
-(defmethod class-finalized-p ((class pcl-class))
-  (not (null (class-wrapper class))))
 
 (defmethod class-prototype ((class std-class))
   (with-slots (prototype) class
-    (or prototype (setq prototype (allocate-instance class)))))
+    (or prototype
+        (if (memq class *classes-being-updated*)
+            (allocate-instance class)
+            (setq prototype (make-class-prototype class))))))
 
-(defmethod class-prototype ((class structure-class))
-  (with-slots (prototype wrapper defstruct-constructor) class
-    (or prototype 
-	(setq prototype 
-	      (if defstruct-constructor
-		  (allocate-instance class)
-		  (let* ((proto (%allocate-instance--class 0)))
-		    (setf (std-instance-wrapper proto) wrapper)
-		    proto))))))
-
-(defmethod class-direct-default-initargs ((class slot-class))
-  (plist-value class 'direct-default-initargs))
-
-(defmethod class-default-initargs ((class slot-class))
-  (plist-value class 'default-initargs))
+(defmethod make-class-prototype ((class std-class))
+  (let ((proto (allocate-instance class)))
+    (shared-initialize proto T :check-initargs-legality-p NIL)
+    proto))
 
 (defmethod class-constructors ((class slot-class))
   (plist-value class 'constructors))
@@ -184,6 +206,24 @@
 (defmethod class-slot-cells ((class std-class))
   (plist-value class 'class-slot-cells))
 
+(defmethod (setf class-name) (new-value (class std-class))
+  (reinitialize-instance class :name new-value))
+
+(defmethod slot-unbound :around ((class class) class-instance slot-name)
+  (let ((documented-reader
+          (case slot-name
+            (default-initargs      'class-default-initargs)
+            (class-precedence-list 'class-precedence-list)
+            (prototype             'class-prototype)
+            (slots                 'class-slots))))
+    (if documented-reader
+        (if (class-finalized-p class-instance)
+            (error "Huh? -- ~S slot unbound in ~S when finalized."
+                   slot-name class-instance)
+            (error "~S called on ~S before it is finalized."
+                   documented-reader class-instance))
+        (call-next-method))))
+
 
 ;;;
 ;;; Class accessors that are even a little bit more complicated than those
@@ -297,12 +337,14 @@
 		    (gather1 (method-generic-function m)))))))))
 
 (defun map-all-classes (function &optional (root-name 't))
+  (declare (type real-function function))
   (labels ((do-class (class)
 	     (mapc #'do-class (class-direct-subclasses class))
 	     (funcall function class)))
     (do-class (find-class root-name))))
 
 (defun map-specializers (function)
+  (declare (type real-function function))
   (map-all-classes #'(lambda (class)
 		       (funcall function (class-eq-specializer class))
 		       (funcall function class)))
@@ -317,6 +359,7 @@
   nil)
 
 (defun map-all-generic-functions (function)
+  (declare (type real-function function))
   (let ((all-generic-functions (make-hash-table :test 'eq)))
     (map-specializers #'(lambda (specl)
 			  (dolist (gf (specializer-direct-generic-functions specl))
@@ -344,27 +387,7 @@
 						  ,(load-truename))
 			     other))
 
-(defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class name (find-class name nil) all))
-
-(defmethod ensure-class-using-class (name (class null) &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (ensure-class-values class args)
-    (inform-type-system-about-class (class-prototype meta) name);***
-    (setf class (apply #'make-instance meta :name name initargs)
-	  (find-class name) class
-	  (find-class-predicate name) (symbol-function (class-predicate-name class)))
-    (inform-type-system-about-class class name)	                ;***
-    class))
-
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
-  (multiple-value-bind (meta initargs)
-      (ensure-class-values class args)
-    (unless (eq (class-of class) meta) (change-class class meta))
-    (apply #'reinitialize-instance class initargs)
-    (inform-type-system-about-class class name)	                ;***
-    class))
-
+(declaim (ftype (function (T T) (values T list)) ensure-class-values))
 (defun ensure-class-values (class args)
   (let* ((initargs (copy-list args))
 	 (unsupplied (list 1))
@@ -399,19 +422,42 @@
 		     (and (neq supplied-slots unsupplied) supplied-slots)
 		     initargs)))))
 
+(defun ensure-class (name &rest all)
+  (apply #'ensure-class-using-class name (find-class name nil) all))
+
+(defmethod ensure-class-using-class (name (class null) &rest args &key)
+  (multiple-value-bind (meta initargs)
+      (ensure-class-values class args)
+    (setf class (apply #'make-instance meta :name name initargs))
+    class))
+
+(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
+  (declare (ignore name))
+  (multiple-value-bind (meta initargs)
+      (ensure-class-values class args)
+    (unless (eq (class-of class) meta) (change-class class meta))
+    (apply #'reinitialize-instance class initargs)
+    class))
+
 
 ;;;
 ;;;
 ;;;
-#|| ; since it doesn't do anything
+
 (defmethod shared-initialize :before ((class std-class)
 				      slot-names
-				      &key direct-superclasses)
+				      &key (name nil name-p))
   (declare (ignore slot-names))
-  ;; *** error checking
-  )
-||#
-  
+  (when name-p
+    (unless (legal-class-name-p name)
+      (error "~S is not a legal class name." name))
+    (when (slot-boundp class 'name)
+      (setf (find-class (slot-value class 'name)) nil))))
+
+(defmethod make-direct-slotd ((class std-class) &rest initargs)
+  (let ((initargs (list* :class class initargs)))
+    (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
+
 (defmethod shared-initialize :after
 	   ((class std-class)
 	    slot-names
@@ -434,11 +480,12 @@
   (setq direct-slots
 	(if direct-slots-p
 	    (setf (slot-value class 'direct-slots)
-		  (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
+		  (mapcar #'(lambda (pl) (apply #'make-direct-slotd class pl))
+                          direct-slots))
 	    (slot-value class 'direct-slots)))
   (if direct-default-initargs-p
-      (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
-      (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
+      (setf (slot-value class 'direct-default-initargs) direct-default-initargs)
+      (setq direct-default-initargs (class-direct-default-initargs class)))
   (setf (plist-value class 'class-slot-cells)
 	(gathering1 (collecting)
 	  (dolist (dslotd direct-slots)
@@ -446,18 +493,21 @@
 	      (let ((initfunction (slot-definition-initfunction dslotd)))
 		(gather1 (cons (slot-definition-name dslotd)
 			       (if initfunction 
-				   (funcall initfunction)
+				   (slot-initfunction-funcall initfunction)
 				   *slot-unbound*))))))))
-  (setq predicate-name (if predicate-name-p
-			   (setf (slot-value class 'predicate-name)
-				 (car predicate-name))
-			   (or (slot-value class 'predicate-name)
-			       (setf (slot-value class 'predicate-name)
-				     (make-class-predicate-name (class-name class))))))
+  (let ((name (class-name class)))
+    (when name
+      (if predicate-name-p
+          (progn
+            (setf (slot-value class 'predicate-name) (car predicate-name))
+            (setf (find-class-predicate name) (make-class-predicate class)))
+          (unless (slot-value class 'predicate-name)
+	    (setf (slot-value class 'predicate-name)
+	          (make-class-predicate-name name))))
+      (setf (find-class name) class)
+      (inform-type-system-about-class class name)))
   (add-direct-subclasses class direct-superclasses)
-  (update-class class nil)
-  (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
+  (add-slot-accessors    class direct-slots))
 
 (defmethod shared-initialize :before ((class class) slot-names &key)
   (declare (ignore slot-names))
@@ -469,149 +519,70 @@
   (remove-direct-subclasses class (class-direct-superclasses class))
   (remove-slot-accessors    class (class-direct-slots class)))
 
-(defmethod reinitialize-instance :after ((class slot-class)
+(defmethod reinitialize-instance :after ((class std-class)
 					 &rest initargs
 					 &key)
+  (update-class class nil)
   (map-dependents class
 		  #'(lambda (dependent)
 		      (apply #'update-dependent class dependent initargs))))
 
-(defmethod shared-initialize :after 
-      ((class structure-class)
-       slot-names
-       &key (direct-superclasses nil direct-superclasses-p)
-            (direct-slots nil direct-slots-p)
-            direct-default-initargs
-            (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names direct-default-initargs))
-  (if direct-superclasses-p
-      (setf (slot-value class 'direct-superclasses)
-	    (or direct-superclasses
-		(setq direct-superclasses
-		      (and (not (eq (class-name class) 'structure-object))
-			   (list *the-class-structure-object*)))))
-      (setq direct-superclasses (slot-value class 'direct-superclasses)))
-  (let* ((name (class-name class))
-	 (from-defclass-p (slot-value class 'from-defclass-p))
-	 (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
-    (if direct-slots-p
-	(setf (slot-value class 'direct-slots)
-	      (setq direct-slots
-		    (mapcar #'(lambda (pl)
-				(when defstruct-p
-				  (let* ((slot-name (getf pl :name))
-					 (acc-name (format nil "~s structure class ~a" 
-							   name slot-name))
-					 (accessor (intern acc-name)))
-				    (setq pl (list* :defstruct-accessor-symbol accessor
-						    pl))))
-				(make-direct-slotd class pl))
-			    direct-slots)))
-	(setq direct-slots (slot-value class 'direct-slots)))
-    (when defstruct-p
-      (let* ((include (car (slot-value class 'direct-superclasses)))
-	     (conc-name (intern (format nil "~s structure class " name)))
-	     (constructor (intern (format nil "~a constructor" conc-name)))
-	     (defstruct `(defstruct (,name
-				      ,@(when include
-					  `((:include ,(class-name include))))
-				      (:print-function print-std-instance)
-				      (:predicate nil)
-				      (:conc-name ,conc-name)
-				      (:constructor ,constructor ()))
-			   ,@(mapcar #'slot-definition-name direct-slots)))
-	     (reader-names (mapcar #'(lambda (slotd)
-				       (intern (format nil "~A~A reader" conc-name 
-						       (slot-definition-name slotd))))
-				   direct-slots))
-	     (writer-names (mapcar #'(lambda (slotd)
-				       (intern (format nil "~A~A writer" conc-name 
-						       (slot-definition-name slotd))))
-				   direct-slots))
-	     (readers-init 
-	      (mapcar #'(lambda (slotd reader-name)
-			  (let ((accessor 
-				 (slot-definition-defstruct-accessor-symbol slotd)))
-			    `(defun ,reader-name (obj)
-			       (declare (type ,name obj))
-			       (,accessor obj))))
-		      direct-slots reader-names))
-	     (writers-init 
-	      (mapcar #'(lambda (slotd writer-name)
-			  (let ((accessor 
-				 (slot-definition-defstruct-accessor-symbol slotd)))
-			    `(defun ,writer-name (nv obj)
-			       (declare (type ,name obj))
-			       (setf (,accessor obj) nv))))
-		      direct-slots writer-names))
-	     (defstruct-form
-	       `(progn
-		  ,defstruct
-		  ,@readers-init ,@writers-init
-		  (declare-structure ',name nil nil))))
-	(unless (structure-type-p name) (eval defstruct-form))
-	(mapc #'(lambda (dslotd reader-name writer-name)
-		  (let* ((reader (gdefinition reader-name))
-			 (writer (when (gboundp writer-name)
-				   (gdefinition writer-name))))
-		    (setf (slot-value dslotd 'internal-reader-function) reader)
-		    (setf (slot-value dslotd 'internal-writer-function) writer)))
-	      direct-slots reader-names writer-names)
-	(setf (slot-value class 'defstruct-form) defstruct-form)
-	(setf (slot-value class 'defstruct-constructor) constructor))))
-  (add-direct-subclasses class direct-superclasses)
-  (setf (slot-value class 'class-precedence-list) 
-	(compute-class-precedence-list class))
-  (setf (slot-value class 'slots) (compute-slots class))
-  (update-isl-cache-info class)
-  (unless (slot-value class 'wrapper) 
-    (setf (slot-value class 'wrapper) (make-wrapper class)))
-  (setq predicate-name (if predicate-name-p
-			   (setf (slot-value class 'predicate-name)
-				 (car predicate-name))
-			   (or (slot-value class 'predicate-name)
-			       (setf (slot-value class 'predicate-name)
-				     (make-class-predicate-name (class-name class))))))
-  (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
-
-(defmethod direct-slot-definition-class ((class structure-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'structure-direct-slot-definition))
 
-(defmethod finalize-inheritance ((class structure-class))
-  nil) ; always finalized
  
-
-(defun make-class-predicate (class name)
-  (let* ((gf (ensure-generic-function name))
+(defun make-class-predicate (class)
+  (let* ((name (class-predicate-name class))
+         (gf (ensure-generic-function name))
+         (method-class (find-class 'standard-method nil))
+         (method-proto
+           (if (and method-class (class-finalized-p method-class))
+               (class-prototype method-class)))
+         (store-method-function-p
+          (call-store-method-function-p gf method-proto nil))
+         (store-method-optimized-function-p
+          (call-store-method-optimized-function-p gf method-proto nil))
 	 (mlist (if (eq *boot-state* 'complete)
 		    (generic-function-methods gf)
 		    (early-gf-methods gf))))
     (unless mlist
       (unless (eq class *the-class-t*)
-	(let* ((default-method-function #'function-returning-nil)
-	       (default-method (make-a-method 'standard-method
-					      ()
-					      (list 'object)
-					      (list *the-class-t*)
-					      default-method-function
-					      "class predicate default method")))
-	  (setf (getf (method-function-plist default-method-function)
-		      :constant-value) nil)
+	(let ((default-method
+                (make-a-method
+                  'standard-method
+	          ()
+	          (list 'object)
+	          (list *the-class-t*)
+                  (when store-method-function-p
+                    #'documented-function-returning-nil)
+                  (when store-method-optimized-function-p
+                    #'function-returning-nil)
+	          NIL
+	          "class predicate default method"
+                  NIL
+                  `(:constant-value NIL))))
 	  (add-method gf default-method)))
-      (let* ((class-method-function #'function-returning-t)
-	     (class-method (make-a-method 'standard-method
-					  ()
-					  (list 'object)
-					  (list class)
-					  class-method-function
-					  "class predicate class method")))
-	(setf (getf (method-function-plist class-method-function)
-		    :constant-value) t)
+      (let ((class-method
+              (make-a-method
+                'standard-method
+	        ()
+	        (list 'object)
+		(list class)
+                (when store-method-function-p
+                  #'documented-function-returning-t)
+                (when store-method-optimized-function-p
+                  #'function-returning-t)
+	        NIL
+		"class predicate class method"
+                NIL
+                `(:constant-value T))))
 	(add-method gf class-method)))
     gf))
 
+(defun fix-dfuns-needing-update ()
+  (loop (unless *dfuns-needing-update* (return T))
+        (let ((name (pop *dfuns-needing-update*)))
+          (when (gboundp name)
+            (update-dfun (gdefinition name))))))
+
 (defun add-slot-accessors (class dslotds)
   (fix-slot-accessors class dslotds 'add))
 
@@ -619,19 +590,20 @@
   (fix-slot-accessors class dslotds 'remove))
 
 (defun fix-slot-accessors (class dslotds add/remove)  
-  (flet ((fix (gfspec name r/w)
+  (flet ((fix (gfspec name dslot r/w)
 	   (let ((gf (ensure-generic-function gfspec)))
 	     (case r/w
 	       (r (if (eq add/remove 'add)
-		      (add-reader-method class gf name)
+		      (add-reader-method class gf name dslot)
 		      (remove-reader-method class gf)))
 	       (w (if (eq add/remove 'add)
-		      (add-writer-method class gf name)
+		      (add-writer-method class gf name dslot)
 		      (remove-writer-method class gf)))))))
     (dolist (dslotd dslotds)
-      (let ((slot-name (slot-definition-name dslotd)))
-	(dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
-	(dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
+      (let ((name (slot-definition-name dslotd)))
+        (dolist (r (slot-definition-readers dslotd)) (fix r name dslotd 'r))
+        (dolist (w (slot-definition-writers dslotd)) (fix w name dslotd 'w)))))
+  (fix-dfuns-needing-update))
 
 
 (defun add-direct-subclasses (class new)
@@ -648,27 +620,34 @@
 ;;;
 ;;;
 ;;;
+
+(defvar *notify-finalize* NIL)
+
 (defmethod finalize-inheritance ((class std-class))
+  (when *notify-finalize*
+    (warn "Finalizing ~S" class))
   (update-class class t))
 
+(defmacro assure-finalized (class)
+  (once-only (class)
+    `(unless (class-finalized-p ,class) (finalize-inheritance ,class))))
+
+
 
-(defun class-has-a-forward-referenced-superclass-p (class)
-  (or (forward-referenced-class-p class)
-      (some #'class-has-a-forward-referenced-superclass-p
-	    (class-direct-superclasses class))))	 
       
 ;;;
 ;;; Called by :after shared-initialize whenever a class is initialized or 
 ;;; reinitialized.  The class may or may not be finalized.
 ;;; 
 (defun update-class (class finalizep)  
-  (when (or finalizep (class-finalized-p class)
-	    (not (class-has-a-forward-referenced-superclass-p class)))
+  (when (or finalizep (class-finalized-p class))
+    (push class *classes-being-updated*)
     (update-cpl class (compute-class-precedence-list class))
-    (update-slots class (compute-slots class))
+    (update-slots class)
     (update-gfs-of-class class)
     (update-inits class (compute-default-initargs class))
-    (update-constructors class))
+    (update-constructors class)
+    (setf *classes-being-updated* (delete class *classes-being-updated*)))
   (unless finalizep
     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
 
@@ -676,94 +655,141 @@
   (when (class-finalized-p class)
     (unless (equal (class-precedence-list class) cpl)
       (force-cache-flushes class)))
-  (setf (slot-value class 'class-precedence-list) cpl)
+  (fast-set-slot-value class 'class-precedence-list cpl slow-slot-value)
   (update-class-can-precede-p cpl))
 
 (defun update-class-can-precede-p (cpl)
   (when cpl
-    (let ((first (car cpl)))
+    (let* ((first (car cpl))
+           (orig-precede-list
+             (fast-slot-value first 'can-precede-list slow-slot-value))
+           (precede-list orig-precede-list))
       (dolist (c (cdr cpl))
-	(pushnew c (slot-value first 'can-precede-list))))
+        (unless (memq c precede-list)
+          (setf precede-list (cons c precede-list))))
+      (unless (eq precede-list orig-precede-list)
+        (fast-set-slot-value first 'can-precede-list precede-list
+                             slow-slot-value)))
     (update-class-can-precede-p (cdr cpl))))
 
 (defun class-can-precede-p (class1 class2)
-  (member class2 (class-can-precede-list class1)))
+  (memq class2 (class-can-precede-list class1)))
 
-(defun update-slots (class eslotds)
+
+(declaim (ftype (function (T T) (values list list)) compute-storage-info))
+(defmethod compute-storage-info ((class std-class) eslotds)
   (let ((instance-slots ())
 	(class-slots    ()))
     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
 	(cond ((eq alloc :instance) (push eslotd instance-slots))
 	      ((classp alloc)       (push eslotd class-slots)))))
-    ;;
-    ;; If there is a change in the shape of the instances then the
-    ;; old class is now obsolete.
-    ;;
-    (let* ((nlayout (mapcar #'slot-definition-name
-			    (sort instance-slots #'< :key #'slot-definition-location)))
-	   (nwrapper-class-slots (compute-class-slots class-slots))
-	   (owrapper (class-wrapper class))
-	   (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
-	   (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
-	   (nwrapper
-	    (cond ((null owrapper)
-		   (make-wrapper class))
-		  ((and (equal nlayout olayout)
-			(not
-			 (iterate ((o (list-elements owrapper-class-slots))
-				   (n (list-elements nwrapper-class-slots)))
-				  (unless (eq (car o) (car n)) (return t)))))
-		   owrapper)
-		  (t
-		   ;;
-		   ;; This will initialize the new wrapper to have the same
-		   ;; state as the old wrapper.  We will then have to change
-		   ;; that.  This may seem like wasted work (it is), but the
-		   ;; spec requires that we call make-instances-obsolete.
-		   ;;
-		   (make-instances-obsolete class)
-		   (class-wrapper class)))))
-      (with-slots (wrapper no-of-instance-slots slots) class
-	(setf no-of-instance-slots (length nlayout)
-	      slots eslotds
-	      (wrapper-instance-slots-layout nwrapper) nlayout
-	      (wrapper-class-slots nwrapper) nwrapper-class-slots
-	      wrapper nwrapper))
-      (update-isl-cache-info class))))
-
-(defun compute-class-slots (eslotds)
+    (values (compute-instance-layout class instance-slots)
+	    (compute-class-slots class class-slots))))
+
+(defmethod compute-instance-layout ((class std-class) instance-eslotds)
+  (mapcar #'slot-definition-name
+          (sort instance-eslotds #'< :key #'slot-definition-location)))
+
+(defmethod compute-class-slots ((class std-class) eslotds)
   (gathering1 (collecting)
     (dolist (eslotd eslotds)
       (gather1
-	(assoc (slot-definition-name eslotd)
-	       (class-slot-cells (slot-definition-allocation eslotd)))))))
+	(assq (slot-definition-name eslotd)
+	      (class-slot-cells (slot-definition-allocation eslotd)))))))
 
-(defun compute-layout (cpl instance-eslotds)
+(defmethod compute-layout ((class std-class) cpl instance-eslotds)
   (let* ((names
 	   (gathering1 (collecting)
 	     (dolist (eslotd instance-eslotds)
-	       (when (eq (slot-definition-allocation eslotd) :instance)
-		 (gather1 (slot-definition-name eslotd))))))
+	       (gather1 (slot-definition-name eslotd)))))
 	 (order ()))
     (labels ((rwalk (tail)
 	       (when tail
 		 (rwalk (cdr tail))
-		 (dolist (ss (class-slots (car tail)))
+		 (dolist (ss (class-direct-slots (car tail)))
 		   (let ((n (slot-definition-name ss)))
-		     (when (member n names)
+		     (when (memq n names)
 		       (setq order (cons n order)
 			     names (remove n names))))))))
-      (rwalk (if (slot-boundp (car cpl) 'slots)
-		 cpl
-		 (cdr cpl)))
-      (reverse (append names order)))))
+      (rwalk cpl)
+      (nreverse order))))
+
+(defun update-slots (class)
+  (let* ((owrapper
+           (class-wrapper class))
+         (nwrapper
+           (or owrapper
+               (progn
+                 ;; The class isn't really totally finalized, but the
+                 ;; class finalization functions have to think it is.
+                 (fast-set-slot-value class 'finalized-p T slow-slot-value)
+                 (setf (fast-slot-value class 'prototype) nil)
+                 (setf (fast-slot-value class 'wrapper) (make-wrapper class)))))
+         (eslotds
+           (compute-slots class)))
+    (multiple-value-bind (nlayout nwrapper-class-slots)
+        (compute-storage-info class eslotds)
+      (declare (type list nlayout nwrapper-class-slots))
+      ;;
+      ;; If there is a change in the shape of the instances then the
+      ;; old class is now obsolete.
+      ;;
+      (let* ((olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+	     (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
+             (make-instances-obsolete-p
+               (not (or (null owrapper)
+		        (and (equal nlayout olayout)
+			     (not
+			      (iterate ((o (list-elements owrapper-class-slots))
+				        (n (list-elements nwrapper-class-slots)))
+				       (unless (eq (car o) (car n)) (return t)))))))))
+        (declare (type list    olayout owrapper-class-slots)
+                 (type boolean make-instances-obsolete-p))
+        (when (or (null owrapper) make-instances-obsolete-p)
+          (let ((internal-slotds ())
+                (side-effect-internal-slotds ()))
+            (dolist (eslotd eslotds)
+              (let ((internal-slotd (slot-definition-internal-slotd eslotd)))
+                (push internal-slotd internal-slotds)
+                (unless (slot-definition-initfunction-side-effect-free-p eslotd)
+                  (push internal-slotd side-effect-internal-slotds))))
+            (setf (slow-slot-value class 'slots) eslotds
+                  (slow-slot-value class 'internal-slotds)
+                    (nreverse internal-slotds)
+                  (slow-slot-value class 'side-effect-internal-slotds)
+                    (nreverse side-effect-internal-slotds)))
+          (setf ;; nwrapper is already the same as the class-wrapper
+	        (wrapper-instance-slots-layout nwrapper) nlayout
+                (wrapper-allocate-static-slot-storage-copy nwrapper)
+                  (%allocate-origional-static-slot-storage-copy (length nlayout))
+	        (wrapper-class-slots           nwrapper) nwrapper-class-slots)
+          (unless owrapper
+            (setf (wrapper-unreserved-field    nwrapper) NIL)))
+        (when make-instances-obsolete-p
+          (make-instances-obsolete class))
+        (initialize-allocate-static-slot-storage-copy class)))))
+
+(defmethod initialize-allocate-static-slot-storage-copy ((class std-class))
+  (let* ((dummy-instance (allocate-instance class))
+         (side-effect-free-slots
+           (let ((collect nil))
+             (dolist (slot (class-slots class) collect)
+               (when (slot-definition-initfunction-side-effect-free-p slot)
+                 (push (slot-definition-name slot) collect)))))
+         (wrapper (class-wrapper class))
+         (old-allocate-static-slot-storage-copy
+          (wrapper-allocate-static-slot-storage-copy wrapper)))
+    (shared-initialize dummy-instance side-effect-free-slots
+                       :check-initargs-legality-p NIL)
+    (setf (wrapper-allocate-static-slot-storage-copy wrapper)
+          (or (get-slots-or-nil dummy-instance)
+              old-allocate-static-slot-storage-copy))))
 
 (defun update-gfs-of-class (class)
-  (when (and (class-finalized-p class)
-	     (let ((cpl (class-precedence-list class)))
-	       (or (member *the-class-slot-class* cpl)
-		   (member *the-class-standard-effective-slot-definition* cpl))))
+  (when (let ((cpl (class-precedence-list class)))
+	  (or (memq *the-class-slot-class* cpl)
+	      (memq *the-class-standard-effective-slot-definition* cpl)))
     (let ((gf-table (make-hash-table :test 'eq)))
       (labels ((collect-gfs (class)
 		 (dolist (gf (specializer-direct-generic-functions class))
@@ -776,7 +802,7 @@
 		 gf-table)))))
 
 (defun update-inits (class inits)
-  (setf (plist-value class 'default-initargs) inits))
+  (setf (slot-value class 'default-initargs) inits))
 
 
 ;;;
@@ -807,10 +833,6 @@
   (declare (ignore initargs))
   (find-class 'standard-direct-slot-definition))
 
-(defun make-direct-slotd (class initargs)
-  (let ((initargs (list* :class class initargs)))
-    (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
-
 ;;;
 ;;;
 ;;;
@@ -822,7 +844,7 @@
   ;; The list is in most-specific-first order.
   ;;
   (let ((name-dslotds-alist ()))
-    (dolist (c (class-precedence-list class))
+    (dolist (c (slot-value class 'class-precedence-list))
       (let ((dslotds (class-direct-slots c)))
 	(dolist (d dslotds)
 	  (let* ((name (slot-definition-name d))
@@ -832,53 +854,66 @@
 		(push (list name d) name-dslotds-alist))))))
     (mapcar #'(lambda (direct)
 		(compute-effective-slot-definition class
+                                                   (car direct)
 						   (nreverse (cdr direct))))
 	    name-dslotds-alist)))
 
 (defmethod compute-slots :around ((class std-class))
   (let ((eslotds (call-next-method))
-	(cpl (class-precedence-list class))
+	(cpl (slot-value class 'class-precedence-list))
 	(instance-slots ())
-	(class-slots    ()))
+	(class-slots    ())
+        (other-slots    ()))
     (dolist (eslotd eslotds)
       (let ((alloc (slot-definition-allocation eslotd)))
 	(cond ((eq alloc :instance) (push eslotd instance-slots))
-	      ((classp alloc)       (push eslotd class-slots)))))
-    (let ((nlayout (compute-layout cpl instance-slots)))
+	      ((classp alloc)       (push eslotd class-slots))
+              (T                    (push eslotd other-slots)))))
+    (let ((nlayout (compute-layout class cpl instance-slots)))
+      (declare (type list nlayout))
       (dolist (eslotd instance-slots)
 	(setf (slot-definition-location eslotd) 
-	      (position (slot-definition-name eslotd) nlayout))))
+	      (posq (slot-definition-name eslotd) nlayout))))
     (dolist (eslotd class-slots)
       (setf (slot-definition-location eslotd) 
-	    (assoc (slot-definition-name eslotd)
-		   (class-slot-cells (slot-definition-allocation eslotd)))))      
-    eslotds))
-
-(defmethod compute-slots ((class structure-class))
-  (mapcan #'(lambda (superclass)
-	      (mapcar #'(lambda (dslotd)
-			  (compute-effective-slot-definition class
-							     (list dslotd)))
-		      (class-direct-slots superclass)))
-	  (reverse (slot-value class 'class-precedence-list))))
-
-(defmethod compute-slots :around ((class structure-class))
-  (let ((eslotds (call-next-method)))
-    (mapc #'initialize-internal-slot-functions eslotds)
+	    (assq (slot-definition-name eslotd)
+		  (class-slot-cells (slot-definition-allocation eslotd)))))
+    (dolist (eslotd other-slots)
+      (initialize-internal-slot-functions eslotd))
     eslotds))
 
-(defmethod compute-effective-slot-definition ((class slot-class) dslotds)
+(defmethod compute-effective-slot-definition ((class standard-class) name dslotds)
   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
-	 (class (effective-slot-definition-class class initargs)))
-    (apply #'make-instance class initargs)))
+	 (class (effective-slot-definition-class class initargs))
+         (slot-definition (apply #'make-instance class initargs))
+         (internal-slotd
+           (make-internal-slotd
+             :name name
+             :slot-definition slot-definition
+             :location        (slot-definition-location     slot-definition)
+             :initargs        (slot-definition-initargs     slot-definition)
+             :initfunction    (slot-definition-initfunction slot-definition))))
+    (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
+    slot-definition))
+
+(defmethod compute-effective-slot-definition ((class funcallable-standard-class)
+                                              name dslotds)
+  (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+	 (class (effective-slot-definition-class class initargs))
+         (slot-definition (apply #'make-instance class initargs))
+         (internal-slotd
+           (make-internal-slotd
+             :name name
+             :slot-definition slot-definition
+             :location        (slot-definition-location     slot-definition)
+             :initargs        (slot-definition-initargs     slot-definition)
+             :initfunction    (slot-definition-initfunction slot-definition))))
+    (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
+    slot-definition))
 
 (defmethod effective-slot-definition-class ((class std-class) initargs)
   (declare (ignore initargs))
-  (find-class 'standard-effective-slot-definition))
-
-(defmethod effective-slot-definition-class ((class structure-class) initargs)
-  (declare (ignore initargs))
-  (find-class 'structure-effective-slot-definition))
+  *the-class-standard-effective-slot-definition*)
 
 (defmethod compute-effective-slot-definition-initargs 
     ((class slot-class) direct-slotds)
@@ -887,10 +922,16 @@
 	 (initform nil)
 	 (initargs nil)
 	 (allocation nil)
+         (documentation nil)
 	 (type t)
 	 (namep  nil)
 	 (initp  nil)
-	 (allocp nil))
+	 (allocp nil)
+         (readers nil)
+         (writers nil)
+         (initfunction-side-effect-free-p nil))
+       (declare (type boolean namep initp allocp
+                              initfunction-side-effect-free-p))
 
     (dolist (slotd direct-slotds)
       (when slotd
@@ -898,72 +939,176 @@
 	  (setq name (slot-definition-name slotd)
 		namep t))
 	(unless initp
+	  (setq initform (slot-definition-initform slotd))
 	  (when (slot-definition-initfunction slotd)
-	    (setq initform (slot-definition-initform slotd)
-		  initfunction (slot-definition-initfunction slotd)
+	    (setq initfunction (slot-definition-initfunction slotd)
+                  initfunction-side-effect-free-p
+                    (slot-definition-initfunction-side-effect-free-p slotd)
 		  initp t)))
 	(unless allocp
 	  (setq allocation (slot-definition-allocation slotd)
 		allocp t))
 	(setq initargs (append (slot-definition-initargs slotd) initargs))
 	(let ((slotd-type (slot-definition-type slotd)))
-	  (setq type (cond ((null type)     slotd-type)
+	  (setq type (cond ((eq type 't) slotd-type)
 			   ((*subtypep type slotd-type) type)
-			   (t `(and ,type ,slotd-type)))))))
+                           ((*subtypep slotd-type type) slotd-type)
+			   (t `(and ,type ,slotd-type)))))
+        (unless documentation
+          (setq documentation
+                (fast-slot-value slotd 'documentation slow-slot-value)))
+        (dolist (reader (slot-definition-readers slotd))
+          (pushnew reader readers :test #'eq))
+        (dolist (writer (slot-definition-writers slotd))
+          (pushnew writer writers :test #'eq))))
     (list :name name
 	  :initform initform
 	  :initfunction initfunction
+          :initfunction-side-effect-free-p initfunction-side-effect-free-p
 	  :initargs initargs
 	  :allocation allocation
 	  :type type
-	  :class class)))
-
-(defmethod compute-effective-slot-definition-initargs :around
-    ((class structure-class) direct-slotds)
-  (let ((slotd (car direct-slotds)))
-    (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
-	   :internal-reader-function (slot-definition-internal-reader-function slotd)
-	   :internal-writer-function (slot-definition-internal-writer-function slotd)
-	   (call-next-method))))
+	  :class class
+          :documentation documentation
+          :readers readers
+          :writers writers)))
+
+
 
 ;;;
 ;;; NOTE: For bootstrapping considerations, these can't use make-instance
 ;;;       to make the method object.  They have to use make-a-method which
 ;;;       is a specially bootstrapped mechanism for making standard methods.
 ;;;
-(defmethod add-reader-method ((class slot-class) generic-function slot-name)
-  (let* ((name (class-name class))
-	 (method (make-a-method 'standard-reader-method
-				()
-				(list (or name 'object))
-				(list class)
-				(make-reader-method-function class slot-name)
-				"automatically generated reader method"
-				slot-name)))
-    (add-method generic-function method)))
 
-(defmethod add-writer-method ((class slot-class) generic-function slot-name)
-  (let* ((name (class-name class))
-	 (method (make-a-method 'standard-writer-method
-				()
-				(list 'new-value (or name 'object))
-				(list *the-class-t* class)
-				(make-writer-method-function class slot-name)
-				"automatically generated writer method"
-				slot-name)))
+(defmethod add-reader-method ((class slot-class)
+                              generic-function 
+                              slot-name
+                              &optional
+                              direct-slot)
+  (let*
+    ((reader-class
+       (reader-method-class class direct-slot))
+     (reader-prototype
+       (when reader-class
+         (assure-finalized reader-class)
+         (class-prototype reader-class)))
+     (method
+       (make-a-method
+         (if reader-class (class-name reader-class) 'standard-reader-method)
+         ()
+         (list (or (class-name class) 'standard-object))
+         (list class)
+         (when (call-store-method-function-p generic-function reader-prototype nil)
+           (make-documented-reader-method-function
+             class generic-function reader-prototype slot-name))
+         (when (call-store-method-optimized-function-p
+                 generic-function reader-prototype nil)
+           (if (eq *boot-state* 'complete)
+               (make-optimized-reader-method-function
+                 class generic-function reader-prototype slot-name)
+               (make-std-reader-method-function slot-name)))
+         NIL
+         "automatically generated reader method"
+         slot-name
+         `(,@(when direct-slot (list :slot-definition direct-slot))
+           :needs-next-methods-p NIL))))
     (add-method generic-function method)))
 
-(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
-  (let* ((name (class-name class))
-	 (method (make-a-method 'standard-boundp-method
-				()
-				(list (or name 'object))
-				(list class)
-				(make-boundp-method-function class slot-name)
-				"automatically generated boundp method"
-				slot-name)))
+(defmethod add-writer-method ((class slot-class)
+                              generic-function 
+                              slot-name
+                              &optional
+                              direct-slot)
+  (let*
+    ((writer-class
+       (writer-method-class class direct-slot))
+     (writer-prototype
+       (when writer-class
+         (assure-finalized writer-class)
+         (class-prototype writer-class)))
+     (method
+       (make-a-method
+         (if writer-class (class-name writer-class) 'standard-writer-method)
+         ()
+         (list 'new-value (or (class-name class) 'standard-object))
+         (list *the-class-t* class)
+         (when (call-store-method-function-p generic-function writer-prototype nil)
+           (make-documented-writer-method-function
+             class generic-function writer-prototype slot-name))
+         (when (call-store-method-optimized-function-p
+                 generic-function writer-prototype nil)
+           (if (eq *boot-state* 'complete)
+               (make-optimized-writer-method-function
+                 class generic-function writer-prototype slot-name)
+               (make-std-writer-method-function slot-name)))
+         NIL
+         "automatically generated writer method"
+         slot-name
+         `(,@(when direct-slot (list :slot-definition direct-slot))
+           :needs-next-methods-p NIL))))
+   (add-method generic-function method)))
+
+(defmethod add-boundp-method ((class slot-class)
+                              generic-function
+                              slot-name
+                              &optional
+                              direct-slot)
+  (let*
+    ((boundp-class
+       (boundp-method-class class direct-slot))
+     (boundp-prototype
+       (when boundp-class
+         (assure-finalized boundp-class)
+         (class-prototype boundp-class)))
+     (method
+       (make-a-method
+         (if boundp-class (class-name boundp-class) 'standard-boundp-method)
+         ()
+         (list (or (class-name class) 'standard-object))
+         (list class)
+         (when (call-store-method-function-p generic-function boundp-prototype nil)
+           (make-documented-boundp-method-function
+             class generic-function boundp-prototype slot-name))
+         (when (call-store-method-optimized-function-p
+                 generic-function boundp-prototype nil)
+           (if (eq *boot-state* 'complete)
+               (make-optimized-boundp-method-function
+                 class generic-function boundp-prototype slot-name)
+               (make-std-boundp-method-function slot-name)))
+         NIL
+         "automatically generated boundp method"
+         slot-name
+         `(,@(when direct-slot (list :slot-definition direct-slot))
+           :needs-next-methods-p NIL))))
     (add-method generic-function method)))
 
+
+(defmethod reader-method-class ((class T)
+                                direct-slot
+                                &rest initargs)
+  ;; To handle the case when a reader method is added before
+  ;; standard-reader-method is defined.
+  (declare (ignore direct-slot initargs))
+  NIL)
+
+(defmethod writer-method-class ((class T)
+                                direct-slot
+                                &rest initargs)
+  ;; To handle the case when a writer method is added before
+  ;; standard-writer-method is defined.
+  (declare (ignore direct-slot initargs))
+  NIL)
+
+(defmethod boundp-method-class ((class T)
+                                direct-slot
+                                &rest initargs)
+  ;; To handle the case when a boundp method is added before
+  ;; standard-boundp-method is defined.
+  (declare (ignore direct-slot initargs))
+  NIL)
+
+
 (defmethod remove-reader-method ((class slot-class) generic-function)
   (let ((method (get-method generic-function () (list class) nil)))
     (when method (remove-method generic-function method))))
@@ -993,25 +1138,187 @@
 ;;; *** have to give the optimize-slot-value method the user might have
 ;;; *** defined for this metclass a chance to run.
 ;;;
-(defmethod make-reader-method-function ((class slot-class) slot-name)
-  (if (eq *boot-state* 'complete)
-      (make-std-reader-method-function slot-name)
-      (make-internal-reader-method-function slot-name)))
 
-(defmethod make-writer-method-function ((class slot-class) slot-name)
+(defvar *documented-reader-method-function-makers* NIL)
+(defvar *documented-writer-method-function-makers* NIL)
+(defvar *documented-boundp-method-function-makers* NIL)
+
+(defmethod make-documented-reader-method-function ((class slot-class)
+                                                   generic-function
+                                                   reader-method-prototype
+                                                   slot-name)
+  ;;   Make the documented reader-method-function.  To do this correctly for
+  ;; all cases, we must build the reader method function by passing it
+  ;; through make-method-lambda in case the user does something funky
+  ;; with their method lambdas.
+  ;;   Since there usually won't be many different kinds of method
+  ;; lambdas for readers, this method actually dynamically builds a function
+  ;; to make the documented-reader-method-function from each particular
+  ;; method lambda returned and stores it in
+  ;; *documented-reader-method-functions-makers* to be re-used each time
+  ;; the reader lambda is the same.
+  (multiple-value-bind (method-lambda initargs)
+    (call-make-method-lambda generic-function
+                             reader-method-prototype
+                             '(lambda (instance)
+                                (funcall #'slot-value instance slot-name))
+                             ())
+    (declare (ignore initargs))
+    (funcall-compiled
+       (or (cdr (assoc method-lambda
+                       *documented-reader-method-function-makers*
+                       :test #'equal))
+           (let ((reader-function-maker-name
+                   (gensym "MAKE-DOCUMENTED-READER-METHOD-FUNCTION"))
+                 (compiled-lambda
+                   (compile-lambda
+                     `(lambda (slot-name) (function ,method-lambda)))))
+             (declare (type compiled-function compiled-lambda))
+             (setf (symbol-function reader-function-maker-name)
+                   compiled-lambda)
+             (let ((func (eval `(function ,reader-function-maker-name))))
+               (push (cons method-lambda func)
+                     *documented-reader-method-function-makers*)
+               func)))
+      slot-name)))
+
+(defmethod make-documented-writer-method-function ((class slot-class)
+                                                   generic-function
+                                                   writer-method-prototype
+                                                   slot-name)
+  ;;   Make the documented writer-method-function.  To do this correctly for
+  ;; all cases, we must build the writer method function by passing it
+  ;; through make-method-lambda in case the user does something funky
+  ;; with their method lambdas.
+  ;;   Since there usually won't be many different kinds of method
+  ;; lambdas for writers, this method actually dynamically builds a function
+  ;; to make the documented-writer-method-function from each particular
+  ;; method lambda returned and stores it in
+  ;; *documented-writer-method-functions-makers* to be re-used each time
+  ;; the writer lambda is the same.
+  (multiple-value-bind (method-lambda initargs)
+    (call-make-method-lambda generic-function
+                             writer-method-prototype
+                             '(lambda (nv instance)
+                               (funcall #'set-slot-value instance slot-name nv))
+                             ())
+    (declare (ignore initargs))
+    (funcall-compiled
+       (or (cdr (assoc method-lambda
+                       *documented-writer-method-function-makers*
+                       :test #'equal))
+           (let ((writer-function-maker-name
+                   (gensym "MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION"))
+                 (compiled-lambda
+                   (compile-lambda
+                     `(lambda (slot-name) (function ,method-lambda)))))
+             (declare (type compiled-function compiled-lambda))
+             (setf (symbol-function writer-function-maker-name)
+                   compiled-lambda) 
+             (let ((func (eval `(function ,writer-function-maker-name))))
+               (push (cons method-lambda func)
+                     *documented-writer-method-function-makers*)
+               func)))
+       slot-name)))
+
+(defmethod make-documented-boundp-method-function ((class slot-class)
+                                                   generic-function
+                                                   boundp-method-prototype
+                                                   slot-name)
+  ;;   Make the documented boundp-method-function.  To do this correctly for
+  ;; all cases, we must build the boundp method function by passing it
+  ;; through make-method-lambda in case the user does something funky
+  ;; with their method lambdas.
+  ;;   Since there usually won't be many different kinds of method
+  ;; lambdas for boundps, this method actually dynamically builds a function
+  ;; to make the documented-boundp-method-function from each particular
+  ;; method lambda returned and stores it in
+  ;; *documented-boundp-method-functions-makers* to be re-used each time
+  ;; the boundp lambda is the same.
+  (multiple-value-bind (method-lambda initargs)
+    (call-make-method-lambda generic-function
+                             boundp-method-prototype
+                             '(lambda (instance)
+                               (funcall #'slot-value instance slot-name))
+                             ())
+    (declare (ignore initargs))
+    (funcall-compiled
+       (or (cdr (assoc method-lambda
+                       *documented-boundp-method-function-makers*
+                       :test #'equal))
+           (let ((boundp-function-maker-name
+                   (gensym "MAKE-DOCUMENTED-READER-METHOD-FUNCTION"))
+                 (compiled-lambda
+                   (compile-lambda
+                     `(lambda (slot-name) (function ,method-lambda)))))
+             (declare (type compiled-function compiled-lambda))
+             (setf (symbol-function boundp-function-maker-name)
+                   compiled-lambda)
+             (let ((func (eval `(function ,boundp-function-maker-name))))
+               (push (cons method-lambda func)
+                     *documented-boundp-method-function-makers*)
+               func)))
+      slot-name)))
+
+(defmethod make-optimized-reader-method-function ((class slot-class)
+                                                  generic-function
+                                                  reader-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function reader-method-prototype))
+  (make-std-reader-method-function slot-name))
+
+(defmethod make-optimized-writer-method-function ((class slot-class)
+                                                  generic-function
+                                                  writer-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function writer-method-prototype))
   (make-std-writer-method-function slot-name))
 
-(defmethod make-boundp-method-function ((class slot-class) slot-name)
+(defmethod make-optimized-boundp-method-function ((class slot-class)
+                                                  generic-function
+                                                  boundp-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function boundp-method-prototype))
   (make-std-boundp-method-function slot-name))
 
-(defun make-std-reader-method-function (slot-name)
-  #'(lambda (instance) (slot-value instance slot-name)))
+(defmethod make-optimized-reader-method-function ((class standard-class)
+                                                  generic-function
+                                                  reader-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function reader-method-prototype))
+  (make-standard-instance-reader-method-function slot-name))
+
+(defmethod make-optimized-writer-method-function ((class standard-class)
+                                                  generic-function
+                                                  writer-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function writer-method-prototype))
+  (make-standard-instance-writer-method-function slot-name))
+
+(defmethod make-optimized-boundp-method-function ((class standard-class)
+                                                  generic-function
+                                                  boundp-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function boundp-method-prototype))
+  (make-standard-instance-boundp-method-function slot-name))
+
+
+(defun make-standard-instance-reader-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (standard-instance-slot-value instance slot-name)))
+
+(defun make-standard-instance-writer-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (nv instance)
+      (setf (standard-instance-slot-value instance slot-name) nv)))
+
+(defun make-standard-instance-boundp-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (standard-instance-slot-boundp instance slot-name)))
 
-(defun make-std-writer-method-function (slot-name)
-  #'(lambda (nv instance) (setf (slot-value instance slot-name) nv)))
 
-(defun make-std-boundp-method-function (slot-name)
-  #'(lambda (instance) (slot-boundp instance slot-name)))
 
 (defvar *internal-reader-gf-table* (make-hash-table :test 'eql))
 (defvar *internal-writer-gf-table* (make-hash-table :test 'eql))
@@ -1029,24 +1336,27 @@
   (or (gethash slot-name *internal-boundp-gf-table*)
       (error "No class has a slot named ~s" slot-name)))
 
-(defun initialize-internal-slot-gfs (slot-name)
+(defun initialize-internal-slot-reader-gfs (slot-name)
   (unless (gethash slot-name *internal-reader-gf-table*)
     (let* ((name (slot-reader-symbol slot-name))
 	   (gf (setf (gethash slot-name *internal-reader-gf-table*)
 		     (ensure-generic-function name))))
-      (add-reader-method *the-class-slot-object* gf slot-name)))
+      (add-reader-method *the-class-slot-object* gf slot-name))))
+
+(defun initialize-internal-slot-writer-gfs (slot-name)
   (unless (gethash slot-name *internal-writer-gf-table*)
     (let* ((name (slot-writer-symbol slot-name))
 	   (gf (setf (gethash slot-name *internal-writer-gf-table*)
 		     (ensure-generic-function name))))
-      (add-writer-method *the-class-slot-object* gf slot-name)))
+      (add-writer-method *the-class-slot-object* gf slot-name))))
+
+(defun initialize-internal-slot-boundp-gfs (slot-name)
   (unless (or (not *optimize-slot-boundp*)
 	      (gethash slot-name *internal-boundp-gf-table*))
     (let* ((name (slot-boundp-symbol slot-name))
 	   (gf (setf (gethash slot-name *internal-boundp-gf-table*)
 		     (ensure-generic-function name))))
-      (add-boundp-method *the-class-slot-object* gf slot-name)))
-  nil)      
+      (add-boundp-method *the-class-slot-object* gf slot-name))))
 
 
 ;;;; inform-type-system-about-class
@@ -1062,6 +1372,7 @@
 (defmethod inform-type-system-about-class ((class std-class) name)
   (inform-type-system-about-std-class name))
 
+
 
 ;;;
 ;;; These 4 definitions appear here for bootstrapping reasons.  Logically,
@@ -1124,7 +1435,11 @@
 	      (wrapper-instance-slots-layout owrapper))
 	(setf (wrapper-class-slots nwrapper)
 	      (wrapper-class-slots owrapper))
-	(without-interrupts
+	(setf (wrapper-allocate-static-slot-storage-copy nwrapper)
+	      (wrapper-allocate-static-slot-storage-copy owrapper))
+	(setf (wrapper-unreserved-field nwrapper)
+	      (wrapper-unreserved-field owrapper))
+	(without-interrupts-simple
 	  (setf (slot-value class 'wrapper) nwrapper)
 	  (invalidate-wrapper owrapper 'flush nwrapper))
 	(update-constructors class)))))		;??? ***
@@ -1147,10 +1462,16 @@
 	    (wrapper-instance-slots-layout owrapper))
       (setf (wrapper-class-slots nwrapper)
 	    (wrapper-class-slots owrapper))
-      (without-interrupts
+      (setf (wrapper-allocate-static-slot-storage-copy nwrapper)
+	    (wrapper-allocate-static-slot-storage-copy owrapper))
+      (setf (wrapper-unreserved-field nwrapper)
+	    (wrapper-unreserved-field owrapper))
+      (without-interrupts-simple
 	(setf (slot-value class 'wrapper) nwrapper)
 	(invalidate-wrapper owrapper 'obsolete nwrapper)
-	class)))
+	class)
+      (dolist (generic-function (class-cached-in-generic-functions class))
+        (update-dfun generic-function))))
 
 (defmethod make-instances-obsolete ((class symbol))
   (make-instances-obsolete (find-class class)))
@@ -1187,6 +1508,10 @@
   ;;  --    --> local        add
   ;;  --    --> shared        --
   ;;
+  (unless (or (std-instance-p instance) (fsc-instance-p instance))
+    (error "Trying to obsolete instance ~S of type ~S, but only know how
+            to obsolete instances of type STD-INSTANCE or FSC-INSTANCE."
+           instance (instance-type instance)))
   (let* ((class (wrapper-class nwrapper))
 	 (guts (allocate-instance class))	;??? allocate-instance ???
 	 (olayout (wrapper-instance-slots-layout owrapper))
@@ -1197,6 +1522,8 @@
 	 (added ())
 	 (discarded ())
 	 (plist ()))
+    (declare (list olayout nlayout oclass-slots added discarded plist)
+             (simple-vector oslots nslots))
     ;;
     ;; Go through all the old local slots.
     ;; 
@@ -1228,7 +1555,7 @@
 		  (assq nlocal oclass-slots))
 	(push nlocal added)))
       
-    (without-interrupts
+    (without-interrupts-simple
       (set-wrapper instance nwrapper)
       (set-slots instance nslots))
 
@@ -1254,6 +1581,8 @@
 	  (old-slots (,slots-fetcher instance))
 	  (new-slots (,slots-fetcher guts))
 	  (old-class-slots (wrapper-class-slots old-wrapper)))
+    (declare (list old-layout new-layout old-class-slots)
+             (simple-vector old-slots new-slots))
 
     ;;
     ;; "The values of local slots specified by both the class Cto and
@@ -1278,7 +1607,7 @@
 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.
-    (without-interrupts
+    (without-interrupts-simple
       (setf (,slots-fetcher copy) old-slots)
       
       (setf (,wrapper-fetcher instance) new-wrapper)
@@ -1328,14 +1657,9 @@
 ;;; 
 (defmethod shared-initialize :before
 	   ((class built-in-class) slot-names &rest initargs)
-  (declare (ignore slot-names))
+  (declare (ignore slot-names initargs))
   (error "Attempt to initialize or reinitialize a built in class."))
 
-(defmethod class-direct-slots            ((class built-in-class)) ())
-(defmethod class-slots                   ((class built-in-class)) ())
-(defmethod class-direct-default-initargs ((class built-in-class)) ())
-(defmethod class-default-initargs        ((class built-in-class)) ())
-
 (defmethod validate-superclass ((c class) (s built-in-class))
   (eq s *the-class-t*))
 
@@ -1346,7 +1670,7 @@
 ;;;
 
 (defmethod validate-superclass ((c slot-class)
-						(f forward-referenced-class))
+				(f forward-referenced-class))
   't)
 
 
@@ -1362,6 +1686,35 @@
 	(delete dependent (plist-value metaobject 'dependents))))
 
 (defmethod map-dependents ((metaobject dependent-update-mixin) function)
+  (declare (type real-function function))
   (dolist (dependent (plist-value metaobject 'dependents))
     (funcall function dependent)))
 
+
+(declaim (ftype (function (T T) boolean) class-on-class-precedence-list-p))
+(defun class-on-class-precedence-list-p (class1 class2)
+  ;; Return whether class1 is on class2's class-precedence-list
+  ;; without finalizing it.
+  (if (class-finalized-p class2)
+      (not (null (memq class1 (fast-slot-value class2 'class-precedence-list))))
+      (let ((direct-superclasses (class-direct-superclasses class2)))
+        (if (memq class1 direct-superclasses)
+            T
+            (dolist (superclass direct-superclasses NIL)
+              (if (class-on-class-precedence-list-p class1 superclass)
+                  (return T)))))))
+
+(declaim (ftype (function (T) boolean) class-standard-p))
+(defun class-standard-p (class)
+  ;; Return whether class is standard without finalizing it.
+  (if (class-finalized-p class)
+      (not (null (memq *the-class-standard-object*
+                       (fast-slot-value class 'class-precedence-list))))
+      (let ((direct-superclasses (class-direct-superclasses class)))
+        (if (memq *the-class-standard-object* direct-superclasses)
+            T
+            (dolist (superclass direct-superclasses NIL)
+              (if (class-standard-p superclass)
+                  (return T)))))))
+
+
diff --git a/pcl/structure-class.lisp b/pcl/structure-class.lisp
new file mode 100644
index 000000000..75f678c44
--- /dev/null
+++ b/pcl/structure-class.lisp
@@ -0,0 +1,340 @@
+;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
+;;;
+;;; *************************************************************************
+;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;; All rights reserved.
+;;;
+;;; Use and copying of this software and preparation of derivative works
+;;; based upon this software are permitted.  Any distribution of this
+;;; software or derivative works must comply with all applicable United
+;;; States export control laws.
+;;; 
+;;; This software is made available AS IS, and Xerox Corporation makes no
+;;; warranty about the software, its performance or its conformity to any
+;;; specification.
+;;; 
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;;   CommonLoops Coordinator
+;;;   Xerox PARC
+;;;   3333 Coyote Hill Rd.
+;;;   Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+(defmethod initialize-internal-slot-functions :after
+          ((slotd structure-effective-slot-definition))
+  (let ((name (slot-definition-name slotd)))
+    (initialize-internal-slot-reader-gfs name)
+    (initialize-internal-slot-writer-gfs name)
+    (initialize-internal-slot-boundp-gfs name)))
+
+(defmethod slot-definition-allocation ((slotd structure-slot-definition))
+  :instance)
+
+(defmethod class-prototype ((class structure-class))
+  (with-slots (prototype) class
+    (or prototype
+        (setq prototype (make-class-prototype class)))))
+
+(defmethod make-class-prototype ((class structure-class))
+  (with-slots (wrapper defstruct-constructor) class
+    (if defstruct-constructor
+        (make-instance class)
+      (let* ((proto (%allocate-instance--class *empty-vector*)))
+         (shared-initialize proto T :check-initargs-legality-p NIL)
+         (setf (std-instance-wrapper proto) wrapper)
+         proto))))
+
+
+(defmethod make-direct-slotd ((class structure-class)
+                              &rest initargs
+                              &key
+                              (name (error "Slot needs a name."))
+                              (conc-name (class-defstruct-conc-name class))
+                              (defstruct-accessor-symbol () acc-sym-p)
+                              &allow-other-keys)
+  (declare (ignore defstruct-accessor-symbol))
+  (declare (type symbol        name)
+           (type simple-string conc-name))
+  (let ((initargs (list* :class class :allow-other-keys T initargs)))
+    (unless acc-sym-p
+      (setf initargs
+            (list* :defstruct-accessor-symbol
+                   (intern (concatenate 'simple-string conc-name (symbol-name name))
+                           (symbol-package (class-name class)))
+                   initargs)))
+    (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
+
+(defun slot-definition-defstruct-slot-description (slot)
+  (let ((type (slot-definition-type slot)))
+    `(,(slot-definition-name slot) ,(slot-definition-initform slot)
+      ,@(unless (eq type t) `(:type ,type)))))
+
+(defmethod shared-initialize :after 
+      ((class structure-class)
+       slot-names
+       &key (direct-superclasses nil direct-superclasses-p)
+            (direct-slots nil direct-slots-p)
+            direct-default-initargs
+            (predicate-name   nil predicate-name-p))
+  (declare (ignore slot-names direct-default-initargs))
+  (let* ((name (class-name class))
+         (from-defclass-p (slot-value class 'from-defclass-p))
+         (defstruct-form (defstruct-form name))
+         (conc-name
+           (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
+               (slot-value class 'defstruct-conc-name)
+               (format nil #-excl "~s structure class "
+                           #+excl "~s_STRUCTURE.CLASS_"
+                           name)))
+         (defstruct-predicate
+           (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
+         (pred-name  ;; Predicate name for class
+           (or (if predicate-name-p (car predicate-name))
+               (if defstruct-form defstruct-predicate)
+               (slot-value class 'predicate-name)
+               (make-class-predicate-name name)))
+         (constructor
+           (or (if defstruct-form (defstruct-form-constructor defstruct-form))
+               (slot-value class 'defstruct-constructor)
+               (if from-defclass-p
+                   (list (intern (format nil "~aconstructor" conc-name)
+                                 (symbol-package name))
+                         ())))))
+    (declare (type symbol        name defstruct-predicate pred-name)
+             (type boolean       from-defclass-p)
+             (type simple-string conc-name))
+    (if direct-superclasses-p
+        (setf (slot-value class 'direct-superclasses)
+	      (or direct-superclasses
+		  (setq direct-superclasses
+                        (if (eq name 'structure-object)
+                            nil
+			    (list *the-class-structure-object*)))))
+        (setq direct-superclasses (slot-value class 'direct-superclasses)))
+    (setq direct-slots
+          (if direct-slots-p
+	      (setf (slot-value class 'direct-slots)
+		    (mapcar #'(lambda (pl)
+                                (apply #'make-direct-slotd class
+                                        :conc-name conc-name pl))
+			    direct-slots))
+	      (slot-value class 'direct-slots)))
+    (when from-defclass-p
+      (do-defstruct-from-defclass
+        class direct-superclasses direct-slots conc-name pred-name constructor))
+    (compile-structure-class-internals
+        class direct-slots conc-name pred-name constructor)
+    (setf (slot-value class 'predicate-name) pred-name)
+    (setf (slot-value class 'defstruct-conc-name) conc-name)
+    (unless (extract-required-parameters (second constructor))
+      (setf (slot-value class 'defstruct-constructor) (car constructor)))
+    (when (and defstruct-predicate (not from-defclass-p))
+      (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
+    (unless (or from-defclass-p (slot-value class 'documentation))
+      (setf (slot-value class 'documentation)
+            (format nil "~S structure class made from Defstruct" name)))
+    (setf (find-class name) class)
+    (update-structure-class class direct-superclasses direct-slots)))
+
+(defun update-structure-class (class direct-superclasses direct-slots)
+  (add-direct-subclasses class direct-superclasses)
+  (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class))
+  (let* ((eslotds (compute-slots class))
+         (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
+    (setf (slot-value class 'slots) eslotds)
+    (setf (slot-value class 'internal-slotds) internal-slotds)
+    (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
+  (unless (slot-value class 'wrapper)
+    (setf (slot-value class 'finalized-p) T)
+    (setf (slot-value class 'wrapper) (make-wrapper class)))
+  (unless (slot-boundp class 'prototype)
+    (setf (slot-value class 'prototype) nil))
+  (setf (slot-value class 'default-initargs) nil)
+  (add-slot-accessors class direct-slots))
+
+(defmethod do-defstruct-from-defclass ((class structure-class)
+                                       direct-superclasses direct-slots
+                                       conc-name predicate constructor)
+  (declare (type simple-string conc-name))
+  (let* ((name (class-name class))
+         (original-defstruct-form
+          `(original-defstruct
+              (,name
+		 ,@(when direct-superclasses
+		   `((:include ,(class-name (car direct-superclasses)))))
+		 (:print-function print-std-instance)
+		 (:predicate ,predicate)
+		 (:conc-name ,(intern conc-name (symbol-package name)))
+		 (:constructor ,@constructor))
+            ,@(mapcar #'slot-definition-defstruct-slot-description
+                      direct-slots))))
+    (eval original-defstruct-form)
+    (store-defstruct-form (cdr original-defstruct-form))))
+
+(defmethod compile-structure-class-internals ((class structure-class)
+                                              direct-slots conc-name
+                                              predicate-name constructor)
+  (declare (type simple-string conc-name))
+  (let* ((name    (class-name class))
+         (package (symbol-package name))
+         (direct-slots-needing-internals
+           (if (slot-value class 'from-defclass-p)
+               direct-slots
+               (remove-if #'slot-definition-internal-reader-function
+                          direct-slots)))
+	 (reader-names
+           (mapcar #'(lambda (slotd)
+		       (intern (format nil "~A~A reader" conc-name
+				       (slot-definition-name slotd))
+                                package))
+		   direct-slots-needing-internals))
+	 (writer-names
+           (mapcar #'(lambda (slotd)
+		       (intern (format nil "~A~A writer" conc-name 
+				       (slot-definition-name slotd))
+                               package))
+		   direct-slots-needing-internals))
+         (defstruct-accessor-names
+           (mapcar #'slot-definition-defstruct-accessor-symbol
+                   direct-slots-needing-internals))
+	 (readers-init
+	   (mapcar #'(lambda (defstruct-accessor reader-name)
+		       `(progn
+                          (force-compile ',defstruct-accessor)
+                          (defun ,reader-name (obj)
+		            (declare (type ,name obj) #.*optimize-speed*)
+			    (,defstruct-accessor obj))
+                          (force-compile ',reader-name)))
+		   defstruct-accessor-names reader-names))
+	 (writers-init
+	   (mapcar #'(lambda (defstruct-accessor writer-name)
+		       `(progn
+                          (force-compile ',defstruct-accessor)
+                          (defun ,writer-name (nv obj)
+			    (declare (type ,name obj) #.*optimize-speed*)
+			    (setf (,defstruct-accessor obj) nv))
+                          (force-compile ',writer-name)))
+		   defstruct-accessor-names writer-names))
+	 (defstruct-extras-form
+	   `(progn
+              ,@(when (car constructor)
+                  `((force-compile ',(car constructor))))
+              ,@(when (fboundp predicate-name)
+                  `((force-compile ',predicate-name)))
+	      ,@readers-init
+              ,@writers-init)))
+    (declare (type package package))
+    (eval defstruct-extras-form)
+    (mapc #'(lambda (dslotd reader-name writer-name)
+	      (setf (slot-value dslotd 'internal-reader-function)
+                    (gdefinition reader-name))
+	      (setf (slot-value dslotd 'internal-writer-function)
+                    (gdefinition writer-name)))
+	  direct-slots-needing-internals reader-names writer-names)))
+
+(defmethod reinitialize-instance :after ((class structure-class)
+					 &rest initargs
+					 &key)
+  (map-dependents class
+		  #'(lambda (dependent)
+		      (apply #'update-dependent class dependent initargs))))
+
+(defmethod direct-slot-definition-class ((class structure-class) initargs)
+  (declare (ignore initargs))
+  (find-class 'structure-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class structure-class) initargs)
+  (declare (ignore initargs))
+  (find-class 'structure-effective-slot-definition))
+
+(defmethod finalize-inheritance ((class structure-class))
+  nil) ; always finalized
+
+
+(defmethod compute-slots ((class structure-class))
+  (mapcan #'(lambda (superclass)
+	      (mapcar #'(lambda (dslotd)
+			  (compute-effective-slot-definition
+			     class (slot-definition-name dslotd) (list dslotd)))
+		      (class-direct-slots superclass)))
+	  (reverse (slot-value class 'class-precedence-list))))
+
+(defmethod compute-slots :around ((class structure-class))
+  (let ((eslotds (call-next-method)))
+    (mapc #'initialize-internal-slot-functions eslotds)
+    eslotds))
+
+(defmethod compute-effective-slot-definition ((class structure-class)
+                                              name dslotds)
+  (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+	 (class (effective-slot-definition-class class initargs))
+         (slot-definition (apply #'make-instance class initargs))
+         (internal-slotd
+           (make-internal-slotd
+             :name name
+             :slot-definition slot-definition
+             :initargs        (slot-definition-initargs     slot-definition)
+             :initfunction    (slot-definition-initfunction slot-definition))))
+    (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
+    slot-definition))
+
+(defmethod compute-effective-slot-definition-initargs :around
+    ((class structure-class) direct-slotds)
+  (let ((slotd (car direct-slotds)))
+    (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
+	   :internal-reader-function (slot-definition-internal-reader-function slotd)
+	   :internal-writer-function (slot-definition-internal-writer-function slotd)
+	   (call-next-method))))
+
+
+(defmethod make-optimized-reader-method-function ((class structure-class)
+                                                  generic-function
+                                                  reader-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function reader-method-prototype))
+  (make-structure-instance-reader-method-function slot-name))
+
+(defmethod make-optimized-writer-method-function ((class structure-class)
+                                                  generic-function
+                                                  writer-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function writer-method-prototype))
+  (make-structure-instance-writer-method-function slot-name))
+
+(defmethod make-optimized-boundp-method-function ((class structure-class)
+                                                  generic-function
+                                                  boundp-method-prototype
+                                                  slot-name)
+  (declare (ignore generic-function boundp-method-prototype))
+  (make-structure-instance-boundp-method-function slot-name))
+
+
+(defun make-structure-instance-reader-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (structure-instance-slot-value instance slot-name)))
+
+(defun make-structure-instance-writer-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (nv instance)
+      (setf (structure-instance-slot-value instance slot-name) nv)))
+
+(defun make-structure-instance-boundp-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (structure-instance-slot-boundp instance slot-name)))
+
+(defmethod wrapper-fetcher ((class structure-class))
+  'wrapper-for-structure)
+
+(defmethod slots-fetcher ((class structure-class))
+  NIL)
+
+
diff --git a/pcl/sys-package.lisp b/pcl/sys-package.lisp
index 60bfbd70f..88249cf04 100644
--- a/pcl/sys-package.lisp
+++ b/pcl/sys-package.lisp
@@ -13,9 +13,6 @@
 ;;; Definitions for package WALKER of type ESTABLISH
 (LISP::IN-PACKAGE "WALKER" :USE LISP::NIL)
 
-;;; Definitions for package DSYS of type ESTABLISH
-(LISP::IN-PACKAGE "DSYS" :USE LISP::NIL)
-
 ;;; Definitions for package SLOT-ACCESSOR-NAME of type EXPORT
 (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME" :USE 'LISP::NIL :NICKNAMES
     '("S-A-N"))
@@ -26,26 +23,77 @@
 (LISP::IN-PACKAGE "PCL" :USE '("LISP" "ITERATE" "WALKER"))
 (LISP::IMPORT 'LISP::NIL)
 (LISP::EXPORT
-    '(PCL::CLASS-OF PCL::NO-APPLICABLE-METHOD
-         PCL::ENSURE-GENERIC-FUNCTION PCL::SLOT-MISSING
-         PCL::CALL-NEXT-METHOD PCL::MAKE-INSTANCES-OBSOLETE
-         PCL::METHOD-QUALIFIERS PCL::STANDARD-CLASS PCL::PRINT-OBJECT
-         PCL::STRUCTURE-CLASS PCL::MAKE-INSTANCE PCL::DEFGENERIC
-         PCL::REINITIALIZE-INSTANCE PCL::STANDARD-METHOD
-         PCL::FUNCTION-KEYWORDS PCL::STANDARD PCL::FIND-METHOD
+    '(PCL::CLASS-PRECEDENCE-LIST PCL::SLOT-DEFINITION
+         PCL::COMPUTE-APPLICABLE-METHODS-USING-CLASSES
+         PCL::SLOT-DEFINITION-WRITERS PCL::CLASS-OF
+         PCL::NO-APPLICABLE-METHOD PCL::STANDARD-WRITER-METHOD
+         PCL::ENSURE-CLASS-USING-CLASS PCL::ENSURE-GENERIC-FUNCTION
+         PCL::FIND-METHOD-COMBINATION PCL::MAP-DEPENDENTS
+         PCL::SLOT-MISSING PCL::SPECIALIZER PCL::CALL-NEXT-METHOD
+         PCL::ENSURE-GENERIC-FUNCTION-USING-CLASS
+         PCL::SLOT-MAKUNBOUND-USING-CLASS PCL::MAKE-INSTANCES-OBSOLETE
+         PCL::INTERN-EQL-SPECIALIZER PCL::REMOVE-DIRECT-SUBCLASS
+         PCL::METHOD-GENERIC-FUNCTION PCL::METHOD-QUALIFIERS
+         PCL::FUNCALLABLE-STANDARD-CLASS PCL::EXTRACT-LAMBDA-LIST
+         PCL::STANDARD-CLASS PCL::PRINT-OBJECT PCL::STRUCTURE-CLASS
+         PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION
+         PCL::GENERIC-FUNCTION-DECLARATIONS PCL::MAKE-INSTANCE
+         PCL::METHOD-LAMBDA-LIST PCL::DEFGENERIC
+         PCL::REMOVE-DIRECT-METHOD PCL::STANDARD-DIRECT-SLOT-DEFINITION
+         PCL::GENERIC-FUNCTION-METHODS PCL::VALIDATE-SUPERCLASS
+         PCL::REINITIALIZE-INSTANCE PCL::SLOT-EXISTS-P-USING-CLASS
+         PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD
+         PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS
+         PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES
          PCL::INITIALIZE-INSTANCE PCL::GENERIC-FLET PCL::SLOT-UNBOUND
-         PCL::SYMBOL-MACROLET PCL::ADD-METHOD PCL::WITH-ACCESSORS
-         PCL::SLOT-BOUNDP PCL::SHARED-INITIALIZE
-         PCL::STANDARD-GENERIC-FUNCTION PCL::WITH-ADDED-METHODS
-         PCL::NEXT-METHOD-P PCL::SLOT-VALUE PCL::STANDARD-OBJECT
-         PCL::BUILT-IN-CLASS PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND
+         PCL::STANDARD-INSTANCE PCL::SLOT-DEFINITION-TYPE
+         PCL::COMPUTE-EFFECTIVE-METHOD PCL::ALLOCATE-INSTANCE
+         PCL::SYMBOL-MACROLET PCL::GENERIC-FUNCTION
+         PCL::GENERIC-FUNCTION-METHOD-COMBINATION
+         PCL::SPECIALIZER-DIRECT-METHODS PCL::ADD-DIRECT-SUBCLASS
+         PCL::WRITER-METHOD-CLASS PCL::SLOT-DEFINITION-INITARGS
+         PCL::METHOD-SPECIALIZERS PCL::GENERIC-FUNCTION-METHOD-CLASS
+         PCL::ADD-METHOD PCL::WITH-ACCESSORS
+         PCL::SLOT-DEFINITION-ALLOCATION
+         PCL::SLOT-DEFINITION-INITFUNCTION
+         PCL::SLOT-DEFINITION-LOCATION PCL::ADD-DIRECT-METHOD
+         PCL::SLOT-BOUNDP PCL::EQL-SPECIALIZER PCL::SHARED-INITIALIZE
+         PCL::STANDARD-GENERIC-FUNCTION
+         PCL::ACCESSOR-METHOD-SLOT-DEFINITION
+         PCL::SLOT-BOUNDP-USING-CLASS PCL::ADD-DEPENDENT
+         PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTION
+         PCL::WITH-ADDED-METHODS PCL::COMPUTE-CLASS-PRECEDENCE-LIST
+         PCL::REMOVE-DEPENDENT PCL::NEXT-METHOD-P
+         PCL::GENERIC-FUNCTION-NAME PCL::SLOT-VALUE
+         PCL::EFFECTIVE-SLOT-DEFINITION PCL::CLASS-FINALIZED-P
+         PCL::COMPUTE-DISCRIMINATING-FUNCTION PCL::STANDARD-OBJECT
+         PCL::CLASS-DEFAULT-INITARGS PCL::CLASS-DIRECT-SLOTS
+         PCL::FUNCALLABLE-STANDARD-INSTANCE-ACCESS PCL::BUILT-IN-CLASS
+         PCL::NO-NEXT-METHOD PCL::SLOT-MAKUNBOUND
+         PCL::STANDARD-READER-METHOD PCL::GENERIC-FUNCTION-LAMBDA-LIST
+         PCL::GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER
          PCL::INVALID-METHOD-ERROR PCL::METHOD-COMBINATION-ERROR
-         PCL::SLOT-EXISTS-P PCL::WITH-SLOTS
-         PCL::DEFINE-METHOD-COMBINATION PCL::CHANGE-CLASS
-         PCL::DEFMETHOD PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
-         PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS PCL::REMOVE-METHOD
-         PCL::CALL-METHOD PCL::CLASS-NAME PCL::FIND-CLASS PCL::DEFCLASS
-         PCL::COMPUTE-APPLICABLE-METHODS PCL::GENERIC-LABELS))
+         PCL::SLOT-EXISTS-P PCL::FINALIZE-INHERITANCE
+         PCL::SLOT-DEFINITION-NAME
+         PCL::STANDARD-EFFECTIVE-SLOT-DEFINITION PCL::COMPUTE-SLOTS
+         PCL::CLASS-SLOTS PCL::EFFECTIVE-SLOT-DEFINITION-CLASS
+         PCL::STANDARD-INSTANCE-ACCESS PCL::WITH-SLOTS
+         PCL::DIRECT-SLOT-DEFINITION PCL::DEFINE-METHOD-COMBINATION
+         PCL::MAKE-METHOD-LAMBDA PCL::ENSURE-CLASS
+         PCL::DIRECT-SLOT-DEFINITION-CLASS PCL::METHOD-FUNCTION
+         PCL::STANDARD-SLOT-DEFINITION PCL::CHANGE-CLASS PCL::DEFMETHOD
+         PCL::UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
+         PCL::UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+         PCL::FORWARD-REFERENCED-CLASS PCL::SLOT-DEFINITION-INITFORM
+         PCL::REMOVE-METHOD PCL::READER-METHOD-CLASS PCL::CALL-METHOD
+         PCL::CLASS-PROTOTYPE PCL::CLASS-NAME PCL::FIND-CLASS
+         PCL::DEFCLASS PCL::COMPUTE-APPLICABLE-METHODS
+         PCL::DESCRIBE-OBJECT PCL::SLOT-VALUE-USING-CLASS
+         PCL::METHOD-COMBINATION PCL::EQL-SPECIALIZER-INSTANCE
+         PCL::GENERIC-LABELS PCL::METHOD PCL::SLOT-DEFINITION-READERS
+         PCL::CLASS-DIRECT-DEFAULT-INITARGS
+         PCL::CLASS-DIRECT-SUBCLASSES PCL::CLASS-DIRECT-SUPERCLASSES
+         PCL::SET-FUNCALLABLE-INSTANCE-FUNCTION))
 
 ;;; Definitions for package ITERATE of type EXPORT
 (LISP::IN-PACKAGE "ITERATE" :USE '("WALKER" "LISP"))
@@ -65,34 +113,9 @@
 (LISP::EXPORT
     '(WALKER::DEFINE-WALKER-TEMPLATE WALKER::*VARIABLE-DECLARATIONS*
          WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION
-         WALKER::VARIABLE-LEXICAL-P WALKER::VARIABLE-SPECIAL-P
-         WALKER::WALK-FORM WALKER::VARIABLE-GLOBALLY-SPECIAL-P))
-
-;;; Definitions for package DSYS of type EXPORT
-(LISP::IN-PACKAGE "DSYS" :USE '("LISP"))
-(LISP::IMPORT '(USER::*INITIALIZE-SYSTEMS-P* USER::INITIALIZE-SYSTEMS))
-(LISP::EXPORT
-    '(DSYS::SOURCE-FILE DSYS::DIRECTORYP DSYS::SET-SYSTEM-SOURCE-FILE
-         DSYS::*DEFAULT-FASL-PATHNAME-TYPE* DSYS::LOAD-TRUENAME
-         DSYS::READ-DISTRIBUTION DSYS::SUBFILE DSYS::LOAD-FILE
-         DSYS::DIRECTORY-PATHNAME-AS-FILE DSYS::*SYSTEMS-BANNER*
-         DSYS::FIND-SYSTEM DSYS::COMPILE-SYSTEM-FILE
-         DSYS::LOAD-FILE-FILE DSYS::LOAD-SYSTEM DSYS::MAP-SYSTEM-ALL
-         DSYS::*SKIP-LOAD-IF-LOADED-P* DSYS::OBJECT-FILE
-         DSYS::ADD-SYSTEM-LOCATION-DIRECTORY
-         DSYS::COMPILE-FILE-PATHNAME
-         DSYS::*DSYS-SHADOWING-IMPORT-SYMBOLS*
-         DSYS::*DEFAULT-LISP-PATHNAME-TYPE*
-         DSYS::*DEFAULT-DIRECTORY-STRING* DSYS::DEFSYSTEM
-         DSYS::CREATE-DIRECTORY DSYS::TYPE-FOR-DIRECTORY
-         DSYS::*SYSTEM-LOCATION-DIRECTORY-LIST* DSYS::LOAD-SYSTEM-ALL
-         DSYS::MAP-SYSTEM DSYS::GENERIC-PATHNAME
-         DSYS::*SUBFILE-DEFAULT-ROOT-PATHNAME* DSYS::ENSURE-DIRECTORY
-         USER::*INITIALIZE-SYSTEMS-P* DSYS::WRITE-DISTRIBUTION
-         DSYS::*SKIP-COMPILE-FILE-FWD* DSYS::DEFAULT-PATHNAME-DEFAULTS
-         DSYS::COMPILE-SYSTEM DSYS::COMPILE-SYSTEM-ALL
-         DSYS::LOAD-SYSTEM-FILE DSYS::PATHNAME-AS-DIRECTORY
-         USER::INITIALIZE-SYSTEMS))
+         WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P
+         WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM
+         WALKER::VARIABLE-GLOBALLY-SPECIAL-P))
 
 ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW
 (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME")
@@ -118,20 +141,6 @@
 (LISP::SHADOWING-IMPORT 'LISP::NIL)
 (LISP::IMPORT 'LISP::NIL)
 
-;;; Definitions for package DSYS of type SHADOW
-(LISP::IN-PACKAGE "DSYS")
-(LISP::SHADOW
-    '(DSYS::MERGE-PATHNAMES DSYS::MAKE-PATHNAME DSYS::PATHNAME-HOST
-         DSYS::PATHNAME-DEVICE DSYS::PATHNAME-DIRECTORY
-         DSYS::PATHNAME-NAME DSYS::PATHNAME-TYPE
-         DSYS::PATHNAME-VERSION))
-(LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT
-    '(USER::*INITIALIZE-SYSTEMS-P* USER::INITIALIZE-SYSTEMS
-         PCL::*PATHNAME-EXTENSIONS*
-         USER::*CHOOSE-SOURCE-OR-OBJECT-FILE-ACTION*
-         PCL::*DEFAULT-PATHNAME-EXTENSIONS*))
-
 (in-package 'SI)
 (export '(%structure-name
           %compiled-function-name
diff --git a/pcl/sys-proclaim.lisp b/pcl/sys-proclaim.lisp
index 04da0ed4d..3e8bef09d 100644
--- a/pcl/sys-proclaim.lisp
+++ b/pcl/sys-proclaim.lisp
@@ -1,664 +1,758 @@
 
 (IN-PACKAGE "PCL") 
-(PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) ZERO)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (FIXNUM T FIXNUM) FIXNUM)
             COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) CACHE) ISL-CACHE)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T) FIXNUM) ARG-INFO-NUMBER-REQUIRED
-            DEFAULT-LIMIT-FN CACHE-COUNT CACHING-LIMIT-FN
-            ONE-INDEX-LIMIT-FN N-N-ACCESSORS-LIMIT-FN CHECKING-LIMIT-FN
-            CACHE-NLINES CACHE-MAX-LOCATION CACHE-MASK
-            PV-CACHE-LIMIT-FN CACHE-SIZE EARLY-CLASS-SIZE)) 
+            COUNT-NON-NILS CHECKING-LIMIT-FN CACHE-COUNT
+            N-N-ACCESSORS-LIMIT-FN ARG-INFO-NKEYS CACHING-LIMIT-FN
+            WRAPPER-FIELD ONE-INDEX-LIMIT-FN CPD-COUNT)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (FIXNUM) T) NEXT-WRAPPER-FIELD DFUN-ARG-SYMBOL
+            SLOT-VECTOR-SYMBOL ALLOCATE-CACHE-VECTOR)) 
 (PROCLAIM '(FTYPE (FUNCTION (T) FIELD-TYPE) CACHE-FIELD)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) FUNCTION) CACHE-LIMIT-FN)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) POWER-OF-TWO-CEILING)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) LIST) CACHE-OVERFLOW ISL-SLOT-NAME-LISTS)) 
-(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) CACHE-VALUEP)) 
+    '(FTYPE (FUNCTION (T) LIST) INTERNAL-SLOTD-INITARGS CACHE-OVERFLOW)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) REAL-FUNCTION) CACHE-LIMIT-FN)) 
 (PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) CACHE-VECTOR)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) SYMBOL) INTERNAL-SLOTD-NAME)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T) (VALUES T T)) MAKE-CLASS-PREDICATE-NAME
+            MAKE-KEYWORD LAP-REG GET-METHOD-FROM-IDENTIFIER
+            METHOD-FUNCTION-PLIST DEFSTRUCT-FORM)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) (VALUES T T)) METHOD-FUNCTION-PLIST
-            MAKE-CLASS-PREDICATE-NAME LAP-REG MAKE-KEYWORD)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) %CCLOSURE-ENV-NTHCDR)) 
+    '(FTYPE (FUNCTION (FIXNUM T) T) MAKE-CAXR MAKE-CDXR
+            %CCLOSURE-ENV-NTHCDR)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (FIXNUM FIXNUM T) FIXNUM)
             COMPUTE-PRIMARY-CACHE-LOCATION)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (FIXNUM) FIXNUM) COMPUTE-LINE-SIZE
+            POWER-OF-TWO-CEILING DEFAULT-LIMIT-FN)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T) INDEX) CACHE-NLINES CACHE-MASK
+            CACHE-MAX-LOCATION CACHE-SIZE)) 
 (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) CACHE-LINE-SIZE)) 
 (PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) CACHE-NKEYS)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T) *)
-            BOOTSTRAP-INITIALIZE-BUILT-IN-CLASS)) 
+    '(FTYPE (FUNCTION (T) (OR INDEX NULL)) ARG-INFO-NUMBER-OPTIONAL)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T) *) SET-SLOT-VALUE EMIT-READER/WRITER
-            ACCESSOR-VALUES CONVERT-METHODS WALKER::WALK-LET-IF
-            SLOT-VALUE-USING-CLASS-DFUN SLOT-BOUNDP-USING-CLASS-DFUN
-            NET-CODE-CONVERTER WALKER::WALK-FORM-INTERNAL
-            ITERATE::EXPAND-INTO-LET CACHE-MISS-VALUES
-            ITERATE::RENAME-VARIABLES ITERATE::WALK-GATHERING-BODY
-            MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
+    '(FTYPE (FUNCTION (T) (OR FUNCTION NULL))
+            INTERNAL-SLOTD-INITFUNCTION)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T *) *) GET-EFFECTIVE-METHOD-FUNCTION
+            SLOT-VALUE-OR-DEFAULT COMPUTE-SECONDARY-DISPATCH-FUNCTION
+            MAKE-DOCUMENTED-STANDARD-METHOD-LAMBDA MAKE-ACCESSOR-TABLE
+            LOAD-DEFGENERIC MAKE-EFFECTIVE-METHOD-FUNCTION
+            MAKE-CHECKING-DFUN MAKE-N-N-ACCESSOR-DFUN
+            TYPES-FROM-ARGUMENTS NESTED-WALK-FORM)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T) *) ITERATE::EXPAND-INTO-LET
+            CONSTANT-VALUE-MISS MAKE-FINAL-N-N-ACCESSOR-DFUN
+            MAKE-FINAL-CACHING-DFUN LOAD-LONG-DEFCOMBIN
+            ITERATE::RENAME-VARIABLES
+            GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION
+            GET-OPTIMIZED-STD-READER-METHOD-FUNCTION
             MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
+            GET-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
+            GET-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION SET-SLOT-VALUE
+            MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
             MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION
-            GET-CLASS-SLOT-VALUE-1 SET-CONSTRUCTOR-CODE
-            OPTIMIZE-SLOT-VALUE-BY-CLASS-P
-            GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION
-            GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            MAKE-FINAL-N-N-ACCESSOR-DFUN MAKE-FINAL-CACHING-DFUN
-            MAKE-FINAL-CONSTANT-VALUE-DFUN CONSTANT-VALUE-MISS
-            LOAD-LONG-DEFCOMBIN CACHING-MISS CHECKING-MISS)) 
+            SLOT-VALUE-USING-CLASS-DFUN CONVERT-METHODS
+            WALKER::WALK-FORM-INTERNAL
+            GENERATE-DISCRIMINATION-NET-INTERNAL-DO-COLUMN
+            NET-CODE-CONVERTER CACHE-MISS-VALUES
+            ITERATE::WALK-GATHERING-BODY SLOT-BOUNDP-USING-CLASS-DFUN
+            CHECKING-MISS ACCESSOR-VALUES WALKER::WALK-LET-IF
+            MAKE-FINAL-CONSTANT-VALUE-DFUN CACHING-MISS)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T T T T T) *)
-            BOOTSTRAP-INITIALIZE-STANDARD-CLASS)) 
+    '(FTYPE (FUNCTION (T T T T T T T) *)
+            ITERATE::ITERATE-TRANSFORM-BODY EXPAND-DEFMETHOD-INTERNAL
+            MAKE-LAP-CLOSURE-GENERATOR)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T) *)
-            GENERATE-DISCRIMINATION-NET-INTERNAL
-            MAKE-LONG-METHOD-COMBINATION-FUNCTION
-            DO-SHORT-METHOD-COMBINATION GENERAL-GENERATOR-INTERNAL
-            REAL-LOAD-DEFCLASS)) 
-(PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) *) REAL-MAKE-A-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T) *) ACCESSOR-MISS
-            GENERATE-DISCRIMINATION-NET
-            SETF-SLOT-VALUE-USING-CLASS-DFUN ORDER-SPECIALIZERS
-            FINALIZE-LAP-GENERATION MAKE-ONE-CLASS-ACCESSOR-DFUN
-            MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN SET-CLASS-SLOT-VALUE-1
-            MAKE-CONSTRUCTOR GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION
-            GET-ACCESSOR-METHOD-FUNCTION NO-METHODS-GENERATOR-INTERNAL
-            MAKE-FINAL-CHECKING-DFUN SIMPLE-SLOTS-GENERATOR-INTERNAL
-            LOAD-SHORT-DEFCOMBIN)) 
+    '(FTYPE (FUNCTION (T T T T) *) SIMPLE-SLOTS-GENERATOR-INTERNAL
+            ORDER-SPECIALIZERS MAKE-ONE-CLASS-ACCESSOR-DFUN
+            GET-ACCESSOR-METHOD-FUNCTION LOAD-SHORT-DEFCOMBIN
+            GENERATE-DISCRIMINATION-NET MAKE-FINAL-CHECKING-DFUN
+            FINALIZE-LAP-GENERATION EARLY-MAKE-METHOD-LAMBDA
+            MAKE-METHOD-LAMBDA-AND-OPTIMIZED-LAMBDA
+            NO-METHODS-GENERATOR-INTERNAL
+            SETF-SLOT-VALUE-USING-CLASS-DFUN
+            MAKE-OPTIMIZED-STANDARD-METHOD-LAMBDA
+            MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN ACCESSOR-MISS
+            MAKE-ACCESSOR-FROM-SVUC-METHOD-FUNCTION)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T T T T T) *)
             COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL
-            MAKE-TWO-CLASS-ACCESSOR-DFUN EXPAND-DEFMETHOD-INTERNAL)) 
+            MAKE-TWO-CLASS-ACCESSOR-DFUN
+            GENERATE-DISCRIMINATION-NET-INTERNAL-DO-METHODS)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T *) *) TYPES-FROM-ARGUMENTS
-            GET-EFFECTIVE-METHOD-FUNCTION MAKE-ACCESSOR-TABLE
-            MAKE-CHECKING-DFUN LOAD-DEFGENERIC MAKE-N-N-ACCESSOR-DFUN
-            COMPUTE-SECONDARY-DISPATCH-FUNCTION
-            MAKE-EFFECTIVE-METHOD-FUNCTION SLOT-VALUE-OR-DEFAULT
-            NESTED-WALK-FORM)) 
+    '(FTYPE (FUNCTION (T T T *) *) WALKER::WALK-DECLARATIONS
+            GET-SECONDARY-DISPATCH-FUNCTION
+            MAKE-ONE-INDEX-ACCESSOR-DFUN)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) *) MAKE-LAP-CLOSURE-GENERATOR
-            ITERATE::ITERATE-TRANSFORM-BODY)) 
+    '(FTYPE (FUNCTION (T T T T *) *) ITERATE::RENAME-LET-BINDINGS
+            NO-SLOT-ACCESSOR)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) *) GET-SECONDARY-DISPATCH-FUNCTION
-            MAKE-ONE-INDEX-ACCESSOR-DFUN WALKER::WALK-DECLARATIONS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) *) ITERATE::RENAME-LET-BINDINGS)) 
+    '(FTYPE (FUNCTION (T T T T T T) *)
+            GENERATE-DISCRIMINATION-NET-INTERNAL
+            MAKE-LONG-METHOD-COMBINATION-FUNCTION
+            GENERAL-GENERATOR-INTERNAL)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T T T T T T T T) *)
             BOOTSTRAP-INITIALIZE-STRUCTURE-CLASS)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T T T T T T) *)
+            BOOTSTRAP-INITIALIZE-BUILT-IN-CLASS)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T) BOOLEAN) CACHE-VALUEP
+            GF-PRECOMPUTE-DFUN-AND-EMF-P GF-INFO-C-A-M-EMF-STD-P
+            ARG-INFO-KEY/REST-P)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T) COMPILED-FUNCTION)
+            INTERNAL-SLOTD-READER-FUNCTION
+            INTERNAL-SLOTD-WRITER-FUNCTION
+            INTERNAL-SLOTD-BOUNDP-FUNCTION)) 
 (PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PRINT-DFUN-INFO)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T) T) BOOTSTRAP-ACCESSOR-DEFINITIONS
-            FILL-CACHE-P ADJUST-CACHE EXPAND-CACHE
-            EMIT-CHECK-2-CLASS-WRAPPER EMIT-CHECK-1-WRAPPER-IN-CACHE
-            EMIT-CHECK-CACHE-ENTRY EMIT-CHECK-CACHE-LINE
-            GET-WRAPPERS-FROM-CLASSES LOAD-PRECOMPILED-DFUN-CONSTRUCTOR
-            WALKER::WALK-TEMPLATE TWO-CLASS-DFUN-INFO
-            WALKER::WALK-LET/LET* WALKER::WALK-PROG/PROG*
-            WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2 GET-CACHE
-            EXPAND-DEFCONSTRUCTOR CHECK-INITARGS EXPAND-DEFCLASS
-            EXPAND-SYMBOL-MACROLET-INTERNAL BOOTSTRAP-SET-SLOT)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T *) T) EARLY-ADD-NAMED-METHOD
+    '(FTYPE (FUNCTION (T T *) T) EMIT-GET-CLASS-SLOT
+            EMIT-SET-CLASS-SLOT DEFOPCODE-1 CPL-ERROR
+            WALKER::CONVERT-MACRO-TO-LAMBDA
+            ENSURE-GENERIC-FUNCTION-USING-CLASS PROCLAIM-FUNCTION
+            RECORD-DEFINITION DEFOPERAND-1 PROBE-CACHE
+            REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION
+            REAL-ENSURE-GF-USING-CLASS--NULL MAP-CACHE
+            FIND-CLASS-PREDICATE-FROM-CELL NAMED-OBJECT-PRINT-FUNCTION
+            GET-EFFECTIVE-METHOD-FUNCTION1 PLIST-VALUE)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T T T T *) T) EARLY-MAKE-A-METHOD
+            REAL-MAKE-A-METHOD EARLY-ADD-NAMED-METHOD
             REAL-ADD-NAMED-METHOD)) 
+(PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) FILL-CACHE-FROM-CACHE-P)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T *) T) SET-ARG-INFO EMIT-DLAP
-            EARLY-MAKE-A-METHOD)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) T) COMPUTE-PRECEDENCE ONE-INDEX-DFUN-INFO
-            FLUSH-CACHE-TRAP OBSOLETE-INSTANCE-TRAP |LAP Operand ISET|
-            EMIT-CHECK-1-CLASS-WRAPPER CHECK-OPCODE-ARG
-            CHECK-OPERAND-ARG WALKER::WALK-PROG* EMIT-LOCK-COUNT-TEST
-            |LAP Opcode EQ| |LAP Opcode NEQ| |LAP Opcode FIX=|
-            GET-FUNCTION-GENERATOR GET-NEW-FUNCTION-GENERATOR
-            WRAP-METHOD-GROUP-SPECIFIER-BINDINGS TRACE-METHOD-INTERNAL
-            CONVERT-TABLE FIX-SLOT-ACCESSORS WALKER::WALK-NAMED-LAMBDA
-            MAP-ALL-ORDERS WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL
-            NEW-ARG-INFO-FROM-GENERIC-FUNCTION ONE-CLASS-DFUN-INFO
-            PRINT-CACHE ITERATE::OPTIMIZE-ITERATE-FORM WALKER::RECONS
-            WALKER::RELIST-INTERNAL INVALIDATE-WRAPPER
-            WALKER::WALK-TAGBODY-1 WALKER::WALK-LAMBDA
-            ITERATE::OPTIMIZE-GATHERING-FORM
-            EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
-            ITERATE::SIMPLE-EXPAND-GATHERING-FORM
-            EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
-            ITERATE::RENAME-AND-CAPTURE-VARIABLES
-            WALKER::WALK-COMPILER-LET ITERATE::VARIABLE-SAME-P
-            WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET
-            WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET
-            WALKER::WALK-LET* WALKER::WALK-MACROLET
-            WALKER::WALK-MULTIPLE-VALUE-SETQ
-            WALKER::WALK-MULTIPLE-VALUE-BIND WALKER::WALK-SETQ
-            OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
-            MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            WALKER::WALK-SYMBOL-MACROLET WALKER::WALK-TAGBODY
-            MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            MAKE-DFUN-CALL WALKER::WALK-DO
-            MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
-            COMPUTE-STD-CPL-PHASE-3 WALKER::WALK-DO* WALKER::WALK-PROG
-            SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P SKIP-FAST-SLOT-ACCESS-P
-            |SETF PCL METHOD-FUNCTION-GET| VARIABLE-DECLARATION
-            |SETF PCL PLIST-VALUE| ENTRY-IN-CACHE-P PRINT-STD-INSTANCE
-            EXPAND-DEFGENERIC ADD-PV-BINDING MAKE-METHOD-SPEC
-            SET-FUNCTION-NAME-1 DECLARE-STRUCTURE BOOTSTRAP-GET-SLOT
-            MAKE-TOP-LEVEL-FORM CAN-OPTIMIZE-ACCESS OPTIMIZE-SLOT-VALUE
-            OPTIMIZE-SET-SLOT-VALUE OPTIMIZE-SLOT-BOUNDP
-            CHECK-INITARGS-1 OPTIMIZE-GENERIC-FUNCTION-CALL)) 
+    '(FTYPE (FUNCTION (T T T T T T T T T T T T T T) T)
+            ADD-LEXICAL-FUNCTIONS-TO-OPTIMIZED-STANDARD-METHOD-LAMBDA)) 
+(PROCLAIM '(FTYPE (FUNCTION (T T T T T T *) T) EMIT-DLAP)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T T T T T T) T) LOAD-DEFMETHOD-INTERNAL
+            LOAD-DEFMETHOD)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T) T) MAKE-LAP-PROG DLAP-WRAPPER-MOVES
-            EMIT-1-NIL-DLAP LOAD-FUNCTION-GENERATOR
+    '(FTYPE (FUNCTION (T T T T T T T T T T T T T) T)
+            BOOTSTRAP-INITIALIZE-STANDARD-CLASS)) 
+(PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM T T *) T) SET-ARG-INFO)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T T T T T T T T T T T) T)
+            ADD-LEXICAL-FUNCTIONS-TO-DOCUMENTED-STANDARD-METHOD-LAMBDA)) 
+(PROCLAIM '(FTYPE (FUNCTION (T T FIXNUM) T) COMPUTE-STD-CPL-PHASE-3)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T T T) T) EXPAND-DEFMETHOD
+            MAKE-LAP-CLOSURE-GENERATOR-LAMBDA)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T) T)
+            |CONSTRUCTOR-CODE-GENERATOR PCL SIMPLE-SLOTS|
+            LOAD-CONSTRUCTOR MAKE-FINAL-ORDINARY-DFUN-INTERNAL
+            BOOTSTRAP-MAKE-SLOT-DEFINITIONS MAKE-LAP-PROG
+            EMIT-1-NIL-DLAP DLAP-WRAPPER-MOVES OPTIMIZE-SLOT-VALUE
+            OPTIMIZE-SET-SLOT-VALUE OPTIMIZE-SLOT-BOUNDP
             GET-SECONDARY-DISPATCH-FUNCTION2
-            MAKE-FINAL-ORDINARY-DFUN-INTERNAL MAKE-FGEN
-            WALKER::WALK-TEMPLATE-HANDLE-REPEAT MAKE-EMF-CACHE
-            WALKER::WALK-BINDINGS-1 OPTIMIZE-INSTANCE-ACCESS
-            |CONSTRUCTOR-CODE-GENERATOR PCL FALLBACK|
             |CONSTRUCTOR-CODE-GENERATOR PCL GENERAL|
+            WALKER::WALK-TEMPLATE-HANDLE-REPEAT
+            MAKE-PARAMETER-REFERENCES
             |CONSTRUCTOR-CODE-GENERATOR PCL NO-METHODS|
-            |CONSTRUCTOR-CODE-GENERATOR PCL SIMPLE-SLOTS|
-            MAKE-LAP-PROG-INTERNAL LOAD-CONSTRUCTOR
-            MAKE-PARAMETER-REFERENCES BOOTSTRAP-MAKE-SLOT-DEFINITIONS)) 
+            |CONSTRUCTOR-CODE-GENERATOR PCL FALLBACK|
+            WALKER::WALK-BINDINGS-1 MAKE-LAP-PROG-INTERNAL
+            MAKE-EMF-CACHE BUILD-WITH-ACCESSOR-S-V MAKE-FGEN
+            LOAD-FUNCTION-GENERATOR)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) T) GET-SECONDARY-DISPATCH-FUNCTION1
-            EMIT-GET-SLOT EMIT-SET-SLOT WALKER::WALK-ARGLIST FILL-CACHE
-            REAL-GET-METHOD GET-METHOD)) 
+    '(FTYPE (FUNCTION (T T T) T) SYSTEM::APPLY-DISPLAY-FUN
+            PRINT-INTERNAL-SLOTD ONE-INDEX-DFUN-INFO |LAP Opcode NEQ|
+            WALKER::WALK-DO* CHECK-OPCODE-ARG WALKER::WALK-IF
+            EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
+            GET-NEW-FUNCTION-GENERATOR CHECK-INITARGS-1
+            SET-FUNCALLABLE-STANDARD-INSTANCE-ACCESS MAKE-SLOT-SYMBOL
+            SORT-METHODS ITERATE::OPTIMIZE-GATHERING-FORM
+            SORT-APPLICABLE-METHODS
+            ITERATE::SIMPLE-EXPAND-GATHERING-FORM
+            WRAP-METHOD-GROUP-SPECIFIER-BINDINGS
+            EARLY-STORE-METHOD-FUNCTION-P SET-FUNCTION-NAME-1
+            EARLY-STORE-METHOD-OPTIMIZED-FUNCTION-P
+            EARLY-STORE-CLOSURE-GENERATOR-P PRINT-STD-INSTANCE
+            TRACE-FUNCTION-INTERNAL WALKER::WALK-SETQ MAKE-METHOD-SPEC
+            OPTIMIZE-SLOT-VALUE-BY-CLASS-P
+            ITERATE::OPTIMIZE-ITERATE-FORM SET-STANDARD-INSTANCE-ACCESS
+            WALKER::WALK-FLET |LAP Opcode EQ| WALKER::WALK-PROG
+            SKIP-FAST-SLOT-ACCESS-P SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P
+            CHECK-OPERAND-ARG WALKER::WALK-MULTIPLE-VALUE-BIND
+            WALKER::WALK-LABELS WALKER::WALK-TAGBODY-1
+            |LAP Opcode FIX=| WALKER::WALK-SYMBOL-MACROLET
+            WALKER::WALK-PROG* SET-USER-INSTANCE-ACCESS
+            WALKER::WALK-LAMBDA FLUSH-CACHE-TRAP BOOTSTRAP-GET-SLOT
+            OBSOLETE-INSTANCE-TRAP UPDATE-STRUCTURE-CLASS
+            WALKER::WALK-TAGBODY |SETF PCL METHOD-FUNCTION-GET|
+            FIX-SLOT-ACCESSORS |SETF PCL PLIST-VALUE|
+            WALKER::WALK-NAMED-LAMBDA SLOW-SET-SLOT-VALUE
+            WALKER::WALK-COMPILER-LET WALKER::WALK-LET
+            |LAP Operand ISET| WALKER::WALK-MULTIPLE-VALUE-SETQ
+            WALKER::RELIST-INTERNAL CAN-OPTIMIZE-ACCESS
+            ITERATE::VARIABLE-SAME-P OPTIMIZE-GENERIC-FUNCTION-CALL
+            GET-FUNCTION-GENERATOR EMIT-LOCK-COUNT-TEST
+            ONE-CLASS-DFUN-INFO WALKER::RECONS WALKER::WALK-LET*
+            MAKE-TOP-LEVEL-FORM WALKER::WALK-MACROLET MAP-ALL-ORDERS
+            EXPAND-DEFGENERIC SET-CONSTRUCTOR-CODE INVALIDATE-WRAPPER
+            EMIT-CHECK-1-CLASS-WRAPPER
+            WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL
+            EARLY-STORE-OPTIMIZED-METHOD-LAMBDA-P CONVERT-TABLE
+            MAKE-DFUN-CALL
+            EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
+            NEW-ARG-INFO-FROM-GENERIC-FUNCTION COMPUTE-PRECEDENCE
+            WALKER::WALK-DO ITERATE::RENAME-AND-CAPTURE-VARIABLES
+            PRINT-CACHE WALKER::WALK-UNEXPECTED-DECLARE
+            VARIABLE-DECLARATION)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T) T) BOOTSTRAP-MAKE-SLOT-DEFINITION
-            EMIT-DLAP-INTERNAL EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP
-            EMIT-ADJUST-LOCATION WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1
-            EXPAND-DEFMETHOD LOAD-DEFCLASS MAKE-EARLY-CLASS-DEFINITION)) 
+    '(FTYPE (FUNCTION (T T T T T T) T)
+            WALKER::WALK-TEMPLATE-HANDLE-REPEAT-1
+            BOOTSTRAP-MAKE-SLOT-DEFINITION MAKE-EARLY-CLASS-DEFINITION
+            LOAD-DEFCLASS EMIT-DLAP-INTERNAL EMIT-ADJUST-LOCATION
+            EMIT-GREATER-THAN-1-DLAP EMIT-1-T-DLAP
+            OPTIMIZE-STD-INSTANCE-ACCESS REAL-LOAD-DEFCLASS
+            DO-SHORT-METHOD-COMBINATION BUILD-MAYBE-SAFE-W-O-S-V)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T *) T) NAMED-OBJECT-PRINT-FUNCTION
-            REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION
-            REAL-ENSURE-GF-USING-CLASS--NULL EMIT-GET-CLASS-SLOT
-            EMIT-SET-CLASS-SLOT GET-CACHE-FROM-CACHE
-            GET-EFFECTIVE-METHOD-FUNCTION1
-            WALKER::CONVERT-MACRO-TO-LAMBDA CPL-ERROR PROBE-CACHE
-            MAP-CACHE FIND-CLASS-FROM-CELL
-            FIND-CLASS-PREDICATE-FROM-CELL
-            ENSURE-GENERIC-FUNCTION-USING-CLASS RECORD-DEFINITION
-            DEFOPCODE-1 DEFOPERAND-1)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T) T) LOAD-DEFMETHOD
-            LOAD-DEFMETHOD-INTERNAL)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T T T) T)
-            ADD-LEXICAL-FUNCTIONS-TO-METHOD-LAMBDA)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) T)
-            MAKE-LAP-CLOSURE-GENERATOR-LAMBDA)) 
+    '(FTYPE (FUNCTION (T T T T) T) ADJUST-CACHE EXPAND-CACHE
+            MAKE-STD-CLOSURE-GENERATOR-FORM WALKER::WALK-BINDINGS-2
+            EXPAND-SYMBOL-MACROLET-INTERNAL
+            EMIT-CHECK-1-WRAPPER-IN-CACHE CHECK-INITARGS
+            BUILD-W-S-V-FIND-SLOT-INDICES EMIT-CHECK-2-CLASS-WRAPPER
+            GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION TWO-CLASS-DFUN-INFO
+            EXPAND-DEFCLASS LOAD-PRECOMPILED-DFUN-CONSTRUCTOR
+            WALKER::WALK-LET/LET* MAKE-CONSTRUCTOR BOOTSTRAP-SET-SLOT
+            WALKER::WALK-TEMPLATE EXPAND-DEFCONSTRUCTOR
+            WALKER::WALK-PROG/PROG* EMIT-CHECK-CACHE-LINE
+            BOOTSTRAP-ACCESSOR-DEFINITIONS EMIT-CHECK-CACHE-ENTRY
+            WALKER::WALK-DO/DO* FILL-CACHE-P)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) T) FILL-DFUN-CACHE
-            EMIT-FETCH-WRAPPER)) 
-(PROCLAIM '(FTYPE (FUNCTION (T T T FIXNUM) T) FILL-CACHE-FROM-CACHE-P)) 
+    '(FTYPE (FUNCTION (T T T T *) T) EMIT-FETCH-WRAPPER
+            FILL-DFUN-CACHE)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION NIL *) EMIT-N-N-READERS EMIT-N-N-WRITERS
-            COUNT-ALL-DFUNS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION NIL T) SHOW-DFUN-CONSTRUCTORS
-            BOOTSTRAP-META-BRAID MAKE-CACHE EARLY-INITIALIZE-SLOT-GFS
-            EARLY-INITIALIZE-CLASS-PREDICATES
-            BOOTSTRAP-BUILT-IN-CLASSES RESET-PCL-PACKAGE
-            |LAP Opcode BREAK| |LAP Opcode BEEP| DISPATCH-DFUN-INFO
-            SHOW-FREE-CACHE-VECTORS DEFAULT-METHOD-ONLY-DFUN-INFO
-            RENEW-SYS-FILES GET-EFFECTIVE-METHOD-GENSYM
-            RESET-CONSTRUCTORS MAKE-CPD LIST-ALL-DFUNS
-            DISABLE-CONSTRUCTORS ENABLE-CONSTRUCTORS CACHES-TO-ALLOCATE
-            ALLOCATE-FUNCALLABLE-INSTANCE-2
-            ALLOCATE-FUNCALLABLE-INSTANCE-1 %%ALLOCATE-INSTANCE--CLASS
-            BEFORE-PRECOMPILE-RANDOM-CODE-SEGMENTS MAKE-ARG-INFO
-            IN-THE-COMPILER-P STRUCTURE-FUNCTIONS-EXIST-P
-            |LAP Opcode EXIT-LAP-IN-LISP|)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (*) *) METHOD-COMBINATION-ERROR UNTRACE-METHOD
-            PV-WRAPPERS-FROM-PV-ARGS LIST-LARGE-CACHES
-            INVALID-METHOD-ERROR)) 
-(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) 
+    '(FTYPE (FUNCTION (T T T *) T) GET-METHOD FILL-CACHE
+            REAL-GET-METHOD EMIT-GET-SLOT EMIT-SET-SLOT
+            BUILD-WITH-OPTIMIZED-SLOTS-FORM
+            GET-SECONDARY-DISPATCH-FUNCTION1 WALKER::WALK-ARGLIST
+            RECORD-UPDATER)) 
+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM FIXNUM) FIXNUM) MAKE-INDEX-MASK)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION NIL *) RENEW-SYS-FILES EMIT-N-N-READERS
+            COUNT-ALL-DFUNS EMIT-N-N-WRITERS)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION NIL T) IN-THE-COMPILER-P RESET-CONSTRUCTORS
+            BEFORE-PRECOMPILE-RANDOM-CODE-SEGMENTS BOOTSTRAP-META-BRAID
+            DEFAULT-METHOD-ONLY-DFUN-INFO MAKE-ARG-INFO
+            |LAP Opcode EXIT-LAP-IN-LISP| DISABLE-CONSTRUCTORS
+            RESET-PCL-PACKAGE SHOW-FREE-CACHE-VECTORS
+            INITIAL-DISPATCH-DFUN-INFO FLOAT-ZERO
+            SHOW-DFUN-CONSTRUCTORS |LAP Opcode BREAK|
+            ENABLE-CONSTRUCTORS EARLY-INITIALIZE-SLOT-GFS
+            %%ALLOCATE-INSTANCE--CLASS CACHES-TO-ALLOCATE
+            ALLOCATE-FUNCALLABLE-INSTANCE-1
+            ALLOCATE-FUNCALLABLE-INSTANCE-2 MAKE-CPD
+            GET-EFFECTIVE-METHOD-GENSYM DISPATCH-DFUN-INFO
+            FIX-DFUNS-NEEDING-UPDATE NO-METHODS-DFUN-INFO
+            |LAP Opcode BEEP| MAKE-CACHE BOOTSTRAP-BUILT-IN-CLASSES
+            EARLY-INITIALIZE-CLASS-PREDICATES LIST-ALL-DFUNS)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (*) *) INVALID-METHOD-ERROR
+            METHOD-COMBINATION-ERROR UNTRACE-METHOD
+            FINALIZE-ALL-CLASSES LIST-LARGE-CACHES)) 
 (PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T) *) COMPUTE-CACHE-PARAMETERS)) 
+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) FIND-FREE-CACHE-LINE)) 
+(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM T) *) EMIT-READER/WRITER)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) *) FIND-WRAPPER STRUCTURE-WRAPPER
-            COMPUTE-APPLICABLE-METHODS-EMF SPECIALIZER-FROM-TYPE
-            CLASS-EQ-TYPE EMIT-ONE-CLASS-READER EMIT-ONE-CLASS-WRITER
-            EMIT-TWO-CLASS-READER EMIT-TWO-CLASS-WRITER
-            EMIT-ONE-INDEX-READERS EMIT-ONE-INDEX-WRITERS
-            DEFAULT-CODE-CONVERTER EMIT-CONSTANT-VALUE
-            PARSE-METHOD-GROUP-SPECIFIER PCL-DESCRIBE
-            FORCE-CACHE-FLUSHES GET-DISPATCH-FUNCTION
-            MAKE-DISPATCH-DFUN CCLOSUREP MAP-CONSTRUCTORS
-            COMPUTE-CONSTANT-VECTOR PARSE-DEFMETHOD
-            METHOD-PROTOTYPE-FOR-GF FIND-STRUCTURE-CLASS
-            INTERN-SLOT-NAME-LISTS ANALYZE-LAMBDA-LIST
-            MAKE-FINAL-DISPATCH-DFUN TYPE-FROM-SPECIALIZER
-            *NORMALIZE-TYPE UNPARSE-TYPE CONVERT-TO-SYSTEM-TYPE
-            EARLY-COLLECT-INHERITANCE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (*) T) |__si::MAKE-DFUN-INFO|
-            FIX-EARLY-GENERIC-FUNCTIONS |__si::MAKE-DISPATCH|
-            |__si::MAKE-DEFAULT-METHOD-ONLY|
-            |__si::MAKE-ACCESSOR-DFUN-INFO|
-            |__si::MAKE-ONE-INDEX-DFUN-INFO| TRUE |__si::MAKE-N-N|
-            |__si::MAKE-ONE-CLASS| |__si::MAKE-TWO-CLASS|
-            |__si::MAKE-ONE-INDEX| |__si::MAKE-ISL|
+    '(FTYPE (FUNCTION (*) T) |__si::MAKE-TWO-CLASS| TRUE
+            |__si::MAKE-ONE-INDEX-DFUN-INFO| WRAPPER-ERROR
+            |__si::MAKE-ARG-INFO| |__si::MAKE-STD-INSTANCE|
+            |__si::MAKE-CHECKING| |__si::MAKE-CACHING|
+            WALKER::UNBOUND-LEXICAL-FUNCTION |__si::MAKE-NO-METHODS|
+            |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION| FALSE
+            FIX-EARLY-GENERIC-FUNCTIONS |__si::MAKE-N-N|
+            |__si::MAKE-DEFAULT-METHOD-ONLY| FLATTEN-LAP
+            |__si::MAKE-CONSTANT-VALUE| STRING-APPEND
+            NULL-WRAPPERS-METHOD-FUNCTION |__si::MAKE-INITIAL-DISPATCH|
             |STRUCTURE-OBJECT class constructor|
-            WALKER::UNBOUND-LEXICAL-FUNCTION |__si::MAKE-ARG-INFO|
-            |__si::MAKE-CACHE| |__si::MAKE-CHECKING|
-            |__si::MAKE-CACHING| |__si::MAKE-CONSTANT-VALUE|
-            |__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION|
-            |__si::MAKE-STD-INSTANCE| CALLED-FIN-WITHOUT-FUNCTION
-            STRING-APPEND FLATTEN-LAP FALSE MAKE-PROGN)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T) T) REDIRECT-EARLY-FUNCTION-INTERNAL
-            ARG-INFO-VALID-P |LAP Operand OTHER-WRAPPER|
-            |LAP Operand BUILT-IN-OR-STRUCTURE-WRAPPER| UPDATE-GF-INFO
-            ALLOCATE-CACHE-VECTOR |LAP Operand STD-SLOTS|
-            FLUSH-CACHE-VECTOR-INTERNAL |LAP Operand FSC-SLOTS|
-            DO-STANDARD-DEFSETFS-FOR-DEFCLASS
-            |LAP Operand WRAPPER-CACHE-NUMBER-VECTOR| GET-CACHE-VECTOR
-            METHOD-FUNCTION-ISL METHOD-FUNCTION-NEEDS-NEXT-METHODS-P
-            FREE-CACHE-VECTOR GDEFINITION DFUN-INFO-P DFUN-ARG-SYMBOL
-            EARLY-METHOD-FUNCTION |LAP Operand I1+| EXTRACT-PARAMETERS
-            EXTRACT-SPECIALIZER-NAMES DISPATCH-P
-            EXTRACT-REQUIRED-PARAMETERS
-            DEFAULT-SECONDARY-DISPATCH-FUNCTION FREE-CACHE
-            DEFAULT-METHOD-ONLY-P EMIT-MISS UPDATE-C-A-M-GF-INFO
-            DLAP-WRAPPERS UPDATE-GF-SIMPLE-ACCESSOR-TYPE
-            ACCESSOR-DFUN-INFO-P STANDARD-SVUC-METHOD
-            STRUCTURE-SVUC-METHOD TYPE-CLASS ONE-INDEX-DFUN-INFO-P
-            CLASS-PREDICATE MAKE-CLASS-EQ-PREDICATE |LAP Operand LISP|
-            MAKE-EQL-PREDICATE |LAP Operand LISP-VARIABLE|
-            |LAP Opcode PRINT| N-N-P GET-BUILT-IN-CLASS-SYMBOL
-            GET-BUILT-IN-WRAPPER-SYMBOL ARG-INFO-NKEYS ONE-CLASS-P
-            DEFAULT-TEST-CONVERTER GET-READER-FUNCTION ARG-INFO-APPLYP
-            NET-TEST-CONVERTER DEFAULT-CONSTANT-CONVERTER
-            METHODS-CONTAIN-EQL-SPECIALIZER-P |LAP Opcode JMP|
-            GET-WRITER-FUNCTION |LAP Opcode LABEL| TWO-CLASS-P
-            |LAP Opcode GO| DEFAULT-CONSTANTP |LAP Opcode RETURN|
-            FGEN-TEST GF-DFUN-CACHE LOOKUP-FGEN EXPAND-LONG-DEFCOMBIN
-            FGEN-GENERATOR EXPAND-SHORT-DEFCOMBIN
-            UPDATE-ALL-C-A-M-GF-INFO UNDEFMETHOD-1 STORE-FGEN
-            FGEN-SYSTEM CONSTANT-VALUE-P FGEN-GENSYMS MAKE-INITIAL-DFUN
-            ACCESSOR-DFUN-INFO-ACCESSOR-TYPE FGEN-GENERATOR-LAMBDA
-            MAP-SPECIALIZERS MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION
-            USE-CONSTANT-VALUE-DFUN-P ONE-INDEX-DFUN-INFO-INDEX
-            CLASS-FROM-TYPE CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P
-            ONE-CLASS-WRAPPER0 DNET-METHODS-P TWO-CLASS-WRAPPER1
-            CHECKING-FUNCTION UPDATE-GFS-OF-CLASS CACHING-DFUN-INFO
-            ALLOCATE-REGISTER UPDATE-CLASS-CAN-PRECEDE-P
-            DEALLOCATE-REGISTER COMPUTE-CLASS-SLOTS ARG-INFO-PRECEDENCE
-            ARG-INFO-METATYPES UPDATE-ISL-CACHE-INFO
-            ARG-INFO-NUMBER-OPTIONAL ARG-INFO-KEY/REST-P
-            MAKE-STD-BOUNDP-METHOD-FUNCTION ARG-INFO-KEYWORDS
-            GF-INFO-SIMPLE-ACCESSOR-TYPE ISLP CONSTANT-VALUE-DFUN-INFO
-            MAKE-STD-WRITER-METHOD-FUNCTION
-            GF-PRECOMPUTE-DFUN-AND-EMF-P GF-INFO-STATIC-C-A-M-EMF
-            STRUCTURE-OBJECT-P MAKE-STD-READER-METHOD-FUNCTION
-            GF-INFO-C-A-M-EMF-STD-P WALKER::ENV-LOCK
-            ARG-INFO-LAMBDA-LIST WALKER::ENV-LEXICAL-VARIABLES
-            USE-CACHING-DFUN-P WALKER::ENV-DECLARATIONS
+            CALLED-FIN-WITHOUT-FUNCTION |__si::MAKE-DISPATCH|
+            |__si::MAKE-ONE-CLASS| MAKE-PROGN
+            |__si::MAKE-ACCESSOR-DFUN-INFO| |__si::MAKE-ONE-INDEX| ZERO
+            MAKE-INTERNAL-SLOTD |__si::MAKE-DFUN-INFO|
+            |__si::MAKE-CACHE|)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T) *) IN-COMPILER-FORCE-COMPILE
+            SLOT-INITFUNCTION-STORAGE-FORM COMPILE-INITFUNCTION
+            MAKE-DISPATCH-DFUN EMIT-CONSTANT-VALUE
+            COMPUTE-APPLICABLE-METHODS-EMF MAKE-FINAL-DISPATCH-DFUN
+            PARSE-METHOD-GROUP-SPECIFIER ANALYZE-LAMBDA-LIST
+            PARSE-DEFMETHOD EMIT-ONE-CLASS-READER PCL-DESCRIBE
+            COMPUTE-CONSTANT-VECTOR EMIT-ONE-INDEX-READERS
+            EMIT-ONE-CLASS-WRITER EMIT-ONE-INDEX-WRITERS
+            MAP-CONSTRUCTORS METHOD-FUNCTION-STORAGE-FORM
+            COMPILE-FUNCTION EMIT-TWO-CLASS-READER
+            DEFAULT-CODE-CONVERTER EARLY-COLLECT-INHERITANCE
+            EMIT-TWO-CLASS-WRITER GET-DISPATCH-FUNCTION CCLOSUREP)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (FIXNUM T T T) T) GET-WRAPPERS-FROM-CLASSES)) 
+(PROCLAIM '(FTYPE (FUNCTION (T FIXNUM *) T) GET-CACHE-FROM-CACHE)) 
+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T T FIXNUM) T) GET-CACHE)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T) T) SIMPLE-EVAL-ACCESS-P UNDEFMETHOD-1
+            ALL-STANDARD-ACCESSES-P MAP-ALL-GENERIC-FUNCTIONS
+            |LAP Operand WRAPPER-CACHE-NUMBER-VECTOR|
+            STRUCTURE-SLOTD-READER-FUNCTION LOOKUP-FGEN
+            |LAP Operand OTHER-WRAPPER| TWO-CLASS-ACCESSOR-TYPE
+            STORE-FGEN GFS-OF-TYPE DEFAULT-METHOD-ONLY-CACHE
+            REALLY-FUNCTION-P METHOD-FUNCTION-METHOD
+            FTYPE-DECLARATION-FROM-LAMBDA-LIST EARLY-COLLECT-CPL
+            DFUN-INFO-P ARG-INFO-PRECEDENCE GET-WRITER-FUNCTION
+            EARLY-METHOD-QUALIFIERS LAP-OPERAND CPD-CLASS
+            TWO-CLASS-WRAPPER1 |LAP Opcode JMP| STORE-DEFSTRUCT-FORM
+            FLUSH-CACHE-VECTOR-INTERNAL FREE-CACHE CACHE-P
+            |LAP Operand LISP-VARIABLE| MAKE-STD-WRITER-METHOD-FUNCTION
+            PROCLAIM-CLOSURE EXPAND-LONG-DEFCOMBIN ONE-CLASS-CACHE
+            INITIALIZE-INTERNAL-SLOT-BOUNDP-GFS *NORMALIZE-TYPE
+            MAKE-FIND-CLASS-CELL STRUCTURE-SLOTD-WRITER-FUNCTION
+            FUNCTION-RETURNING-T DEFAULT-TEST-CONVERTER
+            INTERNAL-SLOTD-SLOT-DEFINITION ECD-CLASS-NAME GBOUNDP
+            CONSTANT-VALUE-CACHE CACHING-DFUN-INFO INTERNAL-SLOTD-P
+            MAKE-TYPE-PREDICATE FUNCTION-FTYPE-DECLAIMED-P
+            INTERNAL-SLOTD-LOCATION STRUCTURE-TYPE-INCLUDED-TYPE-NAME
+            NET-TEST-CONVERTER UPDATE-ALL-C-A-M-GF-INFO
+            SYSTEM::NEXT-STACK-FRAME EARLY-GF-NAME
+            INITIAL-DISPATCH-CACHE FUNCALLABLE-INSTANCE-P
+            TWO-CLASS-CACHE GDEFINITION EARLY-COLLECT-SLOTS
+            NO-METHODS-P CACHING-P
+            MAKE-STRUCTURE-INSTANCE-READER-METHOD-FUNCTION
+            |LAP Operand CVAR| KNOWN-STRUCTURE-TYPE-P
+            STRUCTURE-SLOTD-NAME UNTRACE-METHOD-FUNCTION-NAMES
+            INDEX-VALUE->INDEX NON-PCL-SHARED-INITIALIZE-METHODS-P
+            ONE-CLASS-ACCESSOR-TYPE EXPAND-SHORT-DEFCOMBIN
+            CLASS-FROM-TYPE |LAP Opcode LABEL| ONE-CLASS-INDEX
+            LIST-DFUN EARLY-CLASS-ORIGINAL-STATIC-SLOT-STORAGE-COPY
+            TWO-CLASS-P GET-CACHE-VECTOR
+            MAKE-FUNCALLABLE-STANDARD-INSTANCE-WRITER-METHOD-FUNCTION
+            DEFAULT-CONSTANT-CONVERTER DEFSTRUCT-FORM-CLASS-NAME
+            KEYWORD-SPEC-NAME ARG-INFO-APPLYP
+            DEFSTRUCT-FORM-CONSTRUCTOR CONVERT-TO-SYSTEM-TYPE
+            CLASS-PREDICATE DFUN-INFO-CACHE LAP-OPCODE
+            EARLY-METHOD-FUNCTION MAKE-CLASS-PREDICATE
+            USER-INSTANCE-SLOTS USE-CONSTANT-VALUE-DFUN-P
+            FUNCTION-PRETTY-ARGLIST ECD-OTHER-INITARGS
+            INTERN-FUNCTION-NAME CACHING-CACHE CLASS-STANDARD-P
+            EARLY-METHOD-STANDARD-ACCESSOR-P |LAP Operand STD-WRAPPER|
+            N-N-P STRUCTURE-OBJECT-P GF-INFO-STATIC-C-A-M-EMF
+            PARSE-SPECIALIZERS ITERATE::VARIABLES-FROM-LET
+            ALLOCATE-REGISTER CLASS-INSTANCE-TYPE
+            UPDATE-GF-SIMPLE-ACCESSOR-TYPE DNET-METHODS-P
+            DEFAULT-METHOD-ONLY-P FORCE-CACHE-FLUSHES
+            |LAP Operand STD-SLOTS| |LAP Opcode RETURN|
+            COMPILER::CAN-USE-PRINT-CIRCLE-P ECD-METACLASS N-N-CACHE
+            REDIRECT-EARLY-FUNCTION-INTERNAL LAMBDA-LIST-REQUIRED-ARGS
+            INITIALIZE-INTERNAL-SLOT-READER-GFS
+            REALLY-COMPILED-FUNCTION-P |LAP Operand BUILT-IN-WRAPPER|
+            MAKE-CLASS-EQ-PREDICATE ARG-INFO-METATYPES INSTANCE-TYPE
+            CPD-AFTER DEFAULT-CONSTANTP
+            INITIALIZE-INTERNAL-SLOT-WRITER-GFS TRACE-METHODS
+            TWO-CLASS-INDEX NO-METHODS-CACHE
+            EARLY-COLLECT-DEFAULT-INITARGS STRUCTURE-WRAPPER
+            MAKE-OPTIMIZED-USER-BOUNDP-METHOD-FUNCTION DISPATCH-P
+            UNPARSE-TYPE-LIST N-N-ACCESSOR-TYPE ACCESSOR-DFUN-INFO-P
+            CLASS-PRECEDENCE-DESCRIPTION-P ONE-CLASS-WRAPPER0
+            METHODS-CONTAIN-EQL-SPECIALIZER-P
+            UPDATE-CLASS-CAN-PRECEDE-P TYPE-CLASS ARG-INFO-KEYWORDS
+            FGEN-TEST MAKE-STD-READER-METHOD-FUNCTION
+            DEFSTRUCT-FORM-CONC-NAME EMIT-MISS FREE-CACHE-VECTOR
+            UNENCAPSULATED-FDEFINITION CHECK-WRAPPER-VALIDITY
+            MAKE-EQL-PREDICATE UNPARSE-TYPE DLAP-WRAPPERS EARLY-GET-CPL
+            FGEN-GENERATOR-LAMBDA STRUCTURE-TYPE-INTERNAL-SLOTDS
+            CHECKING-P |LAP Operand ARG| FIND-CYCLE-REASONS CPD-SUPERS
+            %CCLOSURE-ENV TWO-CLASS-WRAPPER0 COMPUTE-STD-CPL-PHASE-2
+            WALKER::ENV-WALK-FUNCTION GET-BOUNDP-FUNCTION
+            |LAP Operand STRUCTURE-WRAPPER| GET-READER-FUNCTION
+            |LAP Operand REG| ARG-INFO-LAMBDA-LIST |LAP Operand I1+|
+            DEFSTRUCT-FORM-PREDICATE-NAME ARG-INFO-VALID-P
+            USER-INSTANCE-P WRAPPER-OF %STD-INSTANCE-WRAPPER
+            INITIAL-DISPATCH-P
+            MAKE-OPTIMIZED-USER-WRITER-METHOD-FUNCTION
+            MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION MAKE-INITIAL-DFUN
+            GET-SETF-FUNCTION-NAME USER-INSTANCE-WRAPPER DISPATCH-CACHE
+            |LAP Operand USER-WRAPPER| EXTRACT-LAMBDA-LIST
+            UPDATE-GFS-OF-CLASS FIND-WRAPPER EXTRACT-SPECIALIZER-NAMES
+            DEFAULT-SECONDARY-DISPATCH-FUNCTION FORMAT-CYCLE-REASONS
+            FUNCTION-RETURNING-NIL DO-STANDARD-DEFSETFS-FOR-DEFCLASS
+            ITERATE::SEQUENCE-ACCESSOR |LAP Operand LISP| EARLY-GF-P
+            WALKER::ENV-LEXICAL-VARIABLES ONE-INDEX-DFUN-INFO-CACHE
+            MAKE-STD-DOCUMENTED-METHOD-FUNCTION LEGAL-CLASS-NAME-P
+            STANDARD-SVUC-METHOD GET-BUILT-IN-CLASS-SYMBOL
+            METHOD-PROTOTYPE-FOR-GF |LAP Opcode GO|
+            MAKE-STD-BOUNDP-METHOD-FUNCTION WALKER::ENV-DECLARATIONS
+            DEALLOCATE-REGISTER WALKER::ENV-WALK-FORM UPDATE-GF-INFO
+            ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE CHECKING-CACHE
+            INTERN-EQL-SPECIALIZER GMAKUNBOUND DO-STANDARD-DEFSETF-1
+            FGEN-GENSYMS INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS
             WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE
-            ARG-INFO-P WALKER::ENV-WALK-FORM WALKER::ENV-WALK-FUNCTION
-            WALKER::GET-WALKER-TEMPLATE CACHE-P GFS-OF-TYPE
-            PROCLAIM-INCOMPATIBLE-SUPERCLASSES
-            COMPUTE-APPLICABLE-METHODS-EMF-STD-P
-            ITERATE::VARIABLES-FROM-LET STRUCTURE-TYPE-INTERNAL-SLOTDS
-            MAKE-WRAPPER COPY-CACHE GF-DFUN-INFO
-            ITERATE::SEQUENCE-ACCESSOR COMPUTE-LINE-SIZE
-            USE-DISPATCH-DFUN-P %CCLOSURE-ENV SLOT-READER-SYMBOL
-            SLOT-WRITER-SYMBOL GET-BOUNDP-FUNCTION SLOT-BOUNDP-SYMBOL
-            STRUCTURE-SLOT-BOUNDP
-            MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
-            SLOT-VECTOR-SYMBOL STRUCTURE-SLOTD-READER-FUNCTION
-            COMPUTE-STD-CPL-PHASE-2 MAKE-CALL-METHODS
-            MAKE-NOT-FOR-CACHING-METHOD-FUNCTION ONE-INDEX-P CHECKING-P
-            FIND-CYCLE-REASONS FORMAT-CYCLE-REASONS CACHING-P CLASS-OF
-            MAKE-PERMUTATION-VECTOR CPD-CLASS CPD-SUPERS MUTATE-SLOTS
-            SORT-SLOTS CPD-AFTER MAKE-ISL-TYPE-DECLARATION
-            MAKE-PV-TYPE-DECLARATION CPD-COUNT SYMBOL-PKG-NAME MAKE-ISL
-            VARIABLE-GLOBALLY-SPECIAL-P
-            MAKE-INTERNAL-READER-METHOD-FUNCTION STD-INSTANCE-P
-            CLASS-PRECEDENCE-DESCRIPTION-P FUNCALLABLE-INSTANCE-P
-            DFUN-INFO-CACHE DISPATCH-CACHE DEFAULT-METHOD-ONLY-CACHE
-            ACCESSOR-DFUN-INFO-CACHE ONE-INDEX-DFUN-INFO-CACHE
-            ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE LAP-OPCODE N-N-CACHE
-            FUNCTION-RETURNING-NIL %STD-INSTANCE-WRAPPER
-            N-N-ACCESSOR-TYPE LAP-REG-INITIAL-VALUE-FORM
-            %STD-INSTANCE-SLOTS ONE-CLASS-CACHE LAP-OPERAND
-            ONE-CLASS-ACCESSOR-TYPE ONE-CLASS-INDEX TWO-CLASS-CACHE
-            SYSTEM:%STRUCTURE-NAME TWO-CLASS-ACCESSOR-TYPE
-            SYSTEM:%COMPILED-FUNCTION-NAME TWO-CLASS-INDEX
-            TWO-CLASS-WRAPPER0 ONE-INDEX-CACHE INDEX-VALUE->INDEX
-            ONE-INDEX-ACCESSOR-TYPE INDEX->INDEX-VALUE ONE-INDEX-INDEX
-            CHECKING-CACHE DO-STANDARD-DEFSETF-1
-            INITIALIZE-INTERNAL-SLOT-GFS CACHING-CACHE
-            CONSTANT-VALUE-CACHE EXTRACT-LAMBDA-LIST
-            WRAPPER-FOR-STRUCTURE SLOT-NAME-LISTS-FROM-SLOTS
-            LEGAL-CLASS-NAME-P STRUCTURE-TYPE-P BUILT-IN-WRAPPER-OF
+            ARG-INFO-P WALKER::ENV-LOCK SPECIALIZER-FROM-TYPE
+            GET-CONS-GLOBAL-VARIABLE MAKE-CONSTANT-FUNCTION
+            MAKE-CALL-METHODS STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST
+            VARIABLE-GLOBALLY-SPECIAL-P ONE-INDEX-P
+            STRUCTURE-SVUC-METHOD COMPUTE-APPLICABLE-METHODS-EMF-STD-P
+            MAKE-FUNCTION-INLINE |LAP Opcode PRINT| CHECKING-FUNCTION
+            ONE-INDEX-CACHE MAKE-DEFCLASS-DIRECT-SLOTS-FROM-DEFSTRUCT
+            UPDATE-C-A-M-GF-INFO PROTOTYPE-OF-GENERIC-FUNCTION
+            ONE-INDEX-ACCESSOR-TYPE %STD-INSTANCE-SLOTS ONE-INDEX-INDEX
+            ECD-SUPERCLASS-NAMES EXTRACT-REQUIRED-PARAMETERS
+            CLASS-EQ-TYPE EXTRACT-PARAMETERS UPDATE-SLOTS
+            CONSTANT-VALUE-DFUN-INFO
+            MAKE-STANDARD-INSTANCE-BOUNDP-METHOD-FUNCTION
+            MAKE-STRUCTURE-INSTANCE-WRITER-METHOD-FUNCTION
+            GENERIC-CLOBBERS-FUNCTION GF-DFUN-INFO MAKE-INITFUNCTION
+            |LAP Operand BUILT-IN-OR-STRUCTURE-WRAPPER|
+            |LAP Operand FSC-SLOTS| CANONICAL-SLOT-NAME
+            UNPARSE-SPECIALIZERS
+            MAKE-FUNCALLABLE-STANDARD-INSTANCE-BOUNDP-METHOD-FUNCTION
+            ONE-INDEX-DFUN-INFO-P FGEN-SYSTEM
+            MAKE-DOCUMENTED-STD-READER-METHOD-FUNCTION STD-INSTANCE-P
+            BUILT-IN-WRAPPER-OF
+            NON-PCL-OR-AFTER-SHARED-INITIALIZE-METHODS-P
+            SLOT-DEFINITION-DEFSTRUCT-SLOT-DESCRIPTION
+            LAP-REG-INITIAL-VALUE-FORM GET-BUILT-IN-WRAPPER-SYMBOL
+            WALKER::GET-WALKER-TEMPLATE STRUCTURE-SLOTD-ACCESSOR-SYMBOL
+            |LAP Operand CDR|
+            MAKE-STANDARD-INSTANCE-WRITER-METHOD-FUNCTION
+            EARLY-CLASS-DEFINITION ACCESSOR-DFUN-INFO-CACHE
+            MAKE-STANDARD-INSTANCE-READER-METHOD-FUNCTION
+            SYSTEM:%STRUCTURE-NAME SLOT-SYMBOL-ERROR
+            SYSTEM:%COMPILED-FUNCTION-NAME ONE-INDEX-DFUN-INFO-INDEX
+            TYPE-FROM-SPECIALIZER MAP-SPECIALIZERS
+            MAKE-DOCUMENTED-STD-WRITER-METHOD-FUNCTION
             NON-PCL-OR-AFTER-INITIALIZE-INSTANCE-METHODS-P
-            BUILT-IN-OR-STRUCTURE-WRAPPER1
-            NON-PCL-OR-AFTER-SHARED-INITIALIZE-METHODS-P SETFBOUNDP
-            INTERN-FUNCTION-NAME GET-SETF-FUNCTION-NAME
-            COMPILE-LAMBDA-UNCOMPILED KEYWORD-SPEC-NAME
-            FTYPE-DECLARATION-FROM-LAMBDA-LIST COMPILE-LAMBDA-DEFERRED
-            GENERIC-CLOBBERS-FUNCTION UNENCAPSULATED-FDEFINITION
-            FUNCTION-PRETTY-ARGLIST PARSE-SPECIALIZERS
+            ACCESSOR-DFUN-INFO-ACCESSOR-TYPE ECD-CANONICAL-SLOTS
+            STRUCTURE-SLOT-BOUNDP PROCLAIM-INCOMPATIBLE-SUPERCLASSES
+            UN-THE MAKE-WRAPPER |LAP Operand USER-SLOTS|
+            |LAP Operand CONSTANT| SLOT-READER-UNDEFINED
+            USE-DISPATCH-DFUN-P METHOD-LL->GENERIC-FUNCTION-LL
+            LIST-LARGE-CACHE
+            MAKE-FUNCALLABLE-STANDARD-INSTANCE-READER-METHOD-FUNCTION
+            CONSTANT-VALUE-P GF-INFO-SIMPLE-ACCESSOR-TYPE
+            SLOT-BOUNDP-UNDEFINED WRAPPER-FOR-STRUCTURE
+            MAKE-STRUCTURE-INSTANCE-BOUNDP-METHOD-FUNCTION
+            GF-DFUN-CACHE COPY-CACHE ECD-SOURCE CLASS-OF
+            EARLY-CLASS-SLOTS MAKE-NOT-FOR-CACHING-METHOD-FUNCTION
+            USE-CACHING-DFUN-P INDEX->INDEX-VALUE
+            BUILT-IN-OR-STRUCTURE-WRAPPER-FUN FGEN-GENERATOR
+            EARLY-UPDATE-DISCRIMINATOR-CODE COUNT-DFUN ONE-CLASS-P
             NON-PCL-INITIALIZE-INSTANCE-METHODS-P
-            EARLY-METHOD-QUALIFIERS NON-PCL-SHARED-INITIALIZE-METHODS-P
-            INTERN-EQL-SPECIALIZER WRAPPER-FIELD
-            EARLY-UPDATE-DISCRIMINATOR-CODE LIST-DFUN
-            EARLY-CLASS-DEFINITION NEXT-WRAPPER-FIELD EARLY-GF-P
-            MAKE-TYPE-PREDICATE EARLY-GF-NAME |LAP Operand REG|
-            LIST-LARGE-CACHE DEFAULT-STRUCTUREP EARLY-COLLECT-CPL
-            EARLY-GET-CPL DEFAULT-STRUCTURE-INSTANCE-P
-            |LAP Operand CVAR| UNPARSE-TYPE-LIST DEFAULT-STRUCTURE-TYPE
-            EARLY-COLLECT-SLOTS |LAP Operand ARG| COUNT-DFUN
-            STRUCTURE-TYPE INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS
-            EARLY-COLLECT-DEFAULT-INITARGS
-            EARLY-METHOD-STANDARD-ACCESSOR-P
-            STRUCTURE-TYPE-INCLUDED-TYPE-NAME MAKE-INITFUNCTION
-            WRAPPER-OF STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST
-            CHECK-WRAPPER-VALIDITY CANONICAL-SLOT-NAME
-            STRUCTURE-SLOTD-NAME |LAP Operand CDR|
-            MAP-ALL-GENERIC-FUNCTIONS STRUCTURE-SLOTD-ACCESSOR-SYMBOL
-            ECD-CLASS-NAME GBOUNDP STRUCTURE-SLOTD-WRITER-FUNCTION
-            UNPARSE-SPECIALIZERS GMAKUNBOUND |LAP Operand CONSTANT|
-            ECD-SOURCE METHOD-LL->GENERIC-FUNCTION-LL ECD-METACLASS
-            ECD-SUPERCLASS-NAMES EARLY-CLASS-SLOTS
-            |LAP Operand STD-WRAPPER| ECD-CANONICAL-SLOTS
-            ECD-OTHER-INITARGS MAKE-CONSTANT-FUNCTION
-            FUNCTION-RETURNING-T |LAP Operand FSC-WRAPPER|
-            MAKE-FUNCTION-INLINE |LAP Operand BUILT-IN-WRAPPER|
-            |LAP Operand STRUCTURE-WRAPPER|)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T *) *) PARSE-METHOD-OR-SPEC OPCODE OPERAND
-            MAKE-FINAL-DFUN-INTERNAL MAP-ALL-CLASSES GET-FUNCTION
-            GET-FUNCTION1 MAKE-CONSTANT-VALUE-DFUN GET-DFUN-CONSTRUCTOR
-            MAKE-CACHING-DFUN GET-METHOD-FUNCTION
-            ENSURE-GENERIC-FUNCTION WALK-FORM EXTRACT-DECLARATIONS
-            PARSE-SPECIALIZED-LAMBDA-LIST ENSURE-CLASS COERCE-TO-CLASS
-            COMPILE-LAMBDA)) 
+            MAKE-DOCUMENTED-STD-BOUNDP-METHOD-FUNCTION SETFBOUNDP
+            |LAP Operand FSC-WRAPPER|)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T *) *) COMPILE-LAMBDA EXTRACT-DECLARATIONS
+            OPCODE GET-FUNCTION OPERAND PARSE-METHOD-OR-SPEC
+            MAKE-FINAL-DFUN-INTERNAL PARSE-SPECIALIZED-LAMBDA-LIST
+            GET-FUNCTION1 MAP-ALL-CLASSES MAKE-CACHING-DFUN
+            MAKE-CONSTANT-VALUE-DFUN WALK-FORM ENSURE-GENERIC-FUNCTION)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T (VECTOR T)) T) ALLOCATE-FUNCALLABLE-INSTANCE)) 
 (PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) 
-(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) CAPITALIZE-WORDS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T *) T) UPDATE-DFUN SET-DFUN MAKE-FINAL-DFUN
-            TRACE-METHOD WALKER::WALKER-ENVIRONMENT-BIND-1
-            MAKE-SPECIALIZABLE ITERATE::FUNCTION-LAMBDA-P
-            ITERATE::MAYBE-WARN WALKER::RELIST*
-            PRECOMPUTE-EFFECTIVE-METHODS WALKER::RELIST FIND-CLASS
-            LAP-OPERANDS FIND-CLASS-CELL EARLY-METHOD-SPECIALIZERS
-            MAKE-TYPE-PREDICATE-NAME FIND-CLASS-PREDICATE)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T) *) COMPUTE-APPLICABLE-METHODS-USING-TYPES
-            CLASS-APPLICABLE-USING-CLASS-P EMIT-WRAPPER-REF SAUT-AND
-            SAUT-NOT SAUT-CLASS SAUT-CLASS-EQ SAUT-EQL SLOT-BOUNDP
-            SLOT-EXISTS-P SLOT-MAKUNBOUND EMIT-CHECKING EMIT-CACHING
-            SLOT-VALUE COMPUTE-TEST UPDATE-SLOT-VALUE-GF-INFO
-            GET-NEW-FUNCTION-GENERATOR-INTERNAL COMPUTE-CODE
-            SDFUN-FOR-CACHING EMIT-CACHE-VECTOR-REF MAKE-DIRECT-SLOTD
-            ITERATE::PARSE-DECLARATIONS COMPUTE-STD-CPL-PHASE-1
-            FIND-SUPERCLASS-CHAIN GENERATE-FAST-CLASS-SLOT-ACCESS-P
-            ENSURE-CLASS-VALUES DESTRUCTURE SET-FUNCTION-NAME *SUBTYPEP
-            SPECIALIZER-APPLICABLE-USING-TYPE-P *TYPEP INITIAL-DFUN
-            EARLY-DFUN)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T) (*)) SORT-APPLICABLE-METHODS
-            SORT-METHODS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T) T) |SETF PCL FIND-CLASS-PREDICATE|
-            NEW-ARG-INFO-FROM-METHOD ADD-ARG-INFO REAL-REMOVE-METHOD
-            REMOVE-ARG-INFO SUPERCLASSES-COMPATIBLE-P
-            CLASSES-HAVE-COMMON-SUBCLASS-P METHOD-FUNCTION-GET
-            SAUT-NOT-CLASS PLIST-VALUE SAUT-NOT-CLASS-EQ
-            |LAP Operand CREF| SAUT-NOT-EQL |LAP Operand IREF|
-            REDEFINE-FUNCTION |LAP Operand I+| LIST-EQ |LAP Operand I-|
-            COMPUTE-APPLICABLE-METHODS-FUNCTION |LAP Operand ILOGAND|
-            QUALIFIER-CHECK-RUNTIME |LAP Operand ILOGXOR|
-            |LAP Operand ISHIFT| UPDATE-STD-OR-STR-METHODS
-            SET-STANDARD-SVUC-METHOD SET-STRUCTURE-SVUC-METHOD
-            MEC-ALL-CLASSES-INTERNAL MEC-ALL-CLASSES
-            MEC-ALL-CLASS-LISTS |LAP Opcode MOVE| VARIABLE-CLASS
-            REMOVE-METHOD COMPUTE-SECONDARY-DISPATCH-FUNCTION1
-            METHODS-CONVERTER |LAP Opcode IZEROP|
-            |LAP Opcode STD-INSTANCE-P| |LAP Opcode FSC-INSTANCE-P|
+(PROCLAIM
+    '(FTYPE (FUNCTION (T *) T) FIND-CLASS ITERATE::FUNCTION-LAMBDA-P
+            ITERATE::MAYBE-WARN PRECOMPUTE-EFFECTIVE-METHODS
+            LAP-OPERANDS MAKE-SPECIALIZABLE WALKER::RELIST
+            LAMBDA-LIST-LEGAL-P MAKE-TYPE-PREDICATE-NAME
+            COERCE-TO-CLASS FIND-STRUCTURE-CLASS MAKE-FINAL-DFUN
+            GET-METHOD-FUNCTION COMPILE-LAMBDA-DEFERRED
+            NO-NEXT-METHOD-TRAP WALKER::RELIST* GET-DFUN-CONSTRUCTOR
+            FIND-CLASS-PREDICATE EARLY-METHOD-SPECIALIZERS UPDATE-DFUN
+            WALKER::WALKER-ENVIRONMENT-BIND-1 SET-DFUN FIND-CLASS-CELL
+            CAPITALIZE-WORDS COMPILE-LAMBDA-UNCOMPILED ENSURE-CLASS)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T) *) SLOT-VALUE ITERATE::PARSE-DECLARATIONS
+            EMIT-WRAPPER-REF *SUBTYPEP SDFUN-FOR-CACHING SAUT-OR-P
+            EMIT-CHECKING SAUT-CLASS-EQ-P SAUT-NOT-P COMPUTE-CODE
+            EARLY-DFUN FIND-SUPERCLASS-CHAIN COMPUTE-TEST SAUT-EQL-P
+            DESTRUCTURE SAUT-CLASS-P SET-FUNCTION-NAME UPDATE-INITS
+            CLASS-APPLICABLE-USING-CLASS-P EMIT-CACHING
+            EMIT-CACHE-VECTOR-REF GET-NEW-FUNCTION-GENERATOR-INTERNAL
+            SPECIALIZER-APPLICABLE-USING-TYPE-P INITIAL-DFUN
+            ENSURE-CLASS-VALUES SAUT-AND-P COMPUTE-STD-CPL-PHASE-1
+            COMPUTE-APPLICABLE-METHODS-USING-TYPES)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T) T) REMOVE-METHOD SLOT-BOUNDP SLOT-EXISTS-P
+            SLOT-MAKUNBOUND SYSTEM::DISPLAY-ENV
+            SYSTEM::DISPLAY-COMPILED-ENV
             |LAP Opcode BUILT-IN-INSTANCE-P|
-            |LAP Opcode STRUCTURE-INSTANCE-P| COMPUTE-CONSTANTS
-            MAKE-EFFECTIVE-METHOD-FUNCTION1 DEAL-WITH-ARGUMENTS-OPTION
-            PARSE-QUALIFIER-PATTERN NET-CONSTANT-CONVERTER AUGMENT-TYPE
-            UPDATE-CPL UPDATE-SLOTS VALUE-FOR-CACHING
-            CLASS-MIGHT-PRECEDE-P UPDATE-INITS UPDATE-CLASS
-            MAKE-DISCRIMINATING-FUNCTION-ARGLIST UPDATE-ALL-ISL-CACHES
-            WALKER::ENVIRONMENT-MACRO COMPUTE-LAYOUT
-            WALKER::VARIABLE-SYMBOL-MACRO-P ACCESSOR-MISS-FUNCTION
-            ADD-DIRECT-SUBCLASSES MAKE-CLASS-PREDICATE
-            ADD-SLOT-ACCESSORS WALKER::WALK-REPEAT-EVAL N-N-DFUN-INFO
-            WALKER::NOTE-DECLARATION ITERATE::MV-SETQ
-            WALKER::NOTE-LEXICAL-BINDING REMOVE-DIRECT-SUBCLASSES
-            ITERATE::EXTRACT-SPECIAL-BINDINGS REMOVE-SLOT-ACCESSORS
-            MAKE-UNORDERED-METHODS-EMF WALKER::ENVIRONMENT-FUNCTION
-            NO-SLOT RAISE-METATYPE %SET-CCLOSURE-ENV CHECKING-DFUN-INFO
-            ITERATE::SIMPLE-EXPAND-ITERATE-FORM
+            LOAD-DEFINE-CONSTRUCTOR-CODE-TYPE |LAP Opcode IZEROP|
+            ACCESSOR-MISS-FUNCTION BOOTSTRAP-SLOT-INDEX
+            %SET-CCLOSURE-ENV PARSE-QUALIFIER-PATTERN
+            METHOD-FUNCTION-GET |LAP Operand I-|
+            MAKE-EFFECTIVE-METHOD-FUNCTION1
+            |LAP Opcode STRUCTURE-INSTANCE-P|
+            SET-METHOD-FUNCTION-METHOD WALKER::ENVIRONMENT-FUNCTION
+            SUPERCLASSES-COMPATIBLE-P WALKER::ENVIRONMENT-MACRO
+            CLASSES-HAVE-COMMON-SUBCLASS-P *TYPEP
+            GENERATE-FAST-CLASS-SLOT-ACCESS-P
+            |LAP Opcode FSC-INSTANCE-P| LOAD-DEFOPCODE UPDATE-CLASS
+            SLOW-SLOT-VALUE |LAP Opcode MOVE| VARIABLE-CLASS SET-SLOTS
+            NET-CONSTANT-CONVERTER MAKE-DFUN-LAMBDA-LIST
+            METHODS-CONVERTER ADD-ARG-INFO |LAP Operand IREF|
+            |SETF PCL FIND-CLASS| |LAP Operand ISHIFT| PERMUTATION-P
+            SLOT-WRITER-UNDEFINED COMPUTE-APPLICABLE-METHODS-FUNCTION
+            WALKER::VARIABLE-SYMBOL-MACRO-P USER-INSTANCE-ACCESS
+            QUALIFIER-CHECK-RUNTIME |LAP Operand ILOGAND|
             MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE
-            MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL COMPUTE-STD-CPL
-            MAKE-DFUN-LAMBDA-LIST MAKE-DLAP-LAMBDA-LIST
-            CPL-INCONSISTENT-ERROR SET-WRAPPER SET-SLOTS
-            PV-WRAPPERS-FROM-ALL-WRAPPERS COMPUTE-INITARG-POSITIONS
-            ISL-LOOKUP ADD-METHOD CPL-FORWARD-REFERENCED-CLASS-ERROR
-            GET-BOUNDP-FUNCTION1 MAKE-ISL-INTERNAL FIND-SLOT-DEFINITION
-            STANDARD-INSTANCE-ACCESS
-            FUNCALLABLE-STANDARD-INSTANCE-ACCESS LOOKUP-PV
-            |SETF PCL METHOD-FUNCTION-PLIST| VARIABLE-LEXICAL-P
-            VARIABLE-SPECIAL-P |SETF PCL GDEFINITION|
-            SET-FUNCALLABLE-INSTANCE-FUNCTION
-            PRINTING-RANDOM-THING-INTERNAL
-            LOAD-DEFINE-CONSTRUCTOR-CODE-TYPE
-            SYSTEM:%SET-COMPILED-FUNCTION-NAME
-            ALLOCATE-FUNCALLABLE-INSTANCE MAKE-INDEX-MASK MAKE-PLIST
-            REMTAIL DESTRUCTURE-INTERNAL MAKE-PV-FN-FORM MAKE-CAXR
-            MAKE-CDXR FDEFINE-CAREFULLY SET-FUNCTION-PRETTY-ARGLIST
-            DOCTOR-DFUN-FOR-THE-DEBUGGER DO-SATISFIES-DEFTYPE
-            CANONICALIZE-SLOT-SPECIFICATION LOAD-DEFOPCODE
-            CANONICALIZE-DEFCLASS-OPTION EARLY-SORT-METHODS
-            LOAD-DEFOPERAND REAL-ADD-METHOD BOOTSTRAP-SLOT-INDEX
-            |SETF PCL FIND-CLASS| CLASS-CAN-PRECEDE-P
-            PROCLAIM-DEFGENERIC)) 
+            MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL
+            MAKE-OPTIMIZED-USER-READER-METHOD-FUNCTION
+            FIND-SLOT-DEFINITION CANONICALIZE-SLOT-SPECIFICATION
+            ITERATE::SIMPLE-EXPAND-ITERATE-FORM FOUND-UNKNOWN-CLASS
+            CANONICALIZE-DEFCLASS-OPTION ITERATE::MV-SETQ
+            ITERATE::EXTRACT-SPECIAL-BINDINGS N-N-DFUN-INFO
+            MEC-ALL-CLASSES-INTERNAL AUGMENT-TYPE WRAPPER-STATE-TRAP
+            SET-WRAPPER |LAP Opcode USER-INSTANCE-P|
+            SET-USER-INSTANCE-WRAPPER REMOVE-DIRECT-SUBCLASSES
+            SET-USER-INSTANCE-SLOTS FDEFINE-CAREFULLY
+            |SETF PCL METHOD-FUNCTION-PLIST| MAKE-PLIST
+            REMOVE-SLOT-ACCESSORS CLASS-MIGHT-PRECEDE-P
+            WALKER::NOTE-DECLARATION DOCTOR-DFUN-FOR-THE-DEBUGGER
+            SET-STANDARD-SVUC-METHOD LOAD-DEFOPERAND REDEFINE-MACRO
+            DOCUMENTED-FUNCTION-RETURNING-NIL |LAP Operand I+|
+            COMPUTE-INITARG-POSITIONS
+            COMPUTE-SECONDARY-DISPATCH-FUNCTION1
+            NEW-ARG-INFO-FROM-METHOD SET-GET-METHOD-FROM-IDENTIFIER
+            TREE-MEMQ-P MEC-ALL-CLASS-LISTS |SETF PCL GDEFINITION|
+            REAL-ADD-METHOD MAKE-DLAP-LAMBDA-LIST
+            FUNCALLABLE-STANDARD-INSTANCE-ACCESS CPL-INCONSISTENT-ERROR
+            REAL-REMOVE-METHOD EARLY-SORT-METHODS COMPUTE-CONSTANTS
+            REMTAIL RAISE-METATYPE CLASS-ON-CLASS-PRECEDENCE-LIST-P
+            ADD-DIRECT-SUBCLASSES ADD-SLOT-ACCESSORS
+            CLASS-CAN-PRECEDE-P REMOVE-ARG-INFO VARIABLE-LEXICAL-P
+            |LAP Operand CREF| VARIABLE-SPECIAL-P COMPUTE-STD-CPL
+            DO-SATISFIES-DEFTYPE |LAP Operand ILOGXOR|
+            WALKER::NOTE-LEXICAL-BINDING
+            ACCESSOR-METHODS-SAFE-TO-USE-SLOT-WRAPPER-OPTIMIZATIONS-P
+            |LAP Opcode STD-INSTANCE-P| LIST-EQ
+            SET-FUNCALLABLE-INSTANCE-FUNCTION VALUE-FOR-CACHING
+            MEC-ALL-CLASSES SAUT-NOT-CLASS-P SAUT-NOT-CLASS-EQ-P
+            SET-FUNCTION-PRETTY-ARGLIST REDEFINE-FUNCTION
+            SET-STRUCTURE-SVUC-METHOD SAUT-NOT-EQL-P NPERMUTATION-P
+            DEAL-WITH-ARGUMENTS-OPTION UPDATE-SLOT-VALUE-GF-INFO
+            UPDATE-CPL PRINTING-RANDOM-THING-INTERNAL
+            CPL-FORWARD-REFERENCED-CLASS-ERROR CHECKING-DFUN-INFO
+            SLOW-SLOT-BOUNDP STANDARD-INSTANCE-ACCESS
+            UPDATE-STD-OR-STR-METHODS DESTRUCTURE-INTERNAL
+            WALKER::WALK-REPEAT-EVAL SYSTEM:%SET-COMPILED-FUNCTION-NAME
+            MAKE-DISCRIMINATING-FUNCTION-ARGLIST
+            |SETF PCL FIND-CLASS-PREDICATE| MAKE-UNORDERED-METHODS-EMF
+            SLOT-VALUES-SAFE-USING-CLASS-P
+            DOCUMENTED-FUNCTION-RETURNING-T PROCLAIM-DEFGENERIC
+            ADD-METHOD)) 
 (PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) GET-WRAPPER-CACHE-NUMBER)) 
 (IN-PACKAGE "PCL")
 
-(DOLIST (V '(REMOVE-DIRECT-SUBCLASS |(BOUNDP NO-OF-INSTANCE-SLOTS)|
-                CLASS-DIRECT-SUPERCLASSES CLASS-DIRECT-SUBCLASSES
+(DOLIST (V '(COMPUTE-INSTANCE-LAYOUT |(WRITER DIRECT-DEFAULT-INITARGS)|
                 ADD-READER-METHOD
                 SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT
+                SLOT-DEFINITION-INITFUNCTION-SIDE-EFFECT-FREE-P
                 |DEFINITION-SOURCE-MIXIN class predicate|
-                REMOVE-READER-METHOD METHOD-FUNCTION EQL-SPECIALIZER-P
-                |(SETF GENERIC-FUNCTION-NAME)| OBJECT-PLIST
-                METHOD-LAMBDA-LIST
-                SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL
-                SPECIALIZER-TYPE GF-DFUN-STATE
-                |(SETF GENERIC-FUNCTION-METHOD-CLASS)|
+                REMOVE-READER-METHOD |(WRITER INTERNAL-SLOTDS)|
+                CLASS-FROM-DEFCLASS-P MAKE-CLOSURE-GENERATOR-FORM
+                EQL-SPECIALIZER-P |(SETF GENERIC-FUNCTION-NAME)|
+                OBJECT-PLIST SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL
+                METHOD-IDENTIFIER
+                MAKE-DOCUMENTED-BOUNDP-METHOD-FUNCTION
+                MAKE-DOCUMENTED-READER-METHOD-FUNCTION
+                MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION SPECIALIZER-TYPE
+                GF-DFUN-STATE |(SETF GENERIC-FUNCTION-METHOD-CLASS)|
                 |(SETF GENERIC-FUNCTION-METHOD-COMBINATION)|
-                CLASS-DEFAULT-INITARGS SLOT-DEFINITION-INITARGS
-                CLASS-DEFSTRUCT-CONSTRUCTOR
-                |(SETF GENERIC-FUNCTION-METHODS)| ADD-DIRECT-METHOD
-                |(SETF GF-PRETTY-ARGLIST)| SPECIALIZERP
+                CLASS-DEFSTRUCT-CONSTRUCTOR DEPENDENT
+                |(SETF GENERIC-FUNCTION-METHODS)| TRACE-METHOD
+                STORE-CLOSURE-GENERATOR-P |(SETF GF-PRETTY-ARGLIST)|
+                METHOD-OPTIMIZED-FUNCTION SPECIALIZERP
                 EXACT-CLASS-SPECIALIZER-P
                 |STANDARD-OBJECT class predicate|
                 COMPATIBLE-META-CLASS-CHANGE-P
-                ENSURE-GENERIC-FUNCTION-USING-CLASS
                 |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)|
-                |(BOUNDP READERS)|
-                |STANDARD-METHOD-COMBINATION class predicate|
-                SPECIALIZER-DIRECT-METHODS UPDATE-GF-DFUN
+                |(BOUNDP READERS)| UPDATE-GF-DFUN
+                |(BOUNDP DEFSTRUCT-CONC-NAME)|
                 |(BOUNDP CLASS-PRECEDENCE-LIST)|
                 |(BOUNDP ACCESSOR-FLAGS)|
                 |STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate|
-                CONSTRUCTOR-SUPPLIED-INITARG-NAMES
-                |(BOUNDP DOCUMENTATION)| |(BOUNDP LOCATION)|
-                SPECIALIZER-OBJECT METHOD-SPECIALIZERS
-                CLASS-FINALIZED-P
+                CONSTRUCTOR-SUPPLIED-INITARG-NAMES |(BOUNDP LOCATION)|
+                |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT
+                |(BOUNDP CACHED-FUNCTIONS-ALIST)|
                 |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)|
-                |(BOUNDP CODE-TYPE)| ACCESSOR-METHOD-SLOT-NAME
+                ACCESSOR-METHOD-SLOT-NAME |(BOUNDP DECLARATIONS)|
+                |(BOUNDP CACHED-IN-GENERIC-FUNCTIONS)|
                 |(BOUNDP SPECIALIZERS)|
-                |(BOUNDP IDENTITY-WITH-ONE-ARGUMENT)|
                 |STANDARD-DIRECT-SLOT-DEFINITION class predicate|
-                |(BOUNDP CODE-GENERATORS)| SPECIALIZER-CLASS
-                |(BOUNDP PRETTY-ARGLIST)| |(BOUNDP DEFSTRUCT-FORM)|
+                |(BOUNDP IDENTIFIER)| SPECIALIZER-CLASS
+                |(BOUNDP PRETTY-ARGLIST)|
                 |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)|
-                CLASS-EQ-SPECIALIZER-P ENSURE-CLASS-USING-CLASS
+                CLASS-EQ-SPECIALIZER-P |(BOUNDP NEEDS-NEXT-METHODS-P)|
                 SLOTS-FETCHER |(SETF SLOT-ACCESSOR-STD-P)|
+                |(BOUNDP INITFUNCTION-SIDE-EFFECT-FREE-P)|
                 |STANDARD-SLOT-DEFINITION class predicate|
-                REMOVE-WRITER-METHOD |(BOUNDP INITFUNCTION)|
-                |(BOUNDP WRITER-FUNCTION)| STRUCTURE-CLASS-P
+                REMOVE-WRITER-METHOD |(BOUNDP WRITER-FUNCTION)|
+                |(BOUNDP INITFUNCTION)| STRUCTURE-CLASS-P
                 |(BOUNDP WRITERS)| |(BOUNDP INITFORM)|
-                GENERIC-FUNCTION-NAME |(BOUNDP FUNCTION-NAME)|
-                UPDATE-CONSTRUCTORS ADD-DIRECT-SUBCLASS
-                |(BOUNDP SLOT-NAME)| |(SETF SLOT-DEFINITION-INITARGS)|
-                |(BOUNDP ALLOCATION)| DOCUMENTATION |(BOUNDP FUNCTION)|
+                |(BOUNDP FUNCTION-NAME)| UPDATE-CONSTRUCTORS
+                |(BOUNDP SLOT-NAME)| BOUNDP-METHOD-CLASS COMPUTE-LAYOUT
+                |(SETF SLOT-DEFINITION-INITARGS)| |(BOUNDP ALLOCATION)|
+                CACHED-SLOT-LOCATIONS-AND-FETCHERS-FROM-WRAPPERS
+                DOCUMENTATION |(BOUNDP FUNCTION)|
                 |(BOUNDP GENERIC-FUNCTION)|
                 |SLOT-OBJECT class predicate| |(BOUNDP LAMBDA-LIST)|
-                METHOD-PRETTY-ARGLIST |RATIONAL class predicate|
-                |(BOUNDP CAN-PRECEDE-LIST)| |(BOUNDP PROTOTYPE)|
-                CLASS-EQ-SPECIALIZER INFORM-TYPE-SYSTEM-ABOUT-CLASS
+                METHOD-PRETTY-ARGLIST |(BOUNDP CAN-PRECEDE-LIST)|
+                |(BOUNDP PROTOTYPE)| CLASS-EQ-SPECIALIZER
+                INFORM-TYPE-SYSTEM-ABOUT-CLASS
                 |PCL-CLASS class predicate| |(BOUNDP DFUN-STATE)|
-                |(BOUNDP FROM-DEFCLASS-P)| |(READER METHOD)|
-                |(BOUNDP SUPPLIED-INITARG-NAMES)|
-                CLASS-NO-OF-INSTANCE-SLOTS |(BOUNDP METHOD-CLASS)|
-                |(READER SOURCE)| |(BOUNDP METHOD-COMBINATION)|
-                |(BOUNDP INTERNAL-READER-FUNCTION)|
+                |(BOUNDP FROM-DEFCLASS-P)| |(BOUNDP INTERNAL-SLOTD)|
+                |(BOUNDP METHOD-CLASS)| |(READER SOURCE)|
+                |(BOUNDP METHOD-COMBINATION)|
+                |(BOUNDP OPTIMIZED-FUNCTION)|
                 |(BOUNDP INTERNAL-WRITER-FUNCTION)|
+                |(BOUNDP INTERNAL-READER-FUNCTION)|
+                |(BOUNDP OPTIMIZED-SLOT-INDICES)|
                 |(BOUNDP DIRECT-METHODS)| |(BOUNDP DIRECT-SLOTS)|
-                GENERIC-FUNCTION-METHOD-COMBINATION
-                GENERIC-FUNCTION-METHODS |(BOUNDP BOUNDP-FUNCTION)|
+                |(BOUNDP BOUNDP-FUNCTION)|
                 |(BOUNDP DIRECT-SUPERCLASSES)|
-                |(BOUNDP DIRECT-SUBCLASSES)| ADD-DEPENDENT
-                SLOT-VALUE-USING-CLASS |(BOUNDP OPTIONS)|
-                |(BOUNDP METHODS)| CLASS-PROTOTYPE
-                DIRECT-SLOT-DEFINITION-CLASS |(WRITER METHOD)|
-                GENERIC-FUNCTION-METHOD-CLASS
-                |(READER NO-OF-INSTANCE-SLOTS)|
-                GENERIC-FUNCTION-LAMBDA-LIST
-                GENERIC-FUNCTION-PRETTY-ARGLIST
+                |(BOUNDP DIRECT-SUBCLASSES)| ADD-CACHED-FUNCTION
+                |(BOUNDP METHODS)| |(BOUNDP OPTIONS)|
+                GET-CACHED-FUNCTION GENERIC-FUNCTION-PRETTY-ARGLIST
                 MAKE-CONSTRUCTOR-CODE-GENERATORS |(WRITER SOURCE)|
-                MAKE-BOUNDP-METHOD-FUNCTION
+                UPDATE-SLOT-ACCESSOR-FUNCTION
                 |SLOT-DEFINITION class predicate|
-                |METAOBJECT class predicate| FINALIZE-INHERITANCE
-                |(WRITER NO-OF-INSTANCE-SLOTS)| CLASS-PREDICATE-NAME
-                |SEQUENCE class predicate| LOAD-CONSTRUCTOR-INTERNAL
-                COMPUTE-EFFECTIVE-METHOD CLASSP
-                |CHARACTER class predicate|
-                |CONSTRUCTOR class predicate| |COMPLEX class predicate|
-                |STD-CLASS class predicate| LEGAL-QUALIFIERS-P
+                |(METHOD NO-NEXT-METHOD (STANDARD-GENERIC-FUNCTION STANDARD-METHOD))|
+                MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION
+                MAKE-OPTIMIZED-READER-METHOD-FUNCTION
+                MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION
+                |METAOBJECT class predicate| CLASS-PREDICATE-NAME
+                LOAD-CONSTRUCTOR-INTERNAL DESCRIBE-OBJECT-SLOTS
+                STORE-OPTIMIZED-METHOD-LAMBDA-P COPY-INSTANCE-SLOTS
+                CLASSP |STD-CLASS class predicate| LEGAL-QUALIFIERS-P
                 ADD-BOUNDP-METHOD LEGAL-LAMBDA-LIST-P
-                SLOT-MAKUNBOUND-USING-CLASS
                 |SETF PCL GENERIC-FUNCTION-NAME|
-                |SETF PCL METHOD-FUNCTION-NAME|
+                |SETF PCL METHOD-FUNCTION-NAME| LEGAL-DECLARATIONS-P
                 |DEPENDENT-UPDATE-MIXIN class predicate|
                 |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)|
-                |(READER READERS)| DESCRIBE-OBJECT
-                |(READER CLASS-PRECEDENCE-LIST)| CLASS-PRECEDENCE-LIST
-                |(READER ACCESSOR-FLAGS)| |(READER DOCUMENTATION)|
-                |(READER LOCATION)| |(SETF CLASS-SLOT-VALUE)|
-                MAKE-WRITER-METHOD-FUNCTION |SETF PCL GF-DFUN-STATE|
+                |(READER READERS)| |(READER DEFSTRUCT-CONC-NAME)|
+                |(READER CLASS-PRECEDENCE-LIST)|
+                |(READER ACCESSOR-FLAGS)| |(READER LOCATION)|
+                |(READER DOCUMENTATION)| |(SETF CLASS-SLOT-VALUE)|
+                |SETF PCL GF-DFUN-STATE|
+                |(READER CACHED-FUNCTIONS-ALIST)|
                 |(READER INCOMPATIBLE-SUPERCLASS-LIST)|
-                |(READER CODE-TYPE)|
-                |LONG-METHOD-COMBINATION class predicate|
-                |(READER SPECIALIZERS)|
-                |(READER IDENTITY-WITH-ONE-ARGUMENT)|
-                COMPUTE-EFFECTIVE-SLOT-DEFINITION
-                |VECTOR class predicate| SLOT-BOUNDP-USING-CLASS
-                |(READER CODE-GENERATORS)|
-                COMPUTE-CLASS-PRECEDENCE-LIST |(READER PRETTY-ARGLIST)|
-                |(READER DEFSTRUCT-FORM)|
+                |(READER DECLARATIONS)|
+                |(READER CACHED-IN-GENERIC-FUNCTIONS)|
+                |(READER SPECIALIZERS)| COMPUTE-CLASS-SLOTS
+                |(READER IDENTIFIER)| |(READER PRETTY-ARGLIST)|
+                |(READER NEEDS-NEXT-METHODS-P)|
                 |SETF PCL SLOT-DEFINITION-NAME| |SETF PCL CLASS-NAME|
+                |SETF PCL SLOT-DEFINITION-INTERNAL-SLOTD|
                 |(WRITER READER-FUNCTION)|
-                |(SETF CLASS-DEFSTRUCT-CONSTRUCTOR)|
+                |(METHOD TRACE-METHOD (STANDARD-METHOD))|
+                |(METHOD TRACE-METHOD (TRACED-METHOD))|
+                |(METHOD READER-METHOD-CLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))|
+                |(METHOD READER-METHOD-CLASS (STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))|
                 |(METHOD CHANGE-CLASS (T SYMBOL))|
                 |(WRITER PREDICATE-NAME)| |(WRITER READERS)|
-                |(METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
+                |(READER INITFUNCTION-SIDE-EFFECT-FREE-P)|
                 |(METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))|
-                |(METHOD WRAPPER-FETCHER (STANDARD-CLASS))|
-                |(METHOD CLASS-FINALIZED-P (PCL-CLASS))|
-                |(METHOD CLASS-PROTOTYPE (STD-CLASS))|
+                |(METHOD WRAPPER-FETCHER (STRUCTURE-CLASS))|
+                |(METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
                 |(METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))|
-                |(METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))|
-                |(METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))|
-                |(METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))|
-                |(METHOD CLASS-SLOT-CELLS (STD-CLASS))|
-                |(METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))|
                 |(METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))|
-                |(METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))|
-                |(METHOD CLASS-SLOTS (BUILT-IN-CLASS))|
-                |(METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))|
-                |(METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))|
-                |(READER INITFUNCTION)| |(READER WRITER-FUNCTION)|
+                |(METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))|
+                |(METHOD CLASS-SLOT-CELLS (STD-CLASS))|
+                |(METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))|
+                |(METHOD CLASS-PROTOTYPE (STD-CLASS))|
+                |(METHOD WRAPPER-FETCHER (STANDARD-CLASS))|
+                |(READER WRITER-FUNCTION)| |(READER INITFUNCTION)|
                 |(METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))|
                 INITIALIZE-INTERNAL-SLOT-FUNCTIONS
+                |(WRITER DEFSTRUCT-CONC-NAME)|
                 |SETF PCL SLOT-DEFINITION-TYPE|
                 |(SETF METHOD-FUNCTION-NAME)| |(READER WRITERS)|
                 |(WRITER CLASS-PRECEDENCE-LIST)|
                 |(WRITER ACCESSOR-FLAGS)| |(READER INITFORM)|
                 METHOD-COMBINATION-P
-                |(METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))|
                 |(METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))|
-                |(WRITER DOCUMENTATION)| |(WRITER LOCATION)|
+                |(METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))|
+                |(WRITER LOCATION)| |(WRITER DOCUMENTATION)|
                 |STRUCTURE-DIRECT-SLOT-DEFINITION class predicate|
+                |(METHOD ACCESSOR-METHOD-SLOT-DEFINITION (STANDARD-ACCESSOR-METHOD))|
                 |(METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))|
-                |(METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))|
                 |(READER FUNCTION-NAME)|
                 |(METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))|
-                |(METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))|
                 |(METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))|
+                |(METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))|
                 |STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate|
                 |(METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))|
                 |SETF PCL GENERIC-FUNCTION-METHODS|
                 |SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION|
                 |SETF PCL METHOD-GENERIC-FUNCTION|
+                |SETF PCL METHOD-OPTIMIZED-FUNCTION|
                 |(METHOD ADD-CONSTRUCTOR (SLOT-CLASS CONSTRUCTOR))|
-                |(METHOD ADD-DIRECT-METHOD (CLASS METHOD))|
                 |(METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|
-                |(READER SLOT-NAME)|
+                |(METHOD ADD-DIRECT-METHOD (CLASS METHOD))|
+                |(READER SLOT-NAME)| |(WRITER CACHED-FUNCTIONS-ALIST)|
                 |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)|
-                |SETF PCL SLOT-ACCESSOR-STD-P| |(WRITER CODE-TYPE)|
-                |(METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))|
-                |(METHOD UPDATE-CONSTRUCTORS (SLOT-CLASS))|
+                |SETF PCL SLOT-ACCESSOR-STD-P|
                 |(METHOD UPDATE-CONSTRUCTORS (CLASS))|
+                |(METHOD UPDATE-CONSTRUCTORS (SLOT-CLASS))|
+                |(METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))|
                 |(READER ALLOCATION)|
+                |(METHOD (SETF SLOT-DEFINITION-LOCATION) :AFTER (T STANDARD-EFFECTIVE-SLOT-DEFINITION))|
+                |(METHOD (SETF SLOT-DEFINITION-BOUNDP-FUNCTION) :AFTER (T EFFECTIVE-SLOT-DEFINITION))|
+                |(METHOD (SETF SLOT-DEFINITION-WRITER-FUNCTION) :AFTER (T EFFECTIVE-SLOT-DEFINITION))|
+                |(METHOD (SETF SLOT-DEFINITION-READER-FUNCTION) :AFTER (T EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD (SETF SLOT-VALUE-USING-CLASS) (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD (SETF SLOT-VALUE-USING-CLASS) (T STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
-                |(METHOD (SETF SLOT-DEFINITION-LOCATION) :AFTER (T STANDARD-EFFECTIVE-SLOT-DEFINITION))|
-                |(METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))|
                 |SETF PCL CONSTRUCTOR-CODE-TYPE|
+                |(WRITER DECLARATIONS)|
+                |(WRITER CACHED-IN-GENERIC-FUNCTIONS)|
                 |(WRITER SPECIALIZERS)|
-                |(WRITER IDENTITY-WITH-ONE-ARGUMENT)|
                 |(METHOD SPECIALIZER-CLASS (CLASS))|
-                |(METHOD SPECIALIZER-DIRECT-METHODS (CLASS))|
                 |(METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))|
-                |(SETF METHOD-GENERIC-FUNCTION)|
-                |(WRITER CODE-GENERATORS)| |(WRITER PRETTY-ARGLIST)|
-                LEGAL-SPECIALIZERS-P |SETF PCL OBJECT-PLIST|
-                |(WRITER DEFSTRUCT-FORM)|
-                |(METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))|
+                |(METHOD SPECIALIZER-DIRECT-METHODS (CLASS))|
+                |(METHOD (SETF CLASS-NAME) (T STD-CLASS))|
+                |(WRITER IDENTIFIER)| |(SETF METHOD-GENERIC-FUNCTION)|
+                |(SETF METHOD-OPTIMIZED-FUNCTION)|
+                |(WRITER PRETTY-ARGLIST)| LEGAL-SPECIALIZERS-P
+                |SETF PCL OBJECT-PLIST|
                 |(METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))|
+                |(METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))|
                 |(READER FUNCTION)| |(READER GENERIC-FUNCTION)|
-                |(READER LAMBDA-LIST)| |SLOT-CLASS class predicate|
+                |(WRITER NEEDS-NEXT-METHODS-P)| |(READER LAMBDA-LIST)|
+                INITIALIZE-ALLOCATE-STATIC-SLOT-STORAGE-COPY
+                |SLOT-CLASS class predicate|
                 |SETF PCL SLOT-DEFINITION-INITFORM|
-                |SETF PCL CLASS-DEFSTRUCT-FORM|
+                |(SETF METHOD-CACHED-FUNCTIONS)|
                 |(READER CAN-PRECEDE-LIST)|
                 |SETF PCL GENERIC-FUNCTION-METHOD-CLASS|
-                |(READER PROTOTYPE)| |(WRITER INITFUNCTION)|
-                |(WRITER WRITER-FUNCTION)|
+                |(WRITER INITFUNCTION-SIDE-EFFECT-FREE-P)|
+                |(READER PROTOTYPE)| |(WRITER WRITER-FUNCTION)|
+                |(WRITER INITFUNCTION)|
                 |(METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|
                 |(METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|
+                |(METHOD WRITER-METHOD-CLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))|
+                |(METHOD WRITER-METHOD-CLASS (STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))|
                 |(METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))|
+                |(METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS :AFTER (STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
+                |(METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS :AFTER (STANDARD-EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS (EFFECTIVE-SLOT-DEFINITION))|
                 |(WRITER WRITERS)| SLOT-ACCESSOR-STD-P
-                |(WRITER INITFORM)|
+                CLASS-INTERNAL-SLOTDS |(WRITER INITFORM)|
+                |(METHOD REINITIALIZE-INSTANCE :AFTER (STRUCTURE-CLASS))|
+                |(METHOD INITIALIZE-ALLOCATE-STATIC-SLOT-STORAGE-COPY (STD-CLASS))|
+                |(METHOD REINITIALIZE-INSTANCE :AFTER (STD-CLASS))|
                 |(METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))|
-                |(METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))|
-                |(READER DFUN-STATE)| |(WRITER FUNCTION-NAME)|
+                |(WRITER FUNCTION-NAME)| |(READER DFUN-STATE)|
                 |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST|
-                |(READER SUPPLIED-INITARG-NAMES)|
+                OPTIMIZE-INSTANCE-ACCESS
                 |SETF PCL SLOT-DEFINITION-LOCATION|
                 |SETF PCL SLOT-DEFINITION-READER-FUNCTION|
                 |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION|
@@ -667,58 +761,65 @@
                 |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION|
                 |SETF PCL SLOT-DEFINITION-ALLOCATION|
                 |SETF PCL SLOT-DEFINITION-INITFUNCTION|
-                |SETF PCL SLOT-ACCESSOR-FUNCTION|
-                |(METHOD MAKE-INSTANCE (SYMBOL))|
                 |(METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))|
-                |(WRITER SLOT-NAME)| |(BOUNDP NAME)|
+                |(METHOD MAKE-INSTANCE (SYMBOL))| |(WRITER SLOT-NAME)|
+                |(BOUNDP NAME)|
                 |(METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))|
                 |(METHOD SAME-SPECIALIZER-P (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))|
                 |(METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))|
-                COMPUTE-DISCRIMINATING-FUNCTION
-                |(METHOD MAKE-INSTANCE (SLOT-CLASS))|
+                |(READER INTERNAL-SLOTD)|
+                |(METHOD MAKE-DIRECT-SLOTD (STRUCTURE-CLASS))|
+                |(METHOD MAKE-CLASS-PROTOTYPE (STRUCTURE-CLASS))|
                 |(METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))|
-                |(WRITER ALLOCATION)| |(READER METHOD-CLASS)|
+                |(METHOD MAKE-DIRECT-SLOTD (STD-CLASS))|
+                |(METHOD MAKE-CLASS-PROTOTYPE (STD-CLASS))|
+                |(METHOD MAKE-INSTANCE (SLOT-CLASS))|
+                |(WRITER ALLOCATION)| CACHED-FUNCTIONS
+                |(READER METHOD-CLASS)| |(SETF OBJECT-PLIST)|
                 |(METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))|
                 |(METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))|
                 |(METHOD VALIDATE-SUPERCLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))|
-                |(SETF OBJECT-PLIST)|
-                |(METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))|
-                |(METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))|
-                |(METHOD VALIDATE-SUPERCLASS (CLASS CLASS))|
-                |(METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))|
                 |(METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))|
+                |(METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))|
+                |(METHOD VALIDATE-SUPERCLASS (CLASS CLASS))|
+                |(METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))|
+                |(METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))|
                 |(READER METHOD-COMBINATION)|
-                |(READER INTERNAL-READER-FUNCTION)|
+                |(READER OPTIMIZED-FUNCTION)|
                 |(READER INTERNAL-WRITER-FUNCTION)|
+                |(READER INTERNAL-READER-FUNCTION)|
                 METHOD-COMBINATION-OPTIONS
+                |(READER OPTIMIZED-SLOT-INDICES)|
                 |(METHOD COMPUTE-CONSTRUCTOR-CODE (SLOT-CLASS CONSTRUCTOR))|
                 |(METHOD REMOVE-CONSTRUCTOR (SLOT-CLASS CONSTRUCTOR))|
                 |(METHOD COMPUTE-DISCRIMINATING-FUNCTION (STANDARD-GENERIC-FUNCTION))|
                 |(METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO (STANDARD-GENERIC-FUNCTION))|
-                |(METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))|
                 |(METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|
+                |(METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))|
                 |(READER DIRECT-METHODS)| |(READER DIRECT-SLOTS)|
                 |SETF PCL SLOT-DEFINITION-READERS|
+                |(METHOD COPY-INSTANCE-SLOTS (SLOT-OBJECT SLOT-OBJECT))|
                 |(METHOD SAME-SPECIALIZER-P (CLASS CLASS))|
-                |(METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))|
-                |(METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))|
-                |(METHOD COMPUTE-SLOTS (STD-CLASS))|
-                |(METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))|
-                |(METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))|
-                |(METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))|
                 |(METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))|
+                |(METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))|
+                |(METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))|
+                |(METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))|
+                |(METHOD COMPUTE-SLOTS (STD-CLASS))|
+                |(METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))|
+                |(METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))|
                 |(WRITER FUNCTION)| |(WRITER GENERIC-FUNCTION)|
                 |STRUCTURE-OBJECT class predicate|
+                COMPILE-STRUCTURE-CLASS-INTERNALS
                 |(READER BOUNDP-FUNCTION)| |SETF PCL DOCUMENTATION|
                 |(READER DIRECT-SUPERCLASSES)|
                 |(READER DIRECT-SUBCLASSES)|
                 |(METHOD GENERIC-FUNCTION-PRETTY-ARGLIST (STANDARD-GENERIC-FUNCTION))|
                 |(METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))|
-                |(METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))|
                 |(SETF GF-VALID-P)| |(WRITER LAMBDA-LIST)|
                 FUNCALLABLE-STANDARD-CLASS-P |(BOUNDP CLASS)|
                 |(METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))|
                 |(METHOD FINALIZE-INHERITANCE (STD-CLASS))|
+                |(METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))|
                 |(METHOD SLOT-VALUE-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD SLOT-BOUNDP-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD SLOT-MAKUNBOUND-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
@@ -726,73 +827,82 @@
                 |(METHOD SLOT-VALUE-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD SLOT-BOUNDP-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
                 |(METHOD SLOT-MAKUNBOUND-USING-CLASS (STRUCTURE-CLASS STRUCTURE-OBJECT STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
-                |(METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))|
-                |(READER OPTIONS)| |(READER METHODS)|
+                |(READER METHODS)| |(READER OPTIONS)|
                 |(WRITER CAN-PRECEDE-LIST)|
                 |SETF PCL SLOT-DEFINITION-CLASS|
                 |SETF PCL SLOT-VALUE-USING-CLASS| |(WRITER PROTOTYPE)|
                 |(BOUNDP TYPE)| |(BOUNDP OBJECT)|
                 CLASS-CAN-PRECEDE-LIST
-                |SETF PCL CLASS-NO-OF-INSTANCE-SLOTS|
-                |SETF PCL CLASS-DIRECT-SLOTS| |SETF PCL CLASS-SLOTS|
+                |(METHOD SLOTS-FETCHER (STRUCTURE-CLASS))|
                 |(METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
                 |(METHOD SLOTS-FETCHER (STANDARD-CLASS))|
-                SLOT-ACCESSOR-FUNCTION |(BOUNDP PLIST)|
+                SLOT-ACCESSOR-FUNCTION METHOD-OPTIMIZED-METHOD-LAMBDA
+                METHOD-CONSTANT-VALUE |(BOUNDP PLIST)|
                 |SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST|
                 |SETF PCL SLOT-DEFINITION-WRITERS|
                 |(WRITER DFUN-STATE)| |(WRITER FROM-DEFCLASS-P)|
-                |(BOUNDP SLOTS)| |(WRITER SUPPLIED-INITARG-NAMES)|
+                |(BOUNDP SLOTS)|
                 |STRUCTURE-SLOT-DEFINITION class predicate|
-                MAKE-READER-METHOD-FUNCTION |STRING class predicate|
-                LEGAL-METHOD-FUNCTION-P CLASS-SLOTS
+                LEGAL-METHOD-FUNCTION-P |(WRITER INTERNAL-SLOTD)|
+                METHOD-CACHED-FUNCTIONS
                 |(METHOD INSTALL-LAZY-CONSTRUCTOR-INSTALLER (CONSTRUCTOR))|
-                |NUMBER class predicate| |(WRITER METHOD-CLASS)|
+                CLASS-DEFSTRUCT-CONC-NAME |(WRITER METHOD-CLASS)|
                 |(METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))|
-                |(WRITER METHOD-COMBINATION)| GET-METHOD
-                |(WRITER INTERNAL-READER-FUNCTION)|
+                GET-METHOD |(WRITER METHOD-COMBINATION)|
+                |(WRITER OPTIMIZED-FUNCTION)|
                 |(WRITER INTERNAL-WRITER-FUNCTION)|
+                |(WRITER INTERNAL-READER-FUNCTION)|
+                |(WRITER OPTIMIZED-SLOT-INDICES)|
                 |(METHOD METHOD-QUALIFIERS (TRACED-METHOD))|
                 |(METHOD METHOD-SPECIALIZERS (TRACED-METHOD))|
                 |(METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))|
                 |(METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))|
+                |(METHOD METHOD-CONSTANT-VALUE (STANDARD-METHOD))|
                 |(METHOD METHOD-QUALIFIERS (STANDARD-METHOD))|
                 |(METHOD METHOD-FUNCTION-FOR-CACHING-P (STANDARD-ACCESSOR-METHOD))|
                 |(METHOD METHOD-FUNCTION-FOR-CACHING-P (STANDARD-METHOD))|
+                |(METHOD METHOD-CACHED-FUNCTIONS (STANDARD-METHOD))|
                 |(WRITER DIRECT-METHODS)| |(WRITER DIRECT-SLOTS)|
-                SLOT-DEFINITION-NAME VALIDATE-SUPERCLASS
                 |(WRITER BOUNDP-FUNCTION)|
                 |(WRITER DIRECT-SUPERCLASSES)|
-                |(WRITER DIRECT-SUBCLASSES)| |(WRITER OPTIONS)|
-                |(WRITER METHODS)| SLOT-DEFINITION-TYPE
+                |(WRITER DIRECT-SUBCLASSES)|
+                SLOT-DEFINITION-INTERNAL-SLOTD
+                |(METHOD BOUNDP-METHOD-CLASS (FUNCALLABLE-STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))|
+                |(METHOD BOUNDP-METHOD-CLASS (STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION))|
+                |(WRITER METHODS)| |(WRITER OPTIONS)|
                 SHORT-METHOD-COMBINATION-P GF-ARG-INFO
-                CLASS-DIRECT-SLOTS
                 |(METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))|
                 |(METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))|
-                |SYMBOL class predicate| SPECIALIZER-METHOD-TABLE
+                SEQUENCEP SPECIALIZER-METHOD-TABLE
                 |(METHOD MAYBE-UPDATE-CONSTRUCTORS (GENERIC-FUNCTION METHOD))|
-                CLASS-DEFSTRUCT-FORM METHOD-CLOSURE-GENERATOR
-                REMOVE-CONSTRUCTOR SLOT-DEFINITION-INITFORM
+                METHOD-CLOSURE-GENERATOR REMOVE-CONSTRUCTOR
                 GF-PRETTY-ARGLIST SAME-SPECIALIZER-P CONSTRUCTOR-NAME
-                SLOT-DEFINITION-LOCATION
+                DO-DEFSTRUCT-FROM-DEFCLASS
                 SLOT-DEFINITION-BOUNDP-FUNCTION
                 SLOT-DEFINITION-WRITER-FUNCTION
                 SLOT-DEFINITION-READER-FUNCTION
                 SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION
                 SLOT-DEFINITION-INTERNAL-READER-FUNCTION
-                SLOT-DEFINITION-ALLOCATION SLOT-DEFINITION-INITFUNCTION
-                CONSTRUCTOR-CODE-TYPE SLOT-DEFINITION-READERS
-                ADD-CONSTRUCTOR SLOT-DEFINITION-CLASS GET-CONSTRUCTOR
-                EQL-SPECIALIZER-OBJECT SLOT-DEFINITION-WRITERS
-                |RATIO class predicate| CLASS-CONSTRUCTORS
-                |(BOUNDP WRAPPER)| SLOTS-TO-INSPECT
-                FIND-METHOD-COMBINATION
-                |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)|
+                CONSTRUCTOR-CODE-TYPE
+                MAKE-CACHED-METHOD-LAMBDA-FROM-STORED-LAMBDA
+                MAKE-CACHED-METHOD-FUNCTION-FROM-STORED-LAMBDA
+                METHOD-OPTIMIZED-SLOT-INDICES ADD-CONSTRUCTOR
+                SLOT-DEFINITION-CLASS GET-CONSTRUCTOR
+                EQL-SPECIALIZER-OBJECT CLASS-CONSTRUCTORS
+                STORE-METHOD-FUNCTION-P
+                STORE-METHOD-OPTIMIZED-FUNCTION-P |(BOUNDP WRAPPER)|
+                SLOTS-TO-INSPECT |(BOUNDP DEFSTRUCT-ACCESSOR-SYMBOL)|
                 SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
                 |(BOUNDP CLASS-EQ-SPECIALIZER)|
                 |(SETF SLOT-DEFINITION-NAME)| ADD-WRITER-METHOD
-                COMPUTE-SLOTS |(BOUNDP OPERATOR)| |(BOUNDP ARG-INFO)|
-                CONSTRUCTOR-CLASS |(SETF SLOT-DEFINITION-CLASS)|
+                |(BOUNDP ARGUMENT-PRECEDENCE-ORDER)|
+                |(BOUNDP SIDE-EFFECT-INTERNAL-SLOTDS)|
+                |(SETF SLOT-DEFINITION-INTERNAL-SLOTD)|
+                |(BOUNDP ARG-INFO)| CONSTRUCTOR-CLASS
+                |(SETF SLOT-DEFINITION-INITFUNCTION-SIDE-EFFECT-FREE-P)|
+                |(SETF SLOT-DEFINITION-CLASS)|
                 |(SETF SLOT-VALUE-USING-CLASS)|
+                |(BOUNDP DEFAULT-INITARGS)|
                 |(SETF SLOT-DEFINITION-ALLOCATION)|
                 |(SETF SLOT-DEFINITION-BOUNDP-FUNCTION)|
                 |(SETF SLOT-DEFINITION-INITFUNCTION)|
@@ -801,7 +911,6 @@
                 |(SETF SLOT-DEFINITION-LOCATION)|
                 |(SETF SLOT-DEFINITION-READER-FUNCTION)|
                 |(SETF SLOT-DEFINITION-WRITER-FUNCTION)|
-                |(SETF SLOT-ACCESSOR-FUNCTION)|
                 |(BOUNDP DEFSTRUCT-CONSTRUCTOR)|
                 |(SETF SLOT-DEFINITION-READERS)|
                 |(SETF SLOT-DEFINITION-WRITERS)|
@@ -809,66 +918,75 @@
                 CONSTRUCTOR-CODE-GENERATORS
                 |(SETF SLOT-DEFINITION-INITFORM)|
                 |EFFECTIVE-SLOT-DEFINITION class predicate|
-                |LIST class predicate| |(BOUNDP VALID-P)|
+                MAKE-CLASS-PROTOTYPE |(BOUNDP VALID-P)|
                 |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION
                 |BUILT-IN-CLASS class predicate| GENERIC-FUNCTION-P
-                |T class predicate| |FLOAT class predicate|
-                |(READER NAME)| |(BOUNDP CLOSURE-GENERATOR)|
-                MAP-DEPENDENTS |CONS class predicate| |(READER CLASS)|
-                LEGAL-SLOT-NAME-P |(READER TYPE)| |(READER OBJECT)|
+                MAKE-OPTIMIZED-METHOD-LAMBDA |(BOUNDP FINALIZED-P)|
+                |(BOUNDP OPTIMIZED-METHOD-LAMBDA)| |(READER NAME)|
+                |(BOUNDP CLOSURE-GENERATOR)| |(READER CLASS)|
+                |(BOUNDP DIRECT-DEFAULT-INITARGS)| LEGAL-SLOT-NAME-P
+                |(READER TYPE)| |(READER OBJECT)|
+                |(METHOD DO-DEFSTRUCT-FROM-DEFCLASS (STRUCTURE-CLASS T T T T T))|
                 CLASS-WRAPPER |(READER PLIST)| GF-VALID-P
                 |(METHOD NO-APPLICABLE-METHOD (T))| |(READER SLOTS)|
-                |ARRAY class predicate| |(WRITER NAME)|
-                DEFINITION-SOURCE DEFAULT-INITARGS
-                |NULL class predicate| |(WRITER CLASS)|
+                |(BOUNDP INTERNAL-SLOTDS)| |(WRITER NAME)|
+                DEFINITION-SOURCE DEFAULT-INITARGS |(WRITER CLASS)|
                 CLASS-SLOT-VALUE |(WRITER TYPE)| |(WRITER OBJECT)|
                 |(WRITER PLIST)| |(WRITER SLOTS)|
                 FORWARD-REFERENCED-CLASS-P
+                CLASS-SIDE-EFFECT-INTERNAL-SLOTDS
                 |SPECIALIZER-WITH-OBJECT class predicate|
                 LEGAL-QUALIFIER-P METHOD-P
-                |PLIST-MIXIN class predicate| CLASS-SLOT-CELLS
-                COMPUTE-CONSTRUCTOR-CODE
+                |PLIST-MIXIN class predicate| MAKE-DIRECT-SLOTD
+                CLASS-SLOT-CELLS COMPUTE-CONSTRUCTOR-CODE
                 |(METHOD LOAD-CONSTRUCTOR-INTERNAL (SLOT-CLASS T T T))|
+                |(METHOD SHARED-INITIALIZE :AFTER (STANDARD-GENERIC-FUNCTION T))|
                 |(METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|
+                |(METHOD READER-METHOD-CLASS (SLOT-CLASS T))|
                 |(METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))|
                 |(METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))|
                 |(METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))|
                 |(METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))|
                 |(METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))|
-                |(METHOD CLASS-SLOT-VALUE (STD-CLASS T))|
-                |(METHOD SHARED-INITIALIZE (SLOT-OBJECT T))|
-                |(METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))|
-                |(METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))|
-                |(METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))|
-                |(METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))|
-                |(METHOD SHARED-INITIALIZE :BEFORE (CLASS T))|
                 |(METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))|
                 |(METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))|
+                |(METHOD READER-METHOD-CLASS (T T))|
+                |(METHOD SHARED-INITIALIZE :BEFORE (CLASS T))|
+                |(METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))|
+                |(METHOD SHARED-INITIALIZE :BEFORE (STD-CLASS T))|
+                |(METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))|
+                |(METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))|
+                |(METHOD SHARED-INITIALIZE :BEFORE (DOCUMENTATION-MIXIN T))|
+                |(METHOD SHARED-INITIALIZE (SLOT-OBJECT T))|
+                |(METHOD CLASS-SLOT-VALUE (STD-CLASS T))|
                 STANDARD-ACCESSOR-METHOD-P |(SETF CLASS-NAME)|
+                |(METHOD CACHED-SLOT-LOCATIONS-AND-FETCHERS-FROM-WRAPPERS (STANDARD-METHOD T))|
                 |(METHOD UPDATE-GF-DFUN (STD-CLASS T))|
-                |(METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))|
-                |(METHOD ADD-READER-METHOD (SLOT-CLASS T T))|
-                |(METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))|
-                |(METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))|
+                |(METHOD ADD-CACHED-FUNCTION (STANDARD-METHOD T T))|
                 |(METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|
+                |(METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))|
+                |(METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))|
+                |(METHOD ADD-READER-METHOD (SLOT-CLASS T T))|
+                |(METHOD UPDATE-SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T T))|
+                |(METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS (STANDARD-OBJECT T T T))|
                 STANDARD-GENERIC-FUNCTION-P STANDARD-METHOD-P
                 STANDARD-READER-METHOD-P |(METHOD DOCUMENTATION (T))|
                 |(READER WRAPPER)|
-                |(METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))|
-                |(METHOD (SETF SLOT-ACCESSOR-FUNCTION) (T EFFECTIVE-SLOT-DEFINITION T))|
-                |(METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))|
                 |(METHOD (SETF DOCUMENTATION) (T T))|
-                |SETF PCL GF-VALID-P| |TRACED-METHOD class predicate|
-                SLOT-EXISTS-P-USING-CLASS
+                |(METHOD (SETF SLOT-ACCESSOR-STD-P) (T EFFECTIVE-SLOT-DEFINITION T))|
+                |(METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))|
+                |SETF PCL GF-VALID-P|
                 |(READER DEFSTRUCT-ACCESSOR-SYMBOL)|
                 |(METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))|
-                |(METHOD DEFAULT-INITARGS (SLOT-CLASS T))|
-                |(METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))|
                 |(METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|
                 |(METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))|
+                |(METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))|
+                |(METHOD DEFAULT-INITARGS (SLOT-CLASS T T))|
                 |(READER CLASS-EQ-SPECIALIZER)|
                 COMPUTE-DEFAULT-INITARGS
                 COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS
+                |(METHOD LEGAL-LAMBDA-LIST-P (STANDARD-GENERIC-FUNCTION T))|
+                |(METHOD LEGAL-DECLARATIONS-P (STANDARD-GENERIC-FUNCTION T))|
                 |(METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))|
                 |(METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|
                 |(METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))|
@@ -876,29 +994,48 @@
                 |(METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))|
                 |(METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))|
                 |(METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))|
-                |(METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))|
-                |(SETF CLASS-DEFSTRUCT-FORM)|
+                |(METHOD LEGAL-DOCUMENTATION-P (DOCUMENTATION-MIXIN T))|
                 |(SETF CLASS-INCOMPATIBLE-SUPERCLASS-LIST)|
                 |SETF PCL CLASS-SLOT-VALUE|
+                |(READER ARGUMENT-PRECEDENCE-ORDER)|
+                |(READER SIDE-EFFECT-INTERNAL-SLOTDS)|
                 |(METHOD PRINT-OBJECT (CONSTRUCTOR T))|
                 |(METHOD PRINT-OBJECT (METHOD-COMBINATION T))|
                 |(METHOD PRINT-OBJECT (GENERIC-FUNCTION T))|
+                |(METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))|
                 |(METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))|
                 |(METHOD PRINT-OBJECT (STANDARD-METHOD T))|
                 |(METHOD PRINT-OBJECT (SLOT-DEFINITION T))|
                 |(METHOD PRINT-OBJECT (CLASS T))|
                 |(METHOD PRINT-OBJECT (T T))|
-                |(SETF CLASS-DIRECT-SLOTS)|
-                |(SETF CLASS-NO-OF-INSTANCE-SLOTS)|
-                |(SETF CLASS-SLOTS)| |(READER OPERATOR)|
-                |(READER ARG-INFO)| METHOD-COMBINATION-TYPE
+                |(METHOD WRITER-METHOD-CLASS (T T))|
+                |(METHOD TRACE-METHOD (CONS))| |(READER ARG-INFO)|
+                METHOD-COMBINATION-TYPE
+                |SETF PCL SLOT-DEFINITION-INITFUNCTION-SIDE-EFFECT-FREE-P|
+                |(READER DEFAULT-INITARGS)|
+                CLASS-CACHED-IN-GENERIC-FUNCTIONS
                 |(READER DEFSTRUCT-CONSTRUCTOR)|
+                |(METHOD MAKE-CACHED-METHOD-LAMBDA-FROM-STORED-LAMBDA (STANDARD-METHOD T))|
                 |(METHOD MAKE-CONSTRUCTOR-CODE-GENERATORS (SLOT-CLASS T T T T))|
-                |(METHOD MAKE-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))|
-                |(METHOD MAKE-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T))|
-                |(METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))|
-                |(METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))|
-                |(METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))|
+                |(METHOD MAKE-CLOSURE-GENERATOR-FORM (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T))|
+                |(METHOD MAKE-OPTIMIZED-METHOD-LAMBDA (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T))|
+                |(METHOD MAKE-METHOD-LAMBDA (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T))|
+                |(METHOD MAKE-CACHED-METHOD-FUNCTION-FROM-STORED-LAMBDA (STANDARD-METHOD T))|
+                |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (FUNCALLABLE-STANDARD-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (STRUCTURE-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (STRUCTURE-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (STRUCTURE-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (STANDARD-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (STANDARD-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (STANDARD-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-WRITER-METHOD-FUNCTION (SLOT-CLASS T T T))|
+                |(METHOD MAKE-OPTIMIZED-READER-METHOD-FUNCTION (SLOT-CLASS T T T))|
+                |(METHOD MAKE-DOCUMENTED-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T T T))|
+                |(METHOD MAKE-DOCUMENTED-WRITER-METHOD-FUNCTION (SLOT-CLASS T T T))|
+                |(METHOD MAKE-DOCUMENTED-READER-METHOD-FUNCTION (SLOT-CLASS T T T))|
                 |(WRITER WRAPPER)| STANDARD-CLASS-P
                 |(SETF CONSTRUCTOR-CODE-TYPE)| LEGAL-SPECIALIZER-P
                 |(WRITER DEFSTRUCT-ACCESSOR-SYMBOL)|
@@ -908,66 +1045,118 @@
                 |(METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES (GENERIC-FUNCTION T))|
                 |(METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|
                 |(METHOD REMOVE-NAMED-METHOD (T T))|
-                |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))|
-                |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))|
                 |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND (STRUCTURE-CLASS T))|
-                |(METHOD REMOVE-READER-METHOD (SLOT-CLASS T))|
-                |(METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))|
-                |(METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))|
-                |(METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))|
+                |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (STRUCTURE-CLASS T T))|
+                |(METHOD COMPILE-STRUCTURE-CLASS-INTERNALS (STRUCTURE-CLASS T T T T))|
                 |(METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|
-                |(READER VALID-P)|
+                |(METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))|
+                |(METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))|
+                |(METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))|
+                |(METHOD REMOVE-READER-METHOD (SLOT-CLASS T))|
+                |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))|
+                |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (FUNCALLABLE-STANDARD-CLASS T T))|
+                |(METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (STANDARD-CLASS T T))|
+                |(METHOD COMPUTE-LAYOUT (STD-CLASS T T))|
+                |(METHOD COMPUTE-CLASS-SLOTS (STD-CLASS T))|
+                |(METHOD COMPUTE-INSTANCE-LAYOUT (STD-CLASS T))|
+                |(METHOD COMPUTE-STORAGE-INFO (STD-CLASS T))|
+                COMPUTE-STORAGE-INFO |(READER VALID-P)|
                 |DIRECT-SLOT-DEFINITION class predicate|
                 METHOD-FUNCTION-NAME |(READER INITARGS)|
-                REMOVE-DIRECT-METHOD |(WRITER CLASS-EQ-SPECIALIZER)|
+                |(WRITER CLASS-EQ-SPECIALIZER)|
                 |(METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))|
                 STANDARD-BOUNDP-METHOD-P METHOD-FUNCTION-FOR-CACHING
-                |(METHOD SLOT-MISSING (T T T T))|
-                |(METHOD SLOT-UNBOUND (T T T))|
-                |(METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))|
+                |(METHOD STORE-OPTIMIZED-METHOD-LAMBDA-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))|
+                |(METHOD STORE-CLOSURE-GENERATOR-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))|
+                |(METHOD STORE-METHOD-OPTIMIZED-FUNCTION-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))|
+                |(METHOD STORE-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T))|
+                |(METHOD SLOT-UNBOUND :AROUND (CLASS T T))|
                 |(METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))|
-                |(SETF DOCUMENTATION)| RAW-INSTANCE-ALLOCATOR
+                |(METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))|
+                |(METHOD SLOT-MISSING (T T T T))|
+                |(METHOD SLOT-UNBOUND (T T T))| |(READER FINALIZED-P)|
+                |(SETF DOCUMENTATION)|
+                |SETF PCL METHOD-CACHED-FUNCTIONS|
+                RAW-INSTANCE-ALLOCATOR
+                |(WRITER ARGUMENT-PRECEDENCE-ORDER)|
                 INSTALL-LAZY-CONSTRUCTOR-INSTALLER
+                |(WRITER SIDE-EFFECT-INTERNAL-SLOTDS)|
                 |(METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))|
                 METHOD-FUNCTION-FOR-CACHING-P
                 |SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL|
-                |(WRITER OPERATOR)| |(WRITER ARG-INFO)|
+                |(WRITER ARG-INFO)| |(READER OPTIMIZED-METHOD-LAMBDA)|
                 COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO
-                ALLOCATE-INSTANCE STANDARD-WRITER-METHOD-P
+                STANDARD-WRITER-METHOD-P
                 CLASS-INCOMPATIBLE-SUPERCLASS-LIST
+                |(WRITER DEFAULT-INITARGS)|
                 |(WRITER DEFSTRUCT-CONSTRUCTOR)|
                 |(METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|
                 |(METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))|
-                WRAPPER-FETCHER |INTEGER class predicate|
-                METHOD-COMBINATION-DOCUMENTATION
-                |(METHOD DESCRIBE-OBJECT (CLASS T))|
+                WRAPPER-FETCHER |(METHOD DESCRIBE-OBJECT (CLASS T))|
                 |(METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))|
+                |(METHOD DESCRIBE-OBJECT-SLOTS (SLOT-OBJECT T))|
                 |(METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))|
                 |(METHOD DESCRIBE-OBJECT (T T))|
                 |(METHOD DESCRIBE-OBJECT (CONSTRUCTOR T))|
                 |SETF PCL SLOT-DEFINITION-INITARGS|
-                |(READER CLOSURE-GENERATOR)|
-                COMPUTE-APPLICABLE-METHODS-USING-CLASSES
-                REMOVE-BOUNDP-METHOD
+                |(READER CLOSURE-GENERATOR)| REMOVE-BOUNDP-METHOD
                 |(METHOD GET-CONSTRUCTOR (SLOT-CLASS T))|
+                |(METHOD OPTIMIZE-INSTANCE-ACCESS (STANDARD-GENERIC-FUNCTION STANDARD-METHOD STRUCTURE-CLASS T T T T T))|
+                |(METHOD OPTIMIZE-INSTANCE-ACCESS (STANDARD-GENERIC-FUNCTION STANDARD-METHOD T T T T T T))|
                 |(METHOD METHOD-FUNCTION-FOR-CACHING (STANDARD-ACCESSOR-METHOD T))|
+                |(METHOD GET-CACHED-FUNCTION (STANDARD-METHOD T))|
                 |(METHOD METHOD-FUNCTION-FOR-CACHING (STANDARD-METHOD T))|
-                |(WRITER VALID-P)|
-                |SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR|
-                |(WRITER INITARGS)| |(BOUNDP METHOD)| |(BOUNDP SOURCE)|
+                |(WRITER VALID-P)| |(WRITER INITARGS)|
+                |(METHOD BOUNDP-METHOD-CLASS (SLOT-CLASS T))|
+                |(METHOD BOUNDP-METHOD-CLASS (T T))|
+                |(WRITER FINALIZED-P)|
+                |(READER DIRECT-DEFAULT-INITARGS)| |(BOUNDP SOURCE)|
                 |DOCUMENTATION-MIXIN class predicate|
-                |(SETF GF-DFUN-STATE)| EFFECTIVE-SLOT-DEFINITION-CLASS
-                SHORT-COMBINATION-OPERATOR |BIT-VECTOR class predicate|
-                REMOVE-DEPENDENT |(WRITER CLOSURE-GENERATOR)|
-                CLASS-DIRECT-DEFAULT-INITARGS REMOVE-NAMED-METHOD
+                |(WRITER OPTIMIZED-METHOD-LAMBDA)|
+                |(SETF GF-DFUN-STATE)| |(READER INTERNAL-SLOTDS)|
+                SHORT-COMBINATION-OPERATOR METHOD-NEEDS-NEXT-METHODS-P
+                |(WRITER CLOSURE-GENERATOR)| REMOVE-NAMED-METHOD
                 |(METHOD ENSURE-CLASS-USING-CLASS (T NULL))|
-                METHOD-GENERIC-FUNCTION LEGAL-DOCUMENTATION-P
-                COMPUTE-APPLICABLE-METHODS CLASS-NAME REMOVE-METHOD
+                LEGAL-DOCUMENTATION-P CLASS-DIRECT-SUPERCLASSES
+                CLASS-DIRECT-SUBCLASSES CLASS-DIRECT-DEFAULT-INITARGS
+                SLOT-DEFINITION-READERS SLOT-VALUE-USING-CLASS
+                DESCRIBE-OBJECT COMPUTE-APPLICABLE-METHODS CLASS-NAME
+                CLASS-PROTOTYPE READER-METHOD-CLASS REMOVE-METHOD
+                SLOT-DEFINITION-INITFORM
                 UPDATE-INSTANCE-FOR-REDEFINED-CLASS
                 UPDATE-INSTANCE-FOR-DIFFERENT-CLASS CHANGE-CLASS
-                SHARED-INITIALIZE ADD-METHOD SLOT-UNBOUND
-                INITIALIZE-INSTANCE FUNCTION-KEYWORDS
-                REINITIALIZE-INSTANCE MAKE-INSTANCE PRINT-OBJECT
-                METHOD-QUALIFIERS MAKE-INSTANCES-OBSOLETE SLOT-MISSING
-                NO-APPLICABLE-METHOD))
+                METHOD-FUNCTION DIRECT-SLOT-DEFINITION-CLASS
+                MAKE-METHOD-LAMBDA EFFECTIVE-SLOT-DEFINITION-CLASS
+                CLASS-SLOTS COMPUTE-SLOTS SLOT-DEFINITION-NAME
+                FINALIZE-INHERITANCE
+                GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER
+                GENERIC-FUNCTION-LAMBDA-LIST NO-NEXT-METHOD
+                CLASS-DIRECT-SLOTS CLASS-DEFAULT-INITARGS
+                COMPUTE-DISCRIMINATING-FUNCTION CLASS-FINALIZED-P
+                GENERIC-FUNCTION-NAME REMOVE-DEPENDENT
+                COMPUTE-CLASS-PRECEDENCE-LIST ADD-DEPENDENT
+                SLOT-BOUNDP-USING-CLASS ACCESSOR-METHOD-SLOT-DEFINITION
+                SHARED-INITIALIZE ADD-DIRECT-METHOD
+                SLOT-DEFINITION-LOCATION SLOT-DEFINITION-INITFUNCTION
+                SLOT-DEFINITION-ALLOCATION ADD-METHOD
+                GENERIC-FUNCTION-METHOD-CLASS METHOD-SPECIALIZERS
+                SLOT-DEFINITION-INITARGS WRITER-METHOD-CLASS
+                ADD-DIRECT-SUBCLASS SPECIALIZER-DIRECT-METHODS
+                GENERIC-FUNCTION-METHOD-COMBINATION ALLOCATE-INSTANCE
+                COMPUTE-EFFECTIVE-METHOD SLOT-DEFINITION-TYPE
+                SLOT-UNBOUND INITIALIZE-INSTANCE FUNCTION-KEYWORDS
+                SLOT-EXISTS-P-USING-CLASS REINITIALIZE-INSTANCE
+                VALIDATE-SUPERCLASS GENERIC-FUNCTION-METHODS
+                REMOVE-DIRECT-METHOD METHOD-LAMBDA-LIST MAKE-INSTANCE
+                GENERIC-FUNCTION-DECLARATIONS
+                COMPUTE-EFFECTIVE-SLOT-DEFINITION PRINT-OBJECT
+                METHOD-QUALIFIERS METHOD-GENERIC-FUNCTION
+                REMOVE-DIRECT-SUBCLASS MAKE-INSTANCES-OBSOLETE
+                SLOT-MAKUNBOUND-USING-CLASS
+                ENSURE-GENERIC-FUNCTION-USING-CLASS SLOT-MISSING
+                MAP-DEPENDENTS FIND-METHOD-COMBINATION
+                ENSURE-CLASS-USING-CLASS NO-APPLICABLE-METHOD
+                SLOT-DEFINITION-WRITERS
+                COMPUTE-APPLICABLE-METHODS-USING-CLASSES
+                CLASS-PRECEDENCE-LIST))
   (SETF (GET V 'COMPILER::PROCLAIMED-CLOSURE) T)) 
diff --git a/pcl/sysdef.lisp b/pcl/sysdef.lisp
index b9bb3ac57..6ddfed6d2 100644
--- a/pcl/sysdef.lisp
+++ b/pcl/sysdef.lisp
@@ -38,78 +38,111 @@
 (defvar *pcl-compiled-p* nil)
 (defvar *pcl-loaded-p* nil)
 
-(defun pcl-sym (sym)
-  (intern (string sym) (or (find-package :pcl)
-			   (make-package :pcl :use '(:lisp)))))
+(unless (boundp 'pcl::*redefined-functions*)
+  (setq pcl::*redefined-functions* nil))
 
-(defun kill-pcl-package ()
-  (if (and (find-package "PCL")
-	   (fboundp (pcl-sym "RESET-PCL-PACKAGE")))
-      (funcall (pcl-sym "RESET-PCL-PACKAGE"))
-      (rename-package "PCL" (symbol-name (gensym))))
+(defun pcl::reset-pcl-package ()		; Try to do this safely
+  (let* ((vars '(pcl::*pcl-directory* 
+		 pcl::*default-pathname-extensions* 
+		 pcl::*pathname-extensions*
+		 pcl::*redefined-functions*))
+	 (names (mapcar #'symbol-name vars))
+	 (values (mapcar #'symbol-value vars)))
+    (let ((pkg (find-package "PCL")))
+      (do-symbols (sym pkg)
+	(when (eq pkg (symbol-package sym))
+	  (if (constantp sym)
+	      (unintern sym pkg)
+	      (progn
+		(makunbound sym)
+		(unless (eq sym 'pcl::reset-pcl-package)
+		  (fmakunbound sym))
+		#+cmu (fmakunbound `(setf ,sym))
+		(setf (symbol-plist sym) nil))))))
+    (let ((pkg (find-package "SLOT-ACCESSOR-NAME")))
+      (when pkg
+	(do-symbols (sym pkg)
+	  (makunbound sym)
+	  (fmakunbound sym)
+	  (setf (symbol-plist sym) nil))))
+    (let ((pcl (find-package "PCL")))
+      (mapcar #'(lambda (name value)
+		  (let ((var (intern name pcl)))
+		    (proclaim `(special ,var))
+		    (set var value)))
+	      names values))      
+    (dolist (sym pcl::*redefined-functions*)
+      (setf (symbol-function sym) (get sym ':definition-before-pcl)))
+    nil))
+
+(defun reset-pcl-package ()
+  #-cmu
+  (unless (compiled-function-p #'pcl::reset-pcl-package)
+    (compile 'pcl::reset-pcl-package))
+  (pcl::reset-pcl-package)
   (let ((defsys (subfile '("pcl") :name "defsys")))
-    (set (pcl-sym "*PCL-DIRECTORY*") defsys)
+    (setq pcl::*pcl-directory* defsys)
     (load-file defsys))
   (mapc #'(lambda (path)
 	    (setf (lfi-fwd (get-loaded-file-info path)) 0))
 	(pcl-binary-files)))
 
 (defun pcl-binary-files ()
-  (funcall (pcl-sym 'system-binary-files) (pcl-sym 'pcl)))
+  (pcl::system-binary-files 'pcl::pcl))
 
 (defun maybe-load-defsys (&optional compile-defsys-p)
   (let ((defsys (subfile '("pcl") :name "defsys"))
 	(*use-default-pathname-type* nil)
 	(*skip-load-if-loaded-p* t)
 	(*skip-compile-file-fwd* 0))
-    (set (pcl-sym "*PCL-DIRECTORY*") defsys)
+    (set 'pcl::*pcl-directory* defsys)
     (when compile-defsys-p
       (compile-file defsys))
-    (let ((b-s (pcl-sym '*boot-state*)))
+    (let ((b-s 'pcl::*boot-state*))
       (when (and (boundp b-s) (symbol-value b-s))
-	#+ignore (kill-pcl-package)))
+	#+ignore (reset-pcl-package)))
     (load-file defsys)))  
 
-(defun maybe-load-pcl (&optional force-p compile-defsys-p)
+(defun maybe-load-pcl (&optional force-p)
   (unless (and (null force-p)
-	       (fboundp (pcl-sym 'get-system))
+	       (fboundp 'pcl::system-binary-files)
 	       (every #'(lambda (path)
 			  (let* ((path-fwd (file-write-date path))
 				 (lfi (get-loaded-file-info path)))
 			    (and lfi path-fwd (= path-fwd (lfi-fwd lfi)))))
 		      (pcl-binary-files)))
-    (maybe-load-defsys compile-defsys-p)
-    (funcall (pcl-sym 'load-pcl))))
+    (reset-pcl-package)
+    (pcl::load-pcl)))
 
 (defsystem pcl
     (:pretty-name "PCL")
   #+akcl
   (:forms 
-   :compile (let ((cfn (merge-pathnames "../cmpnew/collectfn.lisp" 
-					si::*system-directory*)))
+   :compile (let ((cfn (subfile '("pcl") :name "collectfn" :type "lisp")))
 	      (unless (probe-file cfn)
 		(run-unix-command 
-		 (format nil "ln ~A ~A"
-			 (namestring (make-pathname :defaults cfn :type "lsp"))
+		 (format nil "ln -s ~A ~A"
+			 (namestring (merge-pathnames "../cmpnew/collectfn.lsp" 
+						      si::*system-directory*))
 			 (namestring cfn))))))
+				     
   #+akcl
-  #.(merge-pathnames "../cmpnew/collectfn" si::*system-directory*)
-  #+akcl
-  #.(merge-pathnames "../lsp/sys-proclaim" si::*system-directory*)
+  "collectfn"
   (:forms 
    :compile
    (progn
      (maybe-load-defsys t)
-     (if (and (fboundp (pcl-sym 'operation-transformations))
+     (if (and (fboundp 'pcl::operation-transformations)
 	      (every #'(lambda (trans)
 			 (eq (car trans) :load))
-		     (funcall (pcl-sym 'operation-transformations)
-			      (pcl-sym 'pcl) :compile)))
+		     (pcl::operation-transformations 'pcl::pcl :compile)))
 	 (maybe-load-pcl)
-	 (let ((b-s (pcl-sym '*boot-state*)))
+	 (let ((b-s 'pcl::*boot-state*))
 	   (when (and (boundp b-s) (symbol-value b-s))
-	     (kill-pcl-package))
+	     (reset-pcl-package))
 	   #+akcl (compiler::emit-fn t)
+	   #+akcl (load (merge-pathnames "../lsp/sys-proclaim.lisp" 
+					 si::*system-directory*))
 	   (#+cmu with-compilation-unit #-cmu progn
 	    #+cmu (:optimize 
 		   '(optimize (user::debug-info #+small .5 #-small 2)
@@ -120,15 +153,15 @@
 		   '(#+ignore
 		     (:external (declare (user::optimize-interface 
 					  (safety 2) (debug-info 1))))))
-	     #+testing
-	     (proclaim '(optimize (speed 1) (safety 3) #+lucid (compilation-speed 3)))
-	     #-testing
-	     (proclaim '(optimize (speed 3) (safety 0) #+lucid (compilation-speed 0)))
-	     (funcall (pcl-sym "COMPILE-PCL")))
-	   (kill-pcl-package)
+	     (proclaim #+testing *testing-declaration* 
+		       #-testing *fast-declaration*)
+	     (pcl::compile-pcl))
+	   (reset-pcl-package)
 	   (maybe-load-pcl t))))
    :load
-   (maybe-load-pcl)))
+   (progn 
+     (maybe-load-pcl)
+     #+cmu (lisp::purify))))
 
 (defparameter *pcl-files*
   '((("systems") "lisp"
diff --git a/pcl/time.lisp b/pcl/time.lisp
index eaa766eb9..9abf2a7fa 100644
--- a/pcl/time.lisp
+++ b/pcl/time.lisp
@@ -9,12 +9,18 @@
 (defvar gf #'shared-initialize)
 (defvar c (find-class 'standard-class))
 
+(eval-when (compile)
+ (defvar *saved-defclass-times* *defclass-times*)
+ (setf *defclass-times* '(eval load compile)))
+
 (defclass str ()
   ((slot :initform nil :reader str-slot))
   (:metaclass structure-class))
 
-(defvar str (make-instance 'str))
+(eval-when (compile)
+ (setf *defclass-times* *saved-defclass-times*))
 
+(defvar str (make-instance 'str))
 
 (push (cons "Time unoptimized slot-value.  This is case (1) from notes.text. (standard)"
 	    '(time-slot-value m 'plist 10000))
@@ -82,7 +88,7 @@
 	    '(time-default-initargs (find-class 'plist-mixin) 1000))
       *tests*)
 (defun time-default-initargs (class n)
-  (time (dotimes (i n) (default-initargs class nil))))
+  (time (dotimes (i n) (default-initargs class nil (class-default-initargs class)))))
 
 
 (push (cons "Time make-instance."
@@ -92,6 +98,25 @@
   (time (dotimes (i n) (make-instance class))))
 
 
+(defmethod meth-standard-1-slot-value ((object standard-method))
+  (slot-value object 'function))
+
+(defmethod meth-structure-1-slot-value ((object str))
+  (slot-value object 'slot))
+
+(push (cons "Time optimized slot-value inside of a defmethod (standard)"
+	    '(time-meth-standard-1-slot-value m 10000))
+      *tests*)
+(defun time-meth-standard-1-slot-value (object n)
+  (time (dotimes (i n) (meth-standard-1-slot-value object))))
+
+(push (cons "Time optimized slot-value inside of a defmethod (structure)"
+	    '(time-meth-structure-1-slot-value str 10000))
+      *tests*)
+(defun time-meth-structure-1-slot-value (object n)
+  (time (dotimes (i n) (meth-structure-1-slot-value object))))
+
+
 (defun expand-all-macros (form)
   (walk-form form nil #'(lambda (form context env)
 			  (if (and (eq context :eval)
@@ -102,11 +127,16 @@
 			      (values (macroexpand form env))
 			      form))))
 
-(push (cons "Macroexpand meth-structure-slot-value"
-	    '(pprint (expand-defmethod-internal 'meth-structure-slot-value
-		      nil '((object str))
-		      '(#'(lambda () (slot-value object 'slot)))
-		      nil)))
+(push (cons "Macroexpand method-structure-slot-value"
+	    '(pprint (multiple-value-bind (function optimized-function)
+		        (expand-defmethod-internal
+                         (prototype-of-generic-function 'meth-structure-slot-value)
+                         (method-prototype-for-gf 'meth-structure-slot-value)
+                         'method-structure-slot-value
+		         nil '((object str))
+		         '(#'(lambda () (slot-value object 'slot)))
+		         nil)
+                       optimized-function)))
       *tests*)
 #-kcl
 (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
@@ -119,10 +149,15 @@
 #|| ; interesting, but long.  (produces 100 lines of output)
 (push (cons "Macroexpand meth-standard-slot-value"
 	    '(pprint (expand-all-macros
-		     (expand-defmethod-internal 'meth-standard-slot-value
-		      nil '((object standard-method))
-		      '(#'(lambda () (slot-value object 'function)))
-		      nil))))
+                       (multiple-value-bind (function optimized-function)
+		        (expand-defmethod-internal
+                         (prototype-of-generic-function 'meth-standard-slot-value)
+                         (method-prototype-for-gf 'meth-standard-slot-value)
+                         'meth-standard-slot-value
+		         nil '((object standard-method))
+		         '(#'(lambda () (slot-value object 'function)))
+		         nil)
+                       optimized-function))))
       *tests*)
 (push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
 	    '(disassemble (meth-standard-slot-value m)))
diff --git a/pcl/user-instances.lisp b/pcl/user-instances.lisp
new file mode 100644
index 000000000..1600efc74
--- /dev/null
+++ b/pcl/user-instances.lisp
@@ -0,0 +1,684 @@
+;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; -*-
+
+;;;
+;;; *************************************************************************
+;;;
+;;;   File: user-instances.lisp.
+;;;
+;;;     by Trent E. Lange, Effective Date 06-02-92
+;;;
+;;;
+;;;  This file contains a metaclass (User-Vector-Class) whose instances
+;;; are stored as simple-vectors, saving space over PCL's standard instance
+;;; representations of PCL at the cost of some class redefinition flexibiliity.
+;;;
+;;; Permission is granted to any individual or institution to use, copy,
+;;; modify and distribute this document.
+;;;
+;;; Suggestions, bugs, criticism and questions to lange@cs.ucla.edu
+;;; *************************************************************************
+;;;
+
+(in-package 'pcl)
+
+;;;   This file builds on the PCL-USER-INSTANCES feature of July 92 PCL
+;;; to define the USER-VECTOR-CLASS metaclass whose instances are simple
+;;; vectors.  The first element of the instance vector is the instance's
+;;; class wrapper (providing internal PCL information about the instance's
+;;; class).  The remaining elements of the instance vector are the instance's
+;;; slots themselves.
+;;;
+;;;   The space overhead of user-vector-instances is only two vector cells
+;;; (one for the vector, one for the wrapper).  This is contrast to standard
+;;; PCL instances, which have a total overhead of four cells.  (Standard
+;;; instances in PCL are represented as instances of structure STD-INSTANCE
+;;; having two slots, one for the wrapper and one holding a simple-vector
+;;; which is the instance's slots).  This two-cell space savings per instance
+;;; comes at the cost of losing some class redefinition flexibility, since
+;;; simple-vectors cannot have their sizes changed dynamically.
+;;; All current instances of user-instance-vectors therefore become
+;;; permanently obsolete if the classes' instance slots change.
+;;;
+;;;   This code requires July 92 PCL or later compiled with the
+;;; PCL-USER-INSTANCES feature turned on (see PCL's low.lisp file).
+;;;
+
+#-pcl-user-instances
+(eval-when (compile load eval)
+(error "Cannot use user-instances, since PCL was compiled without
+        PCL-USER-INSTANCES on the *features* list (see pcl file low.lisp.)")
+)
+
+(eval-when (compile load eval)
+(defclass user-vector-class-mixin () ()
+  (:documentation
+    "Use this mixin for metaclasses whose instances are USER-INSTANCES
+     instantiated as simple-vectors.  This saves space over the standard
+     instances used by standard-class, at the cost of losing the ability to
+     redefine the slots in a class and still have old instances updated correctly."))
+
+(defclass user-vector-class (user-vector-class-mixin standard-class) ()
+  (:documentation
+    "A metaclass whose instances are USER-INSTANCES instantiated as simple-vectors.
+     This saves space over the standard instances used by standard-class, at the
+     cost of losing the ability to redefine the slots in a class and still have old
+     instances updated correctly."))
+
+(defmethod validate-superclass ((class user-vector-class-mixin)
+                                (new-super T))
+  (or (typep new-super 'user-vector-class-mixin)
+      (eq new-super (find-class 'standard-object))))
+
+(defclass user-vector-object (standard-object) ()
+  (:metaclass user-vector-class))
+)
+
+;;;
+;;;
+;;; Instance allocation stuff.
+;;;
+
+(defmacro user-vector-instance-p (object)
+  (once-only (object)
+    `(the boolean
+          (and (simple-vector-p ,object)
+               (plusp (length (the simple-vector ,object)))
+               (wrapper-p (%svref ,object 0))))))
+
+(defmacro user-vector-instance-wrapper (object)
+  `(%svref ,object 0))
+
+(defsetf user-vector-instance-wrapper (object) (new-value)
+  `(setf (%svref ,object 0) ,new-value))
+
+(defmacro user-vector-instance-slots (instance)
+  ;; The slots vector of user-vector instances is the instance itself.
+  instance)
+
+(defmacro set-user-vector-instance-slots (instance new-value)
+  `(progn
+     (warn "Attempt to set user-vector-instance-slots of ~S to ~S"
+           ,instance ,new-value)
+     ,new-value))
+
+(defun user-instance-p (x)
+  "Is X a user instance, specifically a user-vector-instance?"
+  (user-vector-instance-p x))
+
+(defun user-instance-slots (x)
+  "Return the slots of this user-vector-instance."
+  (user-vector-instance-slots x))
+
+(defun user-instance-wrapper (x)
+  "Return the wrapper of this user-vector-instance."
+  (user-vector-instance-wrapper x))
+
+(defun set-user-instance-wrapper (x new)
+  (setf (user-vector-instance-wrapper x) new))
+
+(defmacro get-user-instance-p (x)
+  `(user-vector-instance-p ,x))
+
+(defmacro get-user-instance-wrapper (x)
+  `(user-vector-instance-wrapper ,x))
+
+(defmacro get-user-instance-slots (x)
+  `(user-vector-instance-slots ,x))
+
+(eval-when (eval #+cmu load)
+  (force-compile 'user-instance-p)
+  (force-compile 'user-instance-slots)
+  (force-compile 'user-instance-wrapper)
+  (force-compile 'set-user-instance-wrapper))
+
+
+;;;
+;;; Methods needed for user-vector-class-mixin.
+;;;
+
+(defconstant *not-a-slot* (gensym "NOT-A-SLOT"))
+
+(defmethod allocate-instance ((class user-vector-class-mixin) &rest initargs)
+  (declare (ignore initargs))
+  (unless (class-finalized-p class) (finalize-inheritance class))
+  (let* ((class-wrapper (class-wrapper class))
+         (copy-instance (wrapper-allocate-static-slot-storage-copy
+                           class-wrapper))
+         (instance      (copy-simple-vector copy-instance)))
+    (declare (type simple-vector copy-instance instance))
+    (setf (user-vector-instance-wrapper instance) class-wrapper)
+    instance))
+
+(defmethod make-instances-obsolete ((class user-vector-class-mixin))
+  "The slots of user-vector-instances are stored in the instance vector
+   themselves (a simple-vector), so old instances cannot be updated properly."
+  (setf (slot-value class 'prototype) NIL)
+  (warn "Obsoleting user-vector class ~A, all current instances will be invalid..."
+        class))
+
+(defmethod compute-layout :around ((class user-vector-class-mixin)
+                                    cpl instance-eslotds)
+  ;; First element of user-vector-instance is actually its wrapper.
+  (declare (ignore cpl instance-eslotds))
+  (cons *not-a-slot* (call-next-method)))
+
+(defmethod compute-instance-layout :around ((class user-vector-class-mixin)
+                                            instance-eslotds)
+  ;; First element of user-vector-instance is actually its wrapper.
+  (declare (ignore instance-eslotds))
+  (cons *not-a-slot* (call-next-method)))
+
+(defmethod wrapper-fetcher ((class user-vector-class-mixin))
+  'user-vector-instance-wrapper)
+
+(defmethod slots-fetcher ((class user-vector-class-mixin))
+  'user-vector-instance-slots)
+
+(defmethod raw-instance-allocator ((class user-vector-class-mixin))
+  'allocate-user-vector-instance)
+
+
+;;;
+;;; The following functions and methods are not strictly necessary for
+;;; user-vector-instances, but do speed things up a bit.
+;;;
+
+;;; Inform PCL that it is still safe to use its standard slot-value
+;;; optimizations with user-vector-class-mixin's slot-value-using-class
+;;; methods:
+
+(pushnew
+  '(user-vector-class-mixin standard-object standard-effective-slot-definition)
+   *safe-slot-value-using-class-specializers*)
+
+(pushnew
+  '(T user-vector-class-mixin standard-object standard-effective-slot-definition)
+   *safe-set-slot-value-using-class-specializers*)
+
+(pushnew
+  '(user-vector-class-mixin standard-object standard-effective-slot-definition)
+  *safe-slot-boundp-using-class-specializers*)
+
+(defmethod slot-value-using-class
+  ((class user-vector-class-mixin)
+   (object standard-object)
+   (slotd standard-effective-slot-definition))
+  (let* ((location (slot-definition-location slotd))
+	 (value
+           (typecase location
+	      (fixnum
+                (%svref (user-vector-instance-slots object) location))
+	      (cons
+	        (cdr location))
+	      (t
+	       (error
+                 "The slot ~s has neither :instance nor :class allocation, ~@
+                              so it can't be read by the default ~s method."
+		  slotd 'slot-value-using-class)))))
+    (if (eq value *slot-unbound*)
+	(slot-unbound class object (slot-definition-name slotd))
+	value)))
+
+(defmethod (setf slot-value-using-class)
+	   (new-value (class user-vector-class-mixin)
+                      (object standard-object)
+		      (slotd standard-effective-slot-definition))
+  (let ((location (slot-definition-location slotd)))
+    (typecase location
+      (fixnum
+        (setf (%svref (user-vector-instance-slots object) location) new-value))
+      (cons
+        (setf (cdr location) new-value))
+      (t
+       (error "The slot ~s has neither :instance nor :class allocation, ~@
+                           so it can't be written by the default ~s method."
+	      slotd '(setf slot-value-using-class))))))
+
+(defmethod slot-boundp-using-class
+  ((class user-vector-class-mixin)
+   (object standard-object)
+   (slotd standard-effective-slot-definition))
+  (let* ((location (slot-definition-location slotd))
+	 (value
+           (typecase location
+	     (fixnum
+               (%svref (user-vector-instance-slots object) location))
+	     (cons
+	       (cdr location))
+	     (t
+	       (error
+                 "The slot ~s has neither :instance nor :class allocation, ~@
+                              so it can't be read by the default ~s method."
+		 slotd 'slot-boundp-using-class)))))
+    (not (eq value *slot-unbound*))))
+
+
+
+(defmethod make-optimized-reader-method-function
+           ((class user-vector-class-mixin)
+            generic-function
+            reader-method-prototype
+            slot-name)
+  (declare (ignore generic-function reader-method-prototype))
+  (make-user-vector-instance-reader-method-function slot-name))
+
+(defmethod make-optimized-writer-method-function
+           ((class user-vector-class-mixin)
+            generic-function
+            reader-method-prototype
+            slot-name)
+  (declare (ignore generic-function reader-method-prototype))
+  (make-user-vector-instance-writer-method-function slot-name))
+
+(defmethod make-optimized-method-function
+           ((class user-vector-class-mixin)
+            generic-function
+            boundp-method-prototype
+            slot-name)
+  (declare (ignore generic-function boundp-method-prototype))
+  (make-user-vector-instance-boundp-method-function slot-name))
+
+(defun make-user-vector-instance-reader-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (user-instance-slot-value instance slot-name)))
+
+(defun make-user-vector-instance-writer-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (nv instance)
+      (setf (user-instance-slot-value instance slot-name) nv)))
+
+(defun make-user-vector-instance-boundp-method-function (slot-name)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (user-instance-slot-boundp instance slot-name)))
+
+
+(defun make-optimized-user-reader-method-function (slot-name index)
+  (declare #.*optimize-speed*)
+  (progn slot-name)
+  #'(lambda (instance)
+      (let ((value (%svref (user-vector-instance-slots instance) index)))
+        (if (eq value *slot-unbound*)
+            (slot-unbound (class-of instance) instance slot-name)
+            value))))
+
+(defun make-optimized-user-writer-method-function (index)
+  (declare #.*optimize-speed*)
+  #'(lambda (nv instance)
+      (setf (%svref (user-vector-instance-slots instance) index) nv)))
+
+(defun make-optimized-user-boundp-method-function (index)
+  (declare #.*optimize-speed*)
+  #'(lambda (instance)
+      (not (eq (%svref (user-vector-instance-slots instance) index)
+               *slot-unbound*))))
+
+
+
+(defmacro with-user-instance-slots (slot-entries instance-form &body body)
+  "Optimized version of With-Slots that assumes that the instance-form
+   evaluates to a user-vector-instance.  The result is undefined if it does not.
+   With-user-vector-instance-slots is faster than With-Slots because it factors
+   out functions common to all slot accesses on the instance.  It has two
+   extensions to With-Slots: (1) the second value of slot-entries are
+   evaluated as forms rather than considered to be hard slot-names, allowing
+   access of variable slot-names.  (2) if a :variable-instance keyword is
+   the first part of the body, then the instance-form is treated as a variable
+   form, which is always expected to return an instance of the same class.
+   The value of the keyword must be an instance that is the same class as
+   instance-form will always return."
+  (build-with-optimized-slots-form slot-entries instance-form body 'user-instance))
+
+
+
+;;;
+;;;  Lisp and CLOS print compatability functions:
+;;;
+;;;  This gets really ugly because most lisps don't use PRINT-OBJECT
+;;;  for the printed representation of their objects like they're supposed
+;;;  to.  (And if the lisp did, it wouldn't be using PCL.).  And since
+;;;  user-vector-instances are implemented as simple-vectors, the only
+;;;  way to get their printed representations to look right is to make
+;;;  PRINT-OBJECT object to work.
+;;;    We therefore have to patch the standard lisp printing functions.
+;;;  If all goes well, then everything is honky-dory.  If it doesn't, then
+;;;  debugging can get pretty messy since we were screwing with the standard
+;;;  printing functions.  Things should work, but if they don't, then calling
+;;;  RESTORE-LISP-PRINTERS will get things back to normal.
+
+(defvar *old-write* NIL)
+(defvar *old-princ* NIL)
+(defvar *old-prin1* NIL)
+(defvar *old-print* NIL)
+
+;; Structure dummy-print-instance is a structure whose sole purpose
+;; in life is to act as a placeholder to allow the print-object of 
+;; user-vector-class objects to be printed.
+
+(defstruct (dummy-print-instance
+              (:print-function print-dummy-print-instance))
+  (print-object-string nil))
+
+(declaim (type list *dummy-print-instance-garbage*))
+(defvar      *dummy-print-instance-garbage* NIL)
+(defconstant *dummy-print-instance-garbage-limit* 100)
+
+(defmacro pure-array-p (x &optional (test-user-vector-instance-p T))
+  "Returns whether item is a 'pure' array -- i.e. not a string, and
+   not something holding a CLOS instance."
+  (once-only (x)
+    `(the boolean
+          (locally (declare (inline arrayp stringp typep))
+            (and (arrayp ,x)
+                 (not (stringp ,x))
+                 #-(or cmu (and lucid pcl))
+                 (not (typep ,x 'structure))
+                 ,@(when test-user-vector-instance-p
+                     `((not (user-vector-instance-p ,x))))
+                 #-(or cmu (and lucid pcl))
+                 (not (typep ,x 'standard-object)))))))
+
+(defun copy-any-array (old-array &rest keys-passed &key key dimensions)
+  ;; Returns a copy of old-array.  If :key is provided, then the
+  ;; elements of the new-array are the result of key applied to
+  ;; old-array's elements.  If :dimensions is provided, and it is
+  ;; different than old-array's dimensions, then the new-array is created
+  ;; with those dimensions, and everything that can be copied from
+  ;; old-array is copied into it.  It is an error if the rank of
+  ;; the array specified by dimensionss is different than that of the
+  ;; old-array.
+  (declare (type array              old-array)
+           (type (or function null) key)
+           (type list               dimensions keys-passed))
+  (cond
+    ((simple-vector-p old-array)
+     (apply #'copy-array-contents
+            old-array
+            (make-array (the index
+                             (if dimensions
+                                 (car dimensions)
+                               (length (the simple-vector old-array)))))
+            keys-passed))
+    ((vectorp old-array)
+     (apply #'copy-array-contents
+            old-array
+            (make-array (the index
+                             (if dimensions
+                                 (car dimensions)
+                               (length (the vector old-array))))
+                        :element-type (array-element-type old-array)
+                        :adjustable   (adjustable-array-p old-array))
+            keys-passed))
+    ((arrayp old-array)
+     (let* ((old-dimensions (array-dimensions   old-array))
+            (new-dimensions (or dimensions old-dimensions))
+            (element-type   (array-element-type old-array))
+            (new-array
+              (make-array new-dimensions
+                          :element-type element-type
+                          :adjustable   (adjustable-array-p old-array))))
+       (declare (type list  old-dimensions new-dimensions)
+                (type array new-array))
+       (if (or (null dimensions) (equal new-dimensions old-dimensions))
+           (let* ((displaced-old-array
+                    (make-array (array-total-size old-array)
+                      :element-type element-type
+                      :displaced-to old-array))
+                  (displaced-new-array
+                    (make-array (array-total-size new-array)
+                      :element-type element-type
+                      :displaced-to new-array)))
+             (declare (type array displaced-old-array displaced-new-array))
+             (copy-array-contents displaced-old-array
+                                  displaced-new-array
+                                  :key key))
+         (let ((first-dimension
+                  (min (the index (car new-dimensions))
+                       (the index (car old-dimensions)))))
+            (declare (type index first-dimension))
+            (walk-dimensions
+              (mapcar #'min (cdr new-dimensions) (cdr old-dimensions))
+              #'(lambda (post-indices)
+                 (copy-array-contents old-array new-array
+                                      :key key
+                                      :length first-dimension
+                                      :post-indices post-indices)))))
+       new-array))))
+
+(defun copy-array-contents
+       (old-array new-array &key key length post-indices &allow-other-keys)
+  ;; Copies the contents of old-array into new-array, using key if
+  ;; supplied.  Only the first :length items are copied (defaulting
+  ;; to the length of the old-array).  If :post-indices are passed, then
+  ;; they are used as "post" indices to an aref.
+  (macrolet
+   ((do-copy (aref old new key key-type len post-indices)
+     (let ((atype (if (eq aref #'svref) 'simple-vector 'array)))
+       `(dotimes (i (the index ,len))
+          (setf ,(if post-indices
+                     `(apply #'aref (the ,atype ,new) i ,post-indices)
+                    `(,aref (the ,atype ,new) i))
+                ,(if key-type
+                     `(funcall
+                        (the ,key-type ,key)
+                        ,(if post-indices
+                             `(apply #'aref (the ,atype ,old)
+                                     i ,post-indices)
+                           `(,aref (the ,atype ,old) i)))
+                   (if post-indices
+                      `(apply #'aref (the ,atype ,old) i ,post-indices)
+                    `(,aref (the ,atype ,old) i)))))))
+     (expand-on-key (aref key old new len post-ind)
+       `(cond
+         ((null ,key)
+          (do-copy ,aref ,old ,new ,key NIL ,len ,post-ind))
+         ((compiled-function-p ,key)
+          (do-copy ,aref ,old ,new ,key compiled-function ,len ,post-ind))
+         (T
+          (do-copy ,aref ,old ,new ,key function ,len ,post-ind)))))
+    (if (simple-vector-p old-array)
+        (progn
+          (when post-indices
+            (error "Can't pass post-indices given to COPY-ARRAY-CONTENTS
+                    from simple-vector"))
+          
+          (unless length
+            (setf length (min (length (the simple-vector old-array))
+                              (length (the simple-vector new-array)))))
+          (expand-on-key svref key old-array new-array length NIL))
+       (progn
+         (unless length
+           (setf length (min (the index (car (array-dimensions old-array)))
+                             (the index (car (array-dimensions new-array))))))
+         (if post-indices
+             (expand-on-key #'aref key old-array new-array length post-indices)
+             (expand-on-key aref key old-array new-array length NIL)))))
+  new-array)
+
+(declaim (ftype (function (list function) T) walk-dimensions))
+(defun walk-dimensions (dimensions fn)
+  (declare (type list     dimensions)
+           (type function fn))
+  ;; Given a list of dimensions (e.g. '(3 2 8)), this function walks
+  ;; through every possible combination from 0 to 1- each of those
+  ;; dimensions, and calling fn on each of them.
+  (let ((compiled-p (compiled-function-p fn)))
+    (labels
+      ((doit (dims apply-dims)
+         (declare (type list dims apply-dims))
+         (if (cdr dims)
+             (let ((last-dim  NIL)
+                   (dims-left NIL))
+                (loop (when (null (cdr dims))
+                        (setf last-dim (car dims))
+                        (return))
+                      (if dims-left
+                          (nconc dims-left (list (car dims)))
+                        (setf dims-left (list (car dims))))
+                      (setf dims (cdr dims)))
+                 (dotimes (i (the index last-dim))
+                   (doit dims-left (cons i apply-dims))))
+           (if compiled-p 
+               (dotimes (i (the index (car dims)))
+                 (funcall (the compiled-function fn) (cons i apply-dims)))
+             (dotimes (i (the index (car dims)))
+               (funcall fn (cons i apply-dims)))))))
+      (doit dimensions NIL))))
+
+(defmacro funcall-printer (applyer print-function object keys)
+  `(progn
+     (if (or (arrayp ,object) (consp ,object))
+         (multiple-value-bind (converted-item garbage)
+           (convert-user-vector-instances-to-dummy-print-instances ,object)
+           (,applyer (the compiled-function ,print-function)
+                     converted-item ,keys)
+           (deallocate-dummy-print-instances garbage))
+       (,applyer (the compiled-function ,print-function)
+                ,object ,keys))
+     ,object))
+
+(defun print-dummy-print-instance (instance stream depth)
+  (declare (ignore depth))
+  (let ((*print-pretty* NIL))
+    (funcall (the compiled-function *old-princ*)
+             (dummy-print-instance-print-object-string instance)
+             stream)))
+
+(defun allocate-dummy-print-instance (print-object-string)
+  (if *dummy-print-instance-garbage*
+      (let ((instance (pop *dummy-print-instance-garbage*)))
+        (setf (dummy-print-instance-print-object-string instance)
+              print-object-string)
+        instance)
+    (make-dummy-print-instance :print-object-string print-object-string)))
+
+(defun dummy-print-instance-of (user-vector-instance)
+  (allocate-dummy-print-instance 
+    (with-output-to-string (str)
+      (print-object user-vector-instance str))))
+
+(defun deallocate-dummy-print-instances (dummies)
+  (let ((count (length *dummy-print-instance-garbage*)))
+    (declare (type index count))
+    (dolist (dummy dummies)
+      (when (> count *dummy-print-instance-garbage-limit*)
+        (return))
+      (push dummy *dummy-print-instance-garbage*)
+      (setf count (the index (1+ count))))))
+   
+(defun convert-user-vector-instances-to-dummy-print-instances (item)
+  (let ((print-length
+          (or *print-length* 1000))
+        (print-level
+          (or *print-level* 1000))
+        (dummy-print-instances-used NIL))
+    (declare (fixnum print-length print-level))
+    (labels
+      ((doit (item level length)
+         (declare (fixnum level length))
+         (labels
+           ((user-vector-instance-visible-within-p (item level length)
+              (declare (fixnum level length))
+              (cond
+                ((>= length print-length) NIL)
+                ((> level print-level) NIL)
+                ((= level print-level) (user-vector-instance-p item))
+                (T (cond
+                    ((user-vector-instance-p item) T)
+                    ((consp item)
+                     (or (user-vector-instance-visible-within-p
+                           (car item) (the fixnum (1+ level)) 0)
+                         (user-vector-instance-visible-within-p
+                           (cdr item) level (the fixnum (1+ length)))))
+                    ((and *print-array* (pure-array-p item))
+                     (let ((next-level (the fixnum (1+ level))))
+                       (declare (fixnum next-level))
+                       (dotimes (i (1- (length (the array item))) NIL)
+                         (unless (< i print-length)
+                           (return NIL))
+                         (if (user-vector-instance-visible-within-p
+                               (aref item i) next-level 0)
+                             (return T))))))))))
+            ;; doit body
+            (cond
+              ((user-vector-instance-p item)
+               (let ((dummy (dummy-print-instance-of item)))
+                 (push dummy dummy-print-instances-used)
+                 dummy))
+              ((consp item)
+               (if (user-vector-instance-visible-within-p item level length)
+                   (cons (doit (car item) (the fixnum (1+ level)) length)
+                         (doit (cdr item) level (the fixnum (1+ length))))
+                 item))
+              ((and *print-array* (pure-array-p item NIL))
+               (if (user-vector-instance-visible-within-p item level length)
+                   (copy-any-array
+                     item
+                     :key
+                     #'(lambda (item)
+                         (if (user-vector-instance-p item)
+                             (let ((dummy (dummy-print-instance-of item)))
+                               (push dummy dummy-print-instances-used)
+                               dummy)
+                           item))
+                     :dimensions
+                       (mapcar #'1+ (array-dimensions item)))
+                    item))
+              (T item)))))
+
+      ;; convert-user-vector-instances-to-dummy-print-instances body
+
+      (let ((converted (doit item 0 0)))
+        (values converted dummy-print-instances-used)))))
+
+(force-compile 'convert-user-vector-instances-to-dummy-print-instances)
+
+(unless *old-write* (setf *old-write* (symbol-function 'write)))
+(defun new-write (object &rest keys-passed)
+  (declare (list keys-passed))
+  (funcall-printer apply *old-write* object keys-passed))
+(force-compile 'write)
+(setf (symbol-function 'write) (symbol-function 'new-write))
+
+(unless *old-princ* (setf *old-princ* (symbol-function 'princ)))
+(defun princ (object &optional stream)
+  (funcall-printer funcall *old-princ* object stream))
+(force-compile 'princ)
+
+(unless *old-prin1* (setf *old-prin1* (symbol-function 'prin1)))
+(defun prin1 (object &optional stream)
+  (funcall-printer funcall *old-prin1* object stream))
+(force-compile 'prin1)
+
+(unless *old-print* (setf *old-print* (symbol-function 'print)))
+(defun print (object &optional stream)
+  (funcall-printer funcall *old-print* object stream))
+(force-compile 'print)
+
+(defun new-write-to-string (object &rest keys-passed)
+  (declare (list keys-passed))
+  (with-output-to-string (string-stream)
+    (apply #'write object :stream string-stream keys-passed)))
+(force-compile 'write-to-string)
+(setf (symbol-function 'write-to-string)
+      (symbol-function 'new-write-to-string))
+
+(defun princ-to-string (object)
+  (with-output-to-string (string-stream)
+    (funcall-printer funcall *old-princ* object string-stream)
+    string-stream))
+(force-compile 'princ-to-string)
+
+(defun prin1-to-string (object)
+  (with-output-to-string (string-stream)
+    (funcall-printer funcall *old-prin1* object string-stream)
+    string-stream))
+(force-compile 'prin1-to-string)
+ 
+(defun restore-lisp-printers ()
+  (setf (symbol-function 'write) *old-write*)
+  (setf (symbol-function 'princ) *old-princ*)
+  (setf (symbol-function 'prin1) *old-prin1*)
+  (setf (symbol-function 'print) *old-print*))
+
diff --git a/pcl/vector.lisp b/pcl/vector.lisp
index 78158c755..d3ae7c761 100644
--- a/pcl/vector.lisp
+++ b/pcl/vector.lisp
@@ -29,124 +29,41 @@
 
 (in-package 'pcl)
 
+(defmacro instance-slot-index-from-slots-layout (slots-layout slot-name)
+  `(locally (declare #.*optimize-speed*)
+     (let ((slots-left ,slots-layout))
+       (if slots-left
+           (block nil
+             (let ((index 0))
+               (declare (type index index))
+               (tagbody
+                 begin-loop
+                  (if (eq (car slots-left) ,slot-name)
+                      (go return-index))
+                  (setf index (the index (1+ index)))
+                  (if (null (setf slots-left (cdr slots-left)))
+                      (return NIL))
+                  (go begin-loop)
+                 return-index)
+               index))))))
+
 (defmacro instance-slot-index (wrapper slot-name)
-  `(let ((pos 0))
-     (declare (fixnum pos))
-     (block loop
-       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
-	 (when (eq ,slot-name sn) (return-from loop pos))
-	 (incf pos)))))
+  `(instance-slot-index-from-slots-layout
+      (wrapper-instance-slots-layout ,wrapper) ,slot-name))
+
 
 
 ;;;
 ;;;
 ;;;
-(defun pv-cache-limit-fn (nlines)
-  (default-limit-fn nlines))
-
-(defstruct (isl
-	     (:predicate islp)
-	     (:constructor make-isl-internal (cache slot-name-lists)))
-  (cache *empty-cache* :type cache)
-  (slot-name-lists nil :type list))
-
-(defvar *initial-isl* (make-isl-internal nil nil))
-
-; help new slot-value-using-class methods affect fast iv access
-(defvar *all-isl-list* nil) 
-
-(defun make-isl (slot-name-lists)
-  (let ((isl (make-isl-internal (get-cache (- (length slot-name-lists)
-					      (count nil slot-name-lists))
-					   t
-					   #'pv-cache-limit-fn
-					   2)
-				slot-name-lists)))
-    (push isl *all-isl-list*)
-    isl))
-
-(defun make-isl-type-declaration (var)
-  `(type isl ,var))
-
-(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
-(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
-
-(defun intern-slot-name-lists (slot-name-lists)
-  (flet ((inner (x) 
-	   (or (gethash x *slot-name-lists-inner*)
-	       (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
-	 (outer (x) 
-	   (or (gethash x *slot-name-lists-outer*)
-	       (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
-    (outer (mapcar #'inner slot-name-lists))))
-
-
-
-(defvar *pvs* (make-hash-table :test #'equal))
-
 (defun optimize-slot-value-by-class-p (class slot-name type)
   (let ((slotd (find-slot-definition class slot-name)))
     (and slotd 
 	 (or (not (eq *boot-state* 'complete))
 	     (slot-accessor-std-p slotd type)))))
 
-(defun lookup-pv (isl wrappers)
-  (unless (listp wrappers) (setq wrappers (list wrappers)))
-  (let* ((class-slot-p nil)
-	 (elements
-	  (gathering1 (collecting)
-	    (iterate ((slot-names (list-elements (isl-slot-name-lists isl))))
-	      (when slot-names
-		(let* ((wrapper     (pop wrappers))
-		       (class       (wrapper-class wrapper))
-		       (class-slots (wrapper-class-slots wrapper)))
-		  (dolist (slot-name slot-names)
-		    (if (optimize-slot-value-by-class-p class slot-name 'all)
-			(let ((index (instance-slot-index wrapper slot-name)))
-			  (if index
-			      (gather1 index)
-			      (let ((cell (assq slot-name class-slots)))
-				(if cell
-				    (progn (setq class-slot-p t) (gather1 cell))
-				    (gather1 nil)))))
-			(gather1 nil)))))))))
-    (if class-slot-p				;Sure is a shame Common Lisp doesn't
-	(make-permutation-vector elements)	;give me the right kind of hash table.
-	(or (gethash elements *pvs*)
-	    (setf (gethash elements *pvs*) (make-permutation-vector elements))))))
-
-(defun make-permutation-vector (indexes)
-  (make-array (length indexes) :initial-contents indexes))
-
-(defun make-pv-type-declaration (var)
-  `(type simple-vector ,var))
-
-(defmacro pvref (pv index)
-  `(svref ,pv ,index))
-
-;The idea behind pv cells is that we can update them when 
-;new slot-value-using-class methods are added, and affect cached methods.
-;To do this, we have to be able to find all existing isl-caches.
-(defmacro make-pv-cell (pv)
-  `(cons ,pv nil))
-
-(defmacro pv-from-pv-cell (pv-cell)
-  `(car ,pv-cell))
-
-(defun update-all-isl-caches (class slot-name-list)
-  (declare (ignore slot-name-list))
-  (dolist (isl *all-isl-list*)
-    (map-cache #'(lambda (wrappers pv-cell)
-		   (when (if (atom wrappers)
-			     (eq class (wrapper-class wrappers))
-			     (find class wrappers :key #'wrapper-class))
-		     (setf (pv-from-pv-cell pv-cell)
-			   (lookup-pv isl wrappers))))
-	       (isl-cache isl))))
-
-
 (defun optimize-generic-function-call (form required-parameters env)
-  (declare (ignore env))
+  (declare (ignore env required-parameters))
   form
   #||
   (let* ((gf-name (car form))
@@ -155,14 +72,14 @@
 	 (metatypes (arg-info-metatypes arg-info))
 	 (nreq (length metatypes))
 	 (applyp (arg-info-applyp arg-info)))
+    (declare (type index nreq))
     (declare (ignore applyp))
     (if (or (zerop nreq)
 	    (not (<= nreq (length (cdr form))))
 	    (not (every #'(lambda (arg mt)
 			    (declare (ignore mt))
-			    (when (and (consp arg) 
-				       (eq (car arg) 'the))
-			      (setq arg (caddr arg)))
+			    (when (consp arg)
+                              (setq arg (un-the arg)))
 			    (and (symbolp arg)
 				 (memq arg required-parameters))
 			    (let ((class-name (caddr (variable-declaration 
@@ -194,17 +111,15 @@
 
 ;(defmacro maybe-fast-gf-call (gf-name args)
 ;   nil)
-
 
+
 (defun can-optimize-access (form required-parameters env)
   (let ((type (ecase (car form)
 		(slot-value 'reader)
 		(set-slot-value 'writer)
 		(slot-boundp 'boundp)))
-	(var (cadr form))
+	(var (un-the (cadr form)))
 	(slot-name (eval (caddr form)))) ; known to be constant
-    (when (and (consp var) (eq 'the (car var)))
-      (setq var (caddr var)))
     (when (symbolp var)
       (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))
 	     (parameter-or-nil (car (memq (or rebound? var) required-parameters))))
@@ -213,32 +128,50 @@
 				     'class parameter-or-nil env)))
 		 (class (find-class class-name nil)))
 	    (when (if (and class
-			   (memq *the-class-structure-object*
-				 (class-precedence-list class)))
+			   (class-on-class-precedence-list-p
+                             *the-class-structure-object* class))
 		      (optimize-slot-value-by-class-p class slot-name type)
 		      (and class-name (not (eq class-name 't))))
 	      (cons parameter-or-nil (or class class-name)))))))))
 
-(defun optimize-slot-value (slots sparameter form)
+(defun optimize-slot-value (generic-function method slots sparameter form)
   (if sparameter
       (destructuring-bind (ignore ignore slot-name-form) form
-	(let ((slot-name (eval slot-name-form)))
-	  (optimize-instance-access slots :read sparameter slot-name nil)))
-      `(accessor-slot-value ,@(cdr form))))
-
-(defun optimize-set-slot-value (slots sparameter form)
+	(let ((slot-name (eval slot-name-form))
+              (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
+	      (parameter (if (consp sparameter) (car sparameter) sparameter)))
+          (if (eq *boot-state* 'complete)
+	      (optimize-instance-access generic-function method class parameter
+                                        slots :read slot-name nil)
+              (optimize-std-instance-access class parameter
+                                            slots :read slot-name nil))))
+      `(fast-slot-value ,@(cdr form))))
+
+(defun optimize-set-slot-value (generic-function method slots sparameter form)
   (if sparameter
       (destructuring-bind (ignore ignore slot-name-form new-value) form
-	(let ((slot-name (eval slot-name-form)))
-	  (optimize-instance-access slots :write sparameter slot-name new-value)))
-      `(accessor-set-slot-value ,@(cdr form))))
-
-(defun optimize-slot-boundp (slots sparameter form)
+	(let ((slot-name (eval slot-name-form))
+              (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
+	      (parameter (if (consp sparameter) (car sparameter) sparameter)))
+          (if (eq *boot-state* 'complete)
+	      (optimize-instance-access generic-function method class parameter
+	                                slots :write slot-name new-value)
+	      (optimize-std-instance-access class parameter
+	                                    slots :write slot-name new-value))))
+      `(fast-set-slot-value ,@(cdr form))))
+
+(defun optimize-slot-boundp (generic-function method slots sparameter form)
   (if sparameter
       (destructuring-bind (ignore ignore slot-name-form new-value) form
-	(let ((slot-name (eval slot-name-form)))
-	  (optimize-instance-access slots :boundp sparameter slot-name new-value)))
-      `(accessor-slot-boundp ,@(cdr form))))
+	(let ((slot-name (eval slot-name-form))
+              (class (if (consp sparameter) (cdr sparameter) *the-class-t*))
+	      (parameter (if (consp sparameter) (car sparameter) sparameter)))
+          (if (eq *boot-state* 'complete)
+	      (optimize-instance-access generic-function method class parameter
+	                                slots :boundp slot-name new-value)
+	      (optimize-std-instance-access class parameter
+	                                    slots :boundp slot-name new-value))))
+      `(fast-slot-boundp ,@(cdr form))))
 
 ;;;
 ;;; The <slots> argument is an alist, the CAR of each entry is the name of
@@ -246,45 +179,41 @@
 ;;; position of an entry in the alist corresponds to the argument's position
 ;;; in the lambda list.
 ;;; 
-(defun optimize-instance-access (slots read/write sparameter slot-name new-value)
-  (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
-	(parameter (if (consp sparameter) (car sparameter) sparameter)))
-    (if (and (eq *boot-state* 'complete)
-	     (classp class)
-	     (memq *the-class-structure-object* (class-precedence-list class)))
-	(let ((slotd (find-slot-definition class slot-name)))
-	  (ecase read/write
-	    (:read
-	     `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
-	    (:write
-	     `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)
-	       ,new-value))
-	    (:boundp
-	     'T)))
-	(let* ((parameter-entry (assq parameter slots))
-	       (slot-entry      (assq slot-name (cdr parameter-entry)))
-	       (position (posq parameter-entry slots))
-	       (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
-	  (unless parameter-entry
-	    (error "Internal error in slot optimization."))
-	  (unless slot-entry
-	    (setq slot-entry (list slot-name))
-	    (push slot-entry (cdr parameter-entry)))
-	  (push pv-offset-form (cdr slot-entry))
-	  (ecase read/write
-	    (:read
-	     `(instance-read ,pv-offset-form ,parameter ,position 
-		             ',slot-name ',class))
-	    (:write
-	     `(let ((.new-value. ,new-value)) 
-	        (instance-write ,pv-offset-form ,parameter ,position 
-		                ',slot-name ',class .new-value.)))
-	    (:boundp
-	     `(instance-boundp ,pv-offset-form ,parameter ,position 
-		               ',slot-name ',class)))))))
-
-(define-walker-template pv-offset) ; These forms get munged by mutate slots.
-(defmacro pv-offset (arg) arg)
+
+(defun optimize-std-instance-access (class parameter slots read/write
+                                     slot-name new-value)
+  (let* ((parameter-entry (assq parameter slots))
+         (class-name      (if (symbolp class) class (class-name class)))
+         (slot-entry      (assq slot-name (cdr parameter-entry)))
+         (index-name
+           (or (second slot-entry)
+               (intern
+                (string-append "." (symbol-name parameter) "-"
+                               (symbol-name slot-name) "-INDEX.")))))
+    (unless parameter-entry
+      (error "Internal error in slot optimization."))
+    (unless (or slot-entry
+                (skip-fast-slot-access-p
+                  class-name slot-name
+                  (ecase read/write
+                    (:read 'reader) (:write 'writer) (:boundp 'boundp))))
+      (setq slot-entry (list slot-name index-name))
+      (push slot-entry (cdr parameter-entry)))
+    (ecase read/write
+      (:read
+       (if slot-entry
+           `(instance-read   ,parameter ',slot-name ,index-name ,class-name)
+           `(fast-slot-value ,parameter ',slot-name)))
+      (:write
+       (if slot-entry
+           `(instance-write ,parameter ',slot-name ,index-name ,class-name
+                            ,new-value)
+           `(fast-set-slot-value ,parameter ',slot-name ,new-value)))
+      (:boundp
+       (if slot-entry
+           `(instance-boundp  ,parameter ',slot-name ,index-name ,class-name)
+           `(fast-slot-boundp ,parameter ',slot-name))))))
+
 
 ;; It is safe for these two functions to be wrong.
 ;; They just try to guess what the most likely case will be.
@@ -295,230 +224,129 @@
 	 (standard-class-p class)
 	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
 	 (let ((slotd (find-slot-definition class slot-name)))
-	   (and slotd (classp (slot-definition-allocation slotd)))))))
+           (and slotd (consp (slot-definition-location slotd)))))))
 
-(defun skip-fast-slot-access-p (class-form slot-name-form type)
-  (let ((class (and (constantp class-form) (eval class-form)))
-	(slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+(defun skip-fast-slot-access-p (class-name slot-name-form type)
+  (let ((class (find-class class-name nil))
+	(slot-name
+          (cond ((symbolp slot-name-form) slot-name-form)
+                ((constantp slot-name-form) (eval slot-name-form)))))
     (and (eq *boot-state* 'complete)
 	 (standard-class-p class)
 	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
-	 (let ((slotd (find-slot-definition class slot-name)))
-	   (and slotd (skip-optimize-slot-value-by-class-p class slot-name type))))))
+         (progn
+           (unless (class-finalized-p class) (finalize-inheritance class))
+	   (let ((slotd (find-slot-definition class slot-name)))
+	     (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))))
 
 (defun skip-optimize-slot-value-by-class-p (class slot-name type)
   (let ((slotd (find-slot-definition class slot-name)))
     (and slotd
 	 (eq *boot-state* 'complete)
-	 (not (slot-accessor-std-p slotd type)))))
+	 (not (the boolean (slot-accessor-std-p slotd type))))))
 
-(defmacro instance-read (pv-offset parameter position slot-name class)
+(defmacro instance-read (parameter slot-name index class)
   (if (skip-fast-slot-access-p class slot-name 'reader)
-      `(accessor-slot-value ,parameter ,slot-name)
-      (let* ((index (gensym))
-	     (value index)
-	     (instance parameter)
-	     (slots (slot-vector-symbol position)))
-	`(locally (declare #.*optimize-speed*)
-	   (let ((,index (pvref .PV. ,pv-offset)))
-	     (setq ,value (typecase ,index
-			    ,(if (generate-fast-class-slot-access-p class slot-name)
-				 `(cons (cdr ,index))
-				 `(fixnum (%svref ,slots ,index)))
-			    (t ',*slot-unbound*)))
-	     (if (eq ,value ',*slot-unbound*)
-		 (accessor-slot-value ,instance ,slot-name)
-		 ,value))))))
-
-(defmacro instance-write (pv-offset parameter position slot-name class new-value)
+      `(fast-slot-value ,parameter ,slot-name)
+      `(optimized-parameter-read ,parameter ,slot-name ,index)))
+
+(defmacro instance-write (parameter slot-name index class new-value)
   (if (skip-fast-slot-access-p class slot-name 'writer)
-      `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
-      (let* ((index (gensym))
-	     (instance parameter)
-	     (slots (slot-vector-symbol position)))
-	`(locally (declare #.*optimize-speed*)
-	   (let ((,index (pvref .PV. ,pv-offset)))
-	     (typecase ,index
-	       ,(if (generate-fast-class-slot-access-p class slot-name)
-		    `(cons (setf (cdr ,index) ,new-value))
-		    `(fixnum (setf (%svref ,slots ,index) ,new-value)))
-	       (t (accessor-set-slot-value ,instance ,slot-name ,new-value))))))))
-
-(defmacro instance-boundp (pv-offset parameter position slot-name class)
+      `(fast-set-slot-value ,parameter ,slot-name ,new-value)
+      `(optimized-parameter-write ,parameter ,slot-name ,index ,new-value)))
+
+(defmacro instance-boundp (parameter slot-name index class)
   (if (skip-fast-slot-access-p class slot-name 'boundp)
-      `(accessor-slot-boundp ,parameter ,slot-name)
-      (let* ((index (gensym))
-	     (instance parameter)
-	     (slots (slot-vector-symbol position)))
-	`(locally (declare #.*optimize-speed*)
-	   (let ((,index (pvref .PV. ,pv-offset)))
-	     (typecase ,index
-	       ,(if (generate-fast-class-slot-access-p class slot-name)
-		    `(cons (not (eq (cdr ,index) ',*slot-unbound*)))
-		    `(fixnum (not (eq (%svref ,slots ,index) ',*slot-unbound*))))
-	       (t (accessor-slot-boundp ,instance ,slot-name))))))))
+      `(fast-slot-boundp ,parameter ,slot-name)
+      `(optimized-parameter-boundp ,parameter ,slot-name ,index)))
 
-;;;
-;;; This magic function has quite a job to do indeed.
-;;;
-;;; The careful reader will recall that <slots> contains all of the optimized
-;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.  Each of these is
-;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
-;;;
-;;; At the time these calls were produced, the first argument was specified as
-;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
-;;; arguments into the actual number that is the correct offset into the pv.
-;;;
-;;; But first, oh but first, we sort <slots> a bit so that for each argument
-;;; we have the slots in alphabetical order.  This canonicalizes the ISL's a
-;;; bit and will hopefully lead to having fewer PV's floating around.  Even
-;;; if the gain is only modest, it costs nothing.
-;;;  
-(defun slot-name-lists-from-slots (slots)
-  (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
-	  (mutate-slots slots)))
-
-(defun mutate-slots (slots)
-  (let ((sorted (sort-slots slots))
-	(pv-offset -1))
-    (dolist (parameter-entry sorted)
-      (dolist (slot-entry (cdr parameter-entry))
-	(incf pv-offset)	
-	(dolist (form (cdr slot-entry))
-	  (setf (cadr form) pv-offset))))
-    sorted))
-
-(defun symbol-pkg-name (sym) 
-  (let ((pkg (symbol-package sym)))
-    (if pkg (package-name pkg) "")))
-
-(defun sort-slots (slots)
-  (mapcar #'(lambda (parameter-entry)
-	      (cons (car parameter-entry)
-		    (sort (cdr parameter-entry)	;slot entries
-			  #'(lambda (a b)
-			      (if (eq (symbol-package (car a))
-				      (symbol-package (car b)))
-				  (string-lessp (symbol-name (car a))
-						(symbol-name (car b)))
-				  (string-lessp (symbol-pkg-name (car a))
-						(symbol-pkg-name (car b))))))))
-	  slots))
-
-
-;;;
-;;; This needs to work in terms of metatypes and also needs to work for
-;;; automatically generated reader and writer functions.
-;;; -- Automatically generated reader and writer functions do not use this stuff.
-
-(defun add-pv-binding (method-body plist required-parameters)
-  (let* ((isl (getf plist :isl))
-	 (isl-cache-symbol (make-symbol "isl-cache")))
-    (nconc plist (list :isl-cache-symbol isl-cache-symbol))
-    (with-gathering ((slot-variables (collecting))
-		     (pv-parameters (collecting)))
-      (iterate ((slots (list-elements isl))
-		(required-parameter (list-elements required-parameters))
-		(i (interval :from 0)))
-	       (when slots
-		 (gather required-parameter pv-parameters)
-		 (gather (slot-vector-symbol i) slot-variables)))
-      `((pv-binding ,slot-variables ,pv-parameters ,isl-cache-symbol
-	 ,@method-body)))))
-
-(defun make-pv-fn-form (fn-form plist)
-  (let ((isl-cache-symbol (getf plist :isl-cache-symbol)))
-    `(make-not-for-caching-method-function
-       #'(lambda (.all-wrappers.)
-	   (declare (special ,isl-cache-symbol))
-	   (let ((.ISL. *initial-isl*)
-		 (.pv-cell. nil))
-	     (declare ,(make-isl-type-declaration '.ISL.))
-	     (when .all-wrappers.
-	       (setq .isl. ,isl-cache-symbol)
-	       (let ((pv-wrappers (pv-wrappers-from-all-wrappers .isl. .all-wrappers.)))
-		 (setq .pv-cell. (isl-lookup .isl. pv-wrappers))))
-	     ,fn-form)))))
-
-(defmacro pv-binding (slot-vars pv-parameters isl-cache-symbol &body body)
-  `(multiple-value-bind (.pv. ,@slot-vars)
-       (if .all-wrappers.
-	   (values (pv-from-pv-cell .pv-cell.)
-		   ,@(mapcar #'(lambda (p) `(get-slots-or-nil ,p)) pv-parameters))
-	   (multiple-value-bind (pv-wrappers slots)
-	       (pv-wrappers-from-pv-args ,@pv-parameters)
-	     (setq .isl. ,isl-cache-symbol)
-	     (values-list (list* (pv-from-pv-cell (isl-lookup .isl. pv-wrappers))
-				 slots))))
-     (declare ,(make-pv-type-declaration '.PV.))
-     ,@body))
 
 ;;; closure-generators are used only by method-function-for-caching
 ;;; (in methods.lisp) and make-not-for-caching-method-function.
+
 (defun make-not-for-caching-method-function (closure-generator)
-  (let ((function (function-funcall closure-generator nil)))
+  (let ((function (method-function-funcall closure-generator nil)))
     #+(and kcl turbo-closure) (si:turbo-closure function)
-    (setf (method-function-closure-generator function) closure-generator)
     function))
 
-(defun pv-wrappers-from-pv-args (&rest args)
-  (let* ((nkeys (length args))
-	 (pv-wrappers (make-list nkeys))
-	 (slots (make-list nkeys))
-	 w (w-t pv-wrappers) (s-t slots))
-    (dolist (arg args)
-      (cond ((std-instance-p arg)
-	     (setq w (std-instance-wrapper arg))
-	     (unless (eq 't (wrapper-state w))
-	       (setq w (check-wrapper-validity arg)))
-	     (setf (car w-t) w)
-	     (setf (car s-t) (std-instance-slots arg)))
-	    ((fsc-instance-p arg)
-	     (setq w (fsc-instance-wrapper arg))
-	     (unless (eq 't (wrapper-state w))
-	       (setq w (check-wrapper-validity arg)))
-	     (setf (car w-t) w)
-	     (setf (car s-t) (fsc-instance-slots arg)))
-	    (t (built-in-or-structure-wrapper arg))) ; might be a structure
-      (setq w-t (cdr w-t))
-      (setq s-t (cdr s-t)))
-    (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-    (values pv-wrappers slots)))
-
-(defun pv-wrappers-from-all-wrappers (isl wrappers)
-  (let ((nkeys 0)
-	(slot-name-lists (isl-slot-name-lists isl)))
-    (dolist (sn slot-name-lists)
-      (when sn (incf nkeys)))
-    (let* ((pv-wrappers (make-list nkeys))
-	   (pv-w-t pv-wrappers)
-	   (all-std-p t))
-      (dolist (sn slot-name-lists)
-	(when sn
-	  (let ((w (car wrappers)))
-	    (unless w ; can-optimize-access prevents this from happening.
-	      (error "error in pv-wrappers-from-all-wrappers"))
-	    (setf (car pv-w-t) w)
-	    (unless (member *the-class-standard-class*
-			    (class-precedence-list (wrapper-class w)))
-	      (setq all-std-p nil))
-	    (setq pv-w-t (cdr pv-w-t))))
-	(setq wrappers (cdr wrappers)))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers)))
-
-(defun isl-lookup (isl pv-wrappers)
-  (let ((cache (isl-cache isl)))
-    (or (probe-cache cache pv-wrappers)
-	(let* ((pv-cell (make-pv-cell (lookup-pv isl pv-wrappers)))
-	       (new-cache (fill-cache cache pv-wrappers pv-cell)))
-	  (unless (eq new-cache cache)
-	    (setf (isl-cache isl) new-cache)
-	    (free-cache cache))
-	  pv-cell))))
+(declaim (ftype (function (T) boolean) all-standard-accesses-p))
+(defun all-standard-accesses-p (slot-locs-and-fetchers-and-method)
+  (let ((slot-locations (first  slot-locs-and-fetchers-and-method))
+        (slot-fetchers  (second slot-locs-and-fetchers-and-method)))
+    (and slot-locations
+         slot-fetchers
+         (every #'integerp slot-locations)
+         (every #'(lambda (x) (eq x 'std-instance-slots)) slot-fetchers))))
+
+(defun make-std-closure-generator-form
+       (generic-function method optimized-method-lambda initargs)
+  (declare (type list initargs))
+  (let ((slot-indices
+          (getf initargs :optimized-slot-indices))
+        (runtime-compile-p
+          (and (eq *boot-state* 'complete)
+               (call-store-optimized-method-lambda-p
+                 generic-function method initargs))))
+   (declare (type boolean runtime-compile-p))
+   `#'(lambda (slot-locs-and-fetchers-and-method)
+        (let (,@(mapcar
+                  #'(lambda (slot-index)
+                      `(,(third slot-index)
+                        (nth ,(posq slot-index slot-indices)
+                             (the list
+                                  (car slot-locs-and-fetchers-and-method)))))
+                  slot-indices))
+          (if (all-standard-accesses-p slot-locs-and-fetchers-and-method)
+              (macrolet
+                ((optimized-parameter-read (x slot-name index)
+                   `(locally (declare #.*optimize-speed*)
+                      (let ((.value. (%svref (std-instance-slots ,x) ,index)))
+                        (if (eq .value. *slot-unbound*)
+                            (funcall #'slot-value ,x ,slot-name)
+                            .value.))))
+                 (optimized-parameter-write (x slot-name index new)
+                   (declare (ignore slot-name))
+                   `(locally (declare #.*optimize-speed*)
+                      (setf (%svref (std-instance-slots ,x) ,index) ,new)))
+                 (optimized-parameter-boundp (x slot-name index)
+                   (declare (ignore slot-name))
+                   `(locally (declare #.*optimize-speed*)
+                      (neq (%svref (std-instance-slots ,x) ,index)
+                           *slot-unbound*))))
+               (function ,optimized-method-lambda))
+             ,(if runtime-compile-p
+                  `(make-cached-method-function-from-stored-lambda
+                      (third slot-locs-and-fetchers-and-method)
+                      slot-locs-and-fetchers-and-method)
+                `(macrolet
+                   ((optimized-parameter-read (x slot-name index)
+                     `(locally (declare #.*optimize-speed*)
+                        (let ((.value.
+                                (typecase ,index
+                                  (fixnum (%svref (get-slots ,x) ,index))
+                                  (cons   (cdr ,index))
+                                  (T      *slot-unbound*))))
+                          (if (eq .value. *slot-unbound*)
+                              (funcall #'slot-value ,x ,slot-name)
+                              .value.))))
+                    (optimized-parameter-write (x slot-name index new)
+                      (once-only (new)
+                       `(locally (declare #.*optimize-speed*)
+                          (typecase ,index
+                            (fixnum (setf (%svref (get-slots ,x) ,index) ,new))
+                            (cons   (setf (cdr ,index) ,new))
+                            (T (funcall #'set-slot-value ,x ,slot-name
+                                        ,new))))))
+                    (optimized-parameter-boundp (x slot-name index)
+                      `(locally (declare #.*optimize-speed*)
+                         (typecase ,index
+                           (fixnum (neq (%svref (get-slots ,x) ,index)
+                                        *slot-unbound*))
+                           (cons   (neq (cdr ,index) *slot-unbound*))
+                           (T      (funcall #'slot-boundp ,x ,slot-name))))))
+                  (function ,optimized-method-lambda))))))))
 
 
-
 (defmethod wrapper-fetcher ((class standard-class))
   'std-instance-wrapper)
 
@@ -528,3 +356,99 @@
 (defmethod raw-instance-allocator ((class standard-class))
   '%%allocate-instance--class)
 
+
+(defun instance-type (instance)
+  "Returns the underlying instance type of INSTANCE."
+  (cond ((std-instance-p instance)  'std-instance)
+        ((fsc-instance-p instance)  'fsc-instance)
+        #+pcl-user-instances
+        ((user-instance-p instance) 'user-instance)
+        ((structurep      instance) 'structure-instance)
+        (T (error "~S is not a standard kind of instance." instance))))
+
+(defun class-instance-type (class)
+  "Returns the underlying instance type CLASS instances."
+  (if (eq class *the-class-standard-generic-function*)
+      'fsc-instance
+      (if (class-finalized-p class)
+          (instance-type (class-prototype class))
+          (instance-type (allocate-instance class)))))
+
+;;;
+;;;   These are the basic functions to allow programmers to define their
+;;; own type of instances other than STD-INSTANCE, FSC-INSTANCE,
+;;; STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE.  It can be used for user-defined
+;;; meta-classes whose instances' underlying implementation is different
+;;; than the default PCL implementation of STD-INSTANCE for STANDARD-CLASS.
+;;; For example, the programmer can define their own user instances to be
+;;; represented as a simple-vector whose first element stores the information
+;;; needed to control the instances (e.g. a user wrapper storing the normal
+;;; PCL wrapper, the list of slot names for the class, and so on), and whose
+;;; remaining elements are the slots of the instance itself.  This kind of
+;;; defined user instance would take less space than the normal pcl
+;;; STD-INSTANCE (which is represented as a structure, one of whose elements
+;;; is another vector holding the slots), at the cost of some redefinition
+;;; flexibility.  See user-instances.lisp for an example of how this can be done.
+;;;   Defining USER-INSTANCES requires knowledge of how PCL's
+;;; wrappers and slots work internally, but the basic functions that need
+;;; to be implemented are USER-INSTANCE-P, USER-INSTANCE-WRAPPER,
+;;; SET-USER-INSTANCE-WRAPPER, USER-INSTANCE-SLOTS, and
+;;; SET-USER-INSTANCE-SLOTS.  These are analogous to STD-INSTANCE-P,
+;;; STD-INSTANCE-WRAPPER, etc., and must return the same thing that they
+;;; would.
+;;;   Contact Trent Lange (lange@cs.ucla.edu) for any questions.
+;;; The feature :PCL-USER-INSTANCES must be pushed onto the lisp *FEATURES*
+;;; list in low.lisp to turn this feature on.
+;;;
+
+#+pcl-user-instances
+(progn
+(proclaim '(notinline user-instance-p
+                      user-instance-wrapper
+                      user-instance-slots
+                      set-user-instance-wrapper
+                      set-user-instance-slots))
+
+(defun user-instance-p (x)
+  (declare (ignore x))
+  NIL)
+
+(defun user-instance-wrapper (x)
+  (declare (ignore x))
+  (error "No user-instance-wrapper function defined for user instances."))
+
+(defun set-user-instance-wrapper (x nv)
+  (declare (ignore x nv))
+  (error "No set-user-instance-wrapper function defined for user instances."))
+
+(defun user-instance-slots (x)
+  (declare (ignore x))
+  (error "No user-instance-slots function defined for user instances."))
+
+(defun set-user-instance-slots (x nv)
+  (declare (ignore x nv))
+  (error "No set-user-instance-slots function defined for user instances."))
+
+(defsetf user-instance-wrapper set-user-instance-wrapper)
+(defsetf user-instance-slots   set-user-instance-slots)
+
+;;; The following three macros are used by PCL as hooks to call the three
+;;; user-instance functions.  They can be redefined for particular
+;;; instantiations of the user-instance instances to return the same
+;;; values the functions would, but to work faster by avoiding the
+;;; function call.
+
+(defmacro get-user-instance-p (x)
+  `(user-instance-p ,x))
+
+(defmacro get-user-instance-wrapper (x)
+  `(user-instance-wrapper ,x))
+
+(defmacro get-user-instance-slots (x)
+  `(user-instance-slots ,x))
+
+(defmacro fast-check-user-wrapper-validity (object)
+  `(fast-check-wrapper-validity ,object get-user-instance-wrapper))
+
+) ;+pcl-user-instances
+
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
index 28375fd55..6d26a482a 100644
--- a/pcl/walk.lisp
+++ b/pcl/walk.lisp
@@ -986,11 +986,11 @@
       entry)))
 
 
-(defvar *VARIABLE-DECLARATIONS* '(special))
+(defvar *VARIABLE-DECLARATIONS* (list 'special))
 
 (defun VARIABLE-DECLARATION (declaration var env)
   (if (not (member declaration *variable-declarations*))
-      (error "~S is not a recognized variable declaration." declaration)
+      (error "~S is not a reckognized variable declaration." declaration)
       (let ((id (or (variable-lexical-p var env) var)))
 	(dolist (decl (env-declarations env))
 	  (when (and (eq (car decl) declaration)
@@ -1156,7 +1156,6 @@
 (define-walker-template SYMBOL-MACROLET      walk-symbol-macrolet)
 (define-walker-template TAGBODY              walk-tagbody)
 (define-walker-template THE                  (NIL QUOTE EVAL))
-#+cmu(define-walker-template EXT:TRULY-THE   (NIL QUOTE EVAL))
 (define-walker-template THROW                (NIL EVAL EVAL))
 (define-walker-template UNWIND-PROTECT       (NIL RETURN REPEAT (EVAL)))
 
@@ -1296,6 +1295,8 @@
 ;;;     3. Otherwise, assume it is a function call. "
 ;;;     
 
+(defvar walk-form-expand-macros-p nil)
+
 (defun walk-form-internal (form context env)
   ;; First apply the walk-function to perform whatever translation
   ;; the user wants to this form.  If the second value returned
@@ -1314,7 +1315,7 @@
 		(let ((newnewform (walk-form-internal (cddr symmac)
 						      context env)))
 		  (if (eq newnewform (cddr symmac))
-		      newform
+		      (if walk-form-expand-macros-p newnewform newform)
 		      newnewform))
 		newform)))
 	 (t
@@ -1334,7 +1335,7 @@
 		    (let ((newnewnewform (walk-form-internal newnewform context
 							     env)))
 		      (if (eq newnewnewform newnewform)
-			  newform
+			  (if walk-form-expand-macros-p newnewform newform)
 			  newnewnewform)))
 		   ((and (symbolp fn)
 			 (not (fboundp fn))
@@ -1362,7 +1363,7 @@
         ((LAMBDA CALL)
 	 (cond ((or (symbolp form)
 		    (and (listp form)
-			 (= (length form) 2)
+			 (= (length (the list form)) 2)
 			 (eq (car form) 'setf)))
 		form)
 	       #+Lispm
@@ -1377,9 +1378,10 @@
 				       ;; call to length.
 				       (if (null (cddr template))
 					   ()
-					   (nthcdr (- (length form)
+					   (nthcdr (- (length (the list form))
 						      (length
-							(cddr template)))
+							(the list
+                                                             (cddr template))))
 						   form))
                                        context
 				       env))
@@ -1524,7 +1526,7 @@
 					 &aux arg)
   (cond ((null arglist) ())
         ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords)
+         (or (member arg lambda-list-keywords :test #'eq)
              (note-lexical-binding arg env))
          (recons arglist
                  arg
@@ -1533,24 +1535,26 @@
 			       env
                                (and destructuringp
 				    (not (member arg
-						 lambda-list-keywords))))))
+						 lambda-list-keywords
+                                                 :test #'eq))))))
         ((consp arg)
-         (prog1 (if destructuringp
-                    (walk-arglist arg context env destructuringp)
-                    (recons arglist
-                            (relist* arg
-                                     (car arg)
-                                     (walk-form-internal (cadr arg) :eval env)
-                                     (cddr arg))
-                            (walk-arglist (cdr arglist) context env nil)))
-                (if (symbolp (car arg))
-                    (note-lexical-binding (car arg) env)
-                    (note-lexical-binding (cadar arg) env))
-                (or (null (cddr arg))
-                    (not (symbolp (caddr arg)))
-                    (note-lexical-binding (caddr arg) env))))
-          (t
-	   (error "Can't understand something in the arglist ~S" arglist))))
+         (prog1
+	     (recons arglist
+		     (if destructuringp
+			 (walk-arglist arg context env destructuringp)
+			 (relist* arg
+				  (car arg)
+				  (walk-form-internal (cadr arg) :eval env)
+				  (cddr arg)))
+		     (walk-arglist (cdr arglist) context env nil))
+	   (if (symbolp (car arg))
+	       (note-lexical-binding (car arg) env)
+	       (note-lexical-binding (cadar arg) env))
+	   (or (null (cddr arg))
+	       (not (symbolp (caddr arg)))
+	       (note-lexical-binding (caddr arg) env))))
+	(t
+	 (error "Can't understand something in the arglist ~S" arglist))))
 
 (defun walk-let (form context env)
   (walk-let/let* form context env nil))
@@ -1652,11 +1656,18 @@
     (if (some #'(lambda (var)
 		  (variable-symbol-macro-p var env))
 	      vars)
-	(let* ((temps (mapcar #'(lambda (var) (declare (ignore var)) (gensym)) vars))
-	       (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp)) vars temps))
-	       (expanded `(multiple-value-bind ,temps 
-			       ,(caddr form)
-			     ,@sets))
+	(let* ((expanded
+                 (let ((sets NIL)
+                       (temps NIL)
+                       (temp NIL))
+                   (dolist (var vars)
+                     (setf temp (gensym))
+                     (push `(setq ,var ,temp) sets)
+                     (push temp temps))
+                  `(multiple-value-bind
+                      ,(nreverse temps)
+                      ,(caddr form)
+                     ,@(nreverse sets))))
 	       (walked (walk-form-internal expanded context env)))
 	  (if (eq walked expanded)
 	      form
@@ -1756,11 +1767,13 @@
 
 (defun walk-setq (form context env)
   (if (cdddr form)
-      (let* ((expanded (let ((rforms nil)
-			     (tail (cdr form)))
-			 (loop (when (null tail) (return (nreverse rforms)))
-			       (let ((var (pop tail)) (val (pop tail)))
-				 (push `(setq ,var ,val) rforms)))))
+      (let* ((expanded
+               (let ((collect NIL)
+                     (ptr (cdr form)))
+                 (loop (push `(setq ,(car ptr) ,(cadr ptr)) collect)
+                       (setf ptr (cddr ptr))
+                       (unless ptr
+                         (return (nreverse collect))))))
 	     (walked (walk-repeat-eval expanded env)))
 	(if (eq expanded walked)
 	    form
@@ -1891,7 +1904,7 @@
                        Even if this is what~%~
                        you intended, you should fix your source code."
 		      form
-		      (length (cdr form)))
+		      (length (the list (cdr form))))
 		(cons 'progn (cdddr form)))
 	      (cadddr form))))
     (relist form
-- 
GitLab