From b26a095ed26e1e842d854bdbad0910cf0aab89b2 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 9 Nov 1992 15:22:22 +0000
Subject: [PATCH] This is September 92 PCL.

---
 pcl/boot.lisp              | 3467 +++++++++++++++++-------------------
 pcl/braid.lisp             | 1094 +++++-------
 pcl/cache.lisp             |  953 +++++-----
 pcl/cmu-low.lisp           |  404 ++++-
 pcl/combin.lisp            |  502 +++---
 pcl/construct.lisp         |  131 +-
 pcl/cpatch.lisp            |    5 -
 pcl/cpl.lisp               |    8 +-
 pcl/defclass.lisp          |  427 ++---
 pcl/defcombin.lisp         |   54 +-
 pcl/defs.lisp              |  429 +++--
 pcl/defsys.lisp            |  289 ++-
 pcl/dfun.lisp              | 1195 ++++++++++---
 pcl/dlap.lisp              |  190 +-
 pcl/env.lisp               |  431 ++---
 pcl/excl-low.lisp          |   51 +-
 pcl/fin.lisp               |  102 +-
 pcl/fixup.lisp             |    1 -
 pcl/fngen.lisp             |   66 +-
 pcl/fsc.lisp               |   49 +-
 pcl/genera-low.lisp        |    2 +-
 pcl/generic-functions.lisp |  866 ++++++---
 pcl/ibcl-low.lisp          |    5 -
 pcl/init.lisp              |  370 ++--
 pcl/iterate.lisp           |   20 +-
 pcl/kcl-low.lisp           |  173 +-
 pcl/kcl-patches.lisp       |  104 +-
 pcl/lap.lisp               |   39 +-
 pcl/list-functions.lisp    |   76 +-
 pcl/low.lisp               |  704 +++-----
 pcl/lucid-low.lisp         |   66 +-
 pcl/macros.lisp            |  397 ++---
 pcl/methods.lisp           | 2412 ++++++-------------------
 pcl/notes.text             |  465 ++---
 pcl/pcl-env.lisp           |   16 +-
 pcl/pkg.lisp               |   39 +-
 pcl/plap.lisp              |  112 +-
 pcl/quadlap.lisp           |   13 +-
 pcl/slots.lisp             | 1396 +++------------
 pcl/std-class.lisp         | 1322 +++++---------
 pcl/sys-package.lisp       |   19 +-
 pcl/sys-proclaim.lisp      | 2112 +++++++++++-----------
 pcl/sysdef.lisp            |   54 +-
 pcl/time.lisp              |   68 +-
 pcl/vector.lisp            | 1265 +++++++++----
 pcl/walk.lisp              |  138 +-
 46 files changed, 10347 insertions(+), 11754 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 890ccd00e..80572e3d2 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -72,40 +72,19 @@ work during bootstrapping.
 |#
 
 (proclaim '(notinline make-a-method
-                      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-named-method		      
+		      ensure-generic-function-using-class
 
-                      ensure-generic-function-using-class
-
-                      add-method
-                      remove-method
-                      ))
+		      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)
-          (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)
-          ))
+	'((make-a-method early-make-a-method
+			 real-make-a-method)
+	  (add-named-method early-add-named-method
+			    real-add-named-method)
+	  ))
 
 ;;;
 ;;; For each of the early functions, arrange to have it point to its early
@@ -119,16 +98,18 @@ work during bootstrapping.
 ;;;
 (eval-when (load eval)
 
-  (defun redirect-early-function-internal (to)
-    #'(lambda (&rest args) (apply-function (symbol-function to) args)))
-  
-  (dolist (fns *early-functions*)
-    (let ((name (car fns))
-          (early-name (cadr fns)))
-      (setf (symbol-function name)
-            (redirect-early-function-internal early-name))))
+(defun redirect-early-function-internal (real early)
+  (setf (symbol-function real)
+	(set-function-name
+	 #'(lambda (&rest args) (apply (symbol-function early) args))
+	 real)))
+
+(dolist (fns *early-functions*)
+  (let ((name (car fns))
+	(early-name (cadr fns)))
+    (redirect-early-function-internal name early-name)))
 
-  )
+)
 
 
 ;;;
@@ -138,28 +119,40 @@ 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)
-         (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))
+			   &key generic-function-class environment
+			   &allow-other-keys)
+	 (null t)
+	 real-ensure-gf-using-class--null))
+      (make-method-lambda
+       ((proto-generic-function proto-method lambda-expression environment)
+	(standard-generic-function standard-method t t)
+	real-make-method-lambda))
+      (make-method-initargs-form
+       ((proto-generic-function proto-method lambda-expression lambda-list environment)
+	(standard-generic-function standard-method t t t)
+	real-make-method-initargs-form))
+      (compute-effective-method
+       ((generic-function combin applicable-methods)
+	(generic-function standard-method-combination t)
+	standard-compute-effective-method))
       ))
 
 
@@ -169,100 +162,95 @@ 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 ())
-        (methods  ()))
+  (let ((initargs ()))
     (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
-              (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)))))
-
+		   (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)))))
 
 (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-gf
-            (prototype-of-generic-function name))
-          (proto-method
-            (method-prototype-for-gf name)))
-      (expand-defmethod
-        proto-gf proto-method name qualifiers lambda-list body env))))
+    (multiple-value-bind (proto-gf proto-method)
+	(prototypes-for-make-method-lambda name)
+      (expand-defmethod name proto-gf proto-method
+			qualifiers lambda-list body env))))
+
+(defun prototypes-for-make-method-lambda (name)
+  (if (not (eq *boot-state* 'complete))	  
+      (values nil nil)
+      (let ((gf? (and (gboundp name)
+		      (gdefinition name))))
+	(if (or (null gf?)
+		(not (generic-function-p gf?)))
+	    (values (class-prototype (find-class 'standard-generic-function))
+		    (class-prototype (find-class 'standard-method)))
+	    (values gf?
+		    (class-prototype (or (generic-function-method-class gf?)
+					 (find-class 'standard-method))))))))
 
 ;;;
 ;;; takes a name which is either a generic function name or a list specifying
@@ -279,1221 +267,955 @@ 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
-            (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?))))
+	  ((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)))))))
 
 
-(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-generic-function proto-method name qualifiers lambda-list
-        body env)
-  (when (listp name) (do-standard-defsetf-1 (cadr name)))
-  (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*
-      `(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
-          ,(if method-lambda `(function ,method-lambda))
-          ,(if optimized-method-lambda `(function ,optimized-method-lambda))
-          ,closure-generator
-          ',initargs)))))
-
-#||
-#+Genera
-(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
+
+(defun expand-defmethod (name proto-gf proto-method 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)
-    (let ((fn-args (cadadr fn-form))
-          (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)))))
-||#
-
-(defvar *expand-defmethod-internal-real-body* NIL)
-
-(defun expand-defmethod-internal
-       (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)))
+  (let ((*make-instance-function-keys* nil))
+    (declare (special *make-instance-function-keys*))
+    (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
+	(add-method-declarations name qualifiers lambda-list body env)
+      (multiple-value-bind (method-function-lambda initargs)
+	  (make-method-lambda proto-gf proto-method method-lambda env)
+	(let ((initargs-form (make-method-initargs-form 
+			      proto-gf proto-method
+			      method-function-lambda initargs env)))
+	  `(progn
+	     (proclaim-defgeneric ',name ',lambda-list)
+	     ,@(when *make-instance-function-keys*
+		 `((get-make-instance-functions ',*make-instance-function-keys*)))
+	     ,(make-defmethod-form name qualifiers specializers
+				   unspecialized-lambda-list
+				   (if proto-method
+				       (class-name (class-of proto-method))
+				       'standard-method)
+				   initargs-form
+	                           (getf (getf initargs ':plist)
+				         ':pv-table-symbol))))))))
+
+(defun interned-symbol-p (x)
+  (and (symbolp x) (symbol-package x)))
+
+(defun make-defmethod-form (name qualifiers specializers
+				 unspecialized-lambda-list method-class-name
+				 initargs-form &optional pv-table-symbol)
+  (let (fn fn-lambda)
+    (if (and (interned-symbol-p (if (consp name)
+				    (and (eq (car name) 'setf) (cadr name))
+				    name))
+	     (every #'interned-symbol-p qualifiers)
+	     (every #'(lambda (s)
+			(if (consp s)
+			    (and (eq (car s) 'eql) 
+				 (constantp (cadr s))
+				 (let ((sv (eval (cadr s))))
+				   (or (interned-symbol-p sv)
+				       (integerp sv)
+				       (standard-char-p sv))))
+			    (interned-symbol-p s)))
+		    specializers)
+	     (consp initargs-form)
+	     (eq (car initargs-form) 'list*)
+	     (memq (cadr initargs-form) '(:function :fast-function))
+	     (consp (setq fn (caddr initargs-form)))
+	     (eq (car fn) 'function)
+	     (consp (setq fn-lambda (cadr fn)))
+	     (eq (car fn-lambda) 'lambda))
+	(let* ((specls (mapcar #'(lambda (specl)
+				   (if (consp specl)
+				       `(,(car specl) ,(eval (cadr specl)))
+				       specl))
+			       specializers))
+	       (mname `(,(if (eq (cadr initargs-form) ':function)
+			     'method 'fast-method)
+			,name ,@qualifiers ,specls))
+	       (mname-sym (intern (let ((*print-pretty* nil))
+				    (format nil "~S" mname)))))
+	  `(eval-when ,*defmethod-times*
+	    (defun ,mname-sym ,(cadr fn-lambda)
+	      ,@(cddr fn-lambda))
+	    ,(make-defmethod-form-internal 
+	      name qualifiers `',specls
+	      unspecialized-lambda-list method-class-name
+	      `(list* ,(cadr initargs-form) #',mname-sym ,@(cdddr initargs-form))
+	      pv-table-symbol)))
+	(make-top-level-form 
+	 `(defmethod ,name ,@qualifiers ,specializers)
+	 *defmethod-times*
+	 (make-defmethod-form-internal 
+	  name qualifiers 
+	  `(list ,@(mapcar #'(lambda (specializer)
+			       (if (consp specializer)
+				   ``(,',(car specializer) ,,(cadr specializer))
+				   `',specializer))
+		    specializers))
+	  unspecialized-lambda-list method-class-name
+	  initargs-form
+	  pv-table-symbol)))))
+
+(defun make-defmethod-form-internal (name qualifiers specializers-form
+					  unspecialized-lambda-list method-class-name
+					  initargs-form &optional pv-table-symbol)
+  `(load-defmethod
+    ',method-class-name
+    ',name
+    ',qualifiers
+    ,specializers-form
+    ',unspecialized-lambda-list
+    ,initargs-form
+    ;;Paper over a bug in KCL by passing the cache-symbol
+    ;;here in addition to in the list.
+    ',pv-table-symbol))
+
+(defmacro make-method-function (method-lambda &environment env)
+  (make-method-function-internal method-lambda env))
+
+(defun make-method-function-internal (method-lambda &optional env)
+  (multiple-value-bind (proto-gf proto-method)
+	(prototypes-for-make-method-lambda nil)
+    (multiple-value-bind (method-function-lambda initargs)
+	(make-method-lambda proto-gf proto-method method-lambda env)
+      (make-method-initargs-form proto-gf proto-method
+				 method-function-lambda initargs env))))
+
+(defun add-method-declarations (name qualifiers lambda-list body env)
+  (multiple-value-bind (parameters unspecialized-lambda-list specializers)
+      (parse-specialized-lambda-list lambda-list)
+    (declare (ignore parameters))
+    (multiple-value-bind (documentation declarations real-body)
+	(extract-declarations body env)
+      (values `(lambda ,unspecialized-lambda-list
+		 ,@(when documentation `(,documentation))
+		 (declare (method-name ,(list name qualifiers specializers)))
+		 (declare (method-lambda-list ,@lambda-list))
+		 ,@declarations
+		 ,@real-body)
+	      unspecialized-lambda-list specializers))))
+
+(defun real-make-method-initargs-form (proto-gf proto-method 
+				       method-lambda initargs env)
+  (declare (ignore proto-gf proto-method))
+  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+    (error "The method-lambda argument to make-method-function, ~S,~
+            is not a lambda form" method-lambda))
+  (make-method-initargs-form-internal method-lambda initargs env))
+
+(unless (fboundp 'make-method-initargs-form)
+  (setf (symbol-function 'make-method-initargs-form)
+	(symbol-function 'real-make-method-initargs-form)))
+
+(defun real-make-method-lambda (proto-gf proto-method method-lambda env)
+  (declare (ignore proto-gf proto-method))
+  (make-method-lambda-internal method-lambda env))
+
+(defun make-method-lambda-internal (method-lambda &optional env)
+  (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+    (error "The method-lambda argument to make-method-lambda, ~S,~
+            is not a lambda form" method-lambda))
   (multiple-value-bind (documentation declarations real-body)
-      (extract-declarations body)
-    (multiple-value-bind (parameters lambda-list specializers)
-        (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))))
-             (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
-         (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 generic-function method
-                                                  slots parameter form))
-                            (set-slot-value
-                             (optimize-set-slot-value generic-function method
-                                                      slots parameter form))
-                            (slot-boundp
-                             (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))
-                  (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
-                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
-            (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."))))
+      (extract-declarations (cddr method-lambda) env)
+    (let* ((name-decl (get-declaration 'method-name declarations))
+	   (sll-decl (get-declaration 'method-lambda-list declarations))
+	   (method-name (when (consp name-decl) (car name-decl)))
+	   (generic-function-name (when method-name (car method-name)))
+	   (specialized-lambda-list (or sll-decl (cadr method-lambda))))
+      (multiple-value-bind (parameters lambda-list specializers)
+	  (parse-specialized-lambda-list specialized-lambda-list)
+	(let* ((required-parameters
+		(mapcar #'(lambda (r s) (declare (ignore s)) r)
+			parameters
+			specializers))
+	       (slots (mapcar #'list required-parameters))
+	       (calls (list nil))
+	       (parameters-to-reference
+		(make-parameter-references specialized-lambda-list
+					   required-parameters
+					   declarations
+					   method-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.
+		  `(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)
+			  ()))
+	       (applyp (dolist (p lambda-list nil)
+			 (cond ((memq p '(&optional &rest &key))
+				(return t))
+			       ((eq p '&aux)
+				(return nil))))))
+	    (multiple-value-bind (walked-lambda call-next-method-p closurep
+						next-method-p-p)
+		(walk-method-lambda method-lambda required-parameters env 
+				    slots calls)
+	      (multiple-value-bind (ignore walked-declarations walked-lambda-body)
+		  (extract-declarations (cddr walked-lambda))
+		(declare (ignore ignore))
+		(when (or next-method-p-p call-next-method-p)
+		  (setq plist (list* :needs-next-methods-p 't plist)))
+		(when (some #'cdr slots)
+		  (multiple-value-bind (slot-name-lists call-list)
+		      (slot-name-lists-from-slots slots calls)
+		    (let ((pv-table-symbol (make-symbol "pv-table")))
+		      (setq plist 
+			    `(,@(when slot-name-lists 
+				  `(:slot-name-lists ,slot-name-lists))
+			      ,@(when call-list
+				  `(:call-list ,call-list))
+			      :pv-table-symbol ,pv-table-symbol
+			      ,@plist))
+		      (setq walked-lambda-body
+			    `((pv-binding (,required-parameters ,slot-name-lists
+					   ,pv-table-symbol)
+			       ,@walked-lambda-body))))))
+		(when (and (memq '&key lambda-list)
+			   (not (memq '&allow-other-keys lambda-list)))
+		  (let ((aux (memq '&aux lambda-list)))
+		    (setq lambda-list (nconc (ldiff lambda-list aux)
+					     (list '&allow-other-keys)
+					     aux))))
+		(values `(lambda (.method-args. .next-methods.)
+			   (simple-lexical-method-functions
+			       (,lambda-list .method-args. .next-methods.
+				:call-next-method-p ,call-next-method-p 
+				:next-method-p-p ,next-method-p-p
+				:closurep ,closurep
+				:applyp ,applyp)
+			     ,@walked-declarations
+			     ,@walked-lambda-body))
+			`(,@(when plist 
+			      `(:plist ,plist))
+			  ,@(when documentation 
+			      `(:documentation ,documentation)))))))))))
+		 
+(unless (fboundp 'make-method-lambda)
+  (setf (symbol-function 'make-method-lambda)
+	(symbol-function 'real-make-method-lambda)))
+
+(defmacro simple-lexical-method-functions ((lambda-list method-args next-methods
+							&rest lmf-options) 
+					   &body body)
+  `(progn
+     ,method-args ,next-methods
+     (bind-simple-lexical-method-macros (,method-args ,next-methods)
+       (bind-lexical-method-functions (,@lmf-options)
+         (bind-args (,lambda-list ,method-args)
+	   ,@body)))))
+
+(defmacro fast-lexical-method-functions ((lambda-list next-method-call args rest-arg
+						      &rest lmf-options)
+					 &body body)
+ `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
+    (bind-lexical-method-functions (,@lmf-options)
+      (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
+        ,@body))))
+
+(defmacro bind-simple-lexical-method-macros ((method-args next-methods) &body body)
+  `(macrolet ((call-next-method-bind (&body body)
+		`(let ((.next-method. (car ,',next-methods))
+		       (,',next-methods (cdr ,',next-methods)))
+		   .next-method. ,',next-methods
+		   ,@body))
+	      (call-next-method-body (cnm-args)
+		`(if .next-method.
+		     (funcall (if (std-instance-p .next-method.)
+				  (method-function .next-method.)
+				  .next-method.) ; for early methods
+			      (or ,cnm-args ,',method-args)
+		              ,',next-methods)
+		     (error "No next method.")))
+	      (next-method-p-body ()
+	        `(not (null .next-method.))))
+     ,@body))
+
+(defstruct method-call
+  (function #'identity :type function)
+  call-method-args)
+
+(defmacro invoke-method-call1 (function args cm-args)
+  `(let ((.function. ,function)
+	 (.args. ,args)
+	 (.cm-args. ,cm-args))
+     (if (and .cm-args. (null (cdr .cm-args.)))
+	 (funcall .function. .args. (car .cm-args.))
+	 (apply .function. .args. .cm-args.))))
+
+(defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
+  `(invoke-method-call1 (method-call-function ,method-call)
+                        ,(if restp
+			     `(list* ,@required-args+rest-arg)
+			     `(list ,@required-args+rest-arg))
+                        (method-call-call-method-args ,method-call)))
+
+(defstruct fast-method-call
+  (function #'identity :type function)
+  pv-cell
+  next-method-call
+  arg-info)
+
+#-akcl
+(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
+  `(funcall ,fn ,pv-cell ,next-method-call ,@args))
+
+(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
+  `(fmc-funcall (fast-method-call-function ,method-call)
+                (fast-method-call-pv-cell ,method-call)
+                (fast-method-call-next-method-call ,method-call)
+                ,@required-args+rest-arg))
+
+(defstruct fast-instance-boundp
+  (index 0 :type fixnum))
+
+(eval-when (compile load eval)
+(defvar *allow-emf-call-tracing-p* t)
+(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
+)
+
+(defvar *emf-call-trace-size* 200)
+(defvar *emf-call-trace* nil)
+(defvar emf-call-trace-index 0)
+
+(defun show-emf-call-trace ()
+  (when *emf-call-trace*
+    (let ((j emf-call-trace-index)
+	  (*enable-emf-call-tracing-p* nil))
+      (format t "~&(The oldest entries are printed first)~%")
+      (dotimes (i *emf-call-trace-size*)
+	(let ((ct (aref *emf-call-trace* j)))
+	  (when ct (print ct)))
+	(incf j)
+	(when (= j *emf-call-trace-size*)
+	  (setq j 0))))))
+
+(defun trace-emf-call-internal (emf format args)
+  (unless *emf-call-trace*
+    (setq *emf-call-trace* (make-array *emf-call-trace-size*)))
+  (setf (aref *emf-call-trace* emf-call-trace-index)
+	(list* emf format args))
+  (incf emf-call-trace-index)
+  (when (= emf-call-trace-index *emf-call-trace-size*)
+    (setq emf-call-trace-index 0)))
+
+(defmacro trace-emf-call (emf format args)
+  (when *allow-emf-call-tracing-p*
+    `(when *enable-emf-call-tracing-p*
+       (trace-emf-call-internal ,emf ,format ,args))))
+
+(defmacro invoke-effective-method-function-fast
+    (emf restp &rest required-args+rest-arg)
+  `(progn
+     (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
+     (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
+
+(defmacro invoke-effective-method-function (emf restp &rest required-args+rest-arg)
+  (unless (constantp restp)
+    (error "The restp argument to invoke-effective-method-function is not constant"))
+  (setq restp (eval restp))
+  `(progn
+     (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
+     (cond (#-(or lucid excl) (typep ,emf 'fast-method-call)
+	    #+(or lucid excl) (fast-method-call-p ,emf)
+	     (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+	   ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
+	       `(((typep ,emf 'fixnum)
+		  (let* ((.slots. (get-slots-or-nil ,(car required-args+rest-arg)))
+			 (value (when .slots. (%instance-ref .slots. ,emf))))
+		    (if (eq value ',*slot-unbound*)
+			(slot-unbound-internal ,(car required-args+rest-arg) ,emf)
+			value)))))
+	   ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
+	       `(((typep ,emf 'fixnum)
+		  (let ((.new-value. ,(car required-args+rest-arg))
+			(.slots. (get-slots-or-nil ,(car required-args+rest-arg))))
+		    (when .slots. ; just to avoid compiler wranings
+		      (setf (%instance-ref .slots. ,emf) .new-value.))))))
+	   #|| 
+	   ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
+	       `(((typep ,emf 'fast-instance-boundp)
+		  (let ((.slots. (get-slots-or-nil ,(car required-args+rest-arg))))
+		    (and .slots.
+			 (not (eq (%instance-ref .slots.
+						 (fast-instance-boundp-index ,emf))
+				  ',*slot-unbound*)))))))
+	   ||#
+	   (t
+	    (etypecase ,emf
+	      (method-call
+	       (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
+	      (function
+	       ,(if restp
+		    `(apply ,emf ,@required-args+rest-arg)
+		    `(funcall ,emf ,@required-args+rest-arg))))))))
+
+(defun invoke-emf (emf args)
+  (trace-emf-call emf t args)
+  (etypecase emf
+    (fast-method-call
+     (let* ((arg-info (fast-method-call-arg-info emf))
+	    (restp (cdr arg-info))
+	    (nreq (car arg-info)))
+       (if restp
+	   (let* ((rest-args (nthcdr nreq args))
+		  (req-args (ldiff args rest-args)))
+	     (apply (fast-method-call-function emf)
+		    (fast-method-call-pv-cell emf)
+		    (fast-method-call-next-method-call emf)
+		    (nconc req-args (list rest-args))))
+	   (cond ((null args)
+		  (if (eql nreq 0) 
+		      (invoke-fast-method-call emf)
+		      (error "wrong number of args")))
+		 ((null (cdr args))
+		  (if (eql nreq 1) 
+		      (invoke-fast-method-call emf (car args))
+		      (error "wrong number of args")))
+		 ((null (cddr args))
+		  (if (eql nreq 2) 
+		      (invoke-fast-method-call emf (car args) (cadr args))
+		      (error "wrong number of args")))
+		 (t
+		  (apply (fast-method-call-function emf)
+			 (fast-method-call-pv-cell emf)
+			 (fast-method-call-next-method-call emf)
+			 args))))))
+    (method-call 
+     (apply (method-call-function emf)
+	    args
+	    (method-call-call-method-args emf)))
+    (fixnum 
+     (cond ((null args) (error "1 or 2 args expected"))
+	   ((null (cdr args))
+	    (let ((value (%instance-ref (get-slots (car args)) emf)))
+	      (if (eq value *slot-unbound*)
+		  (slot-unbound-internal (car args) emf)
+		  value)))
+	   ((null (cddr args))
+	    (setf (%instance-ref (get-slots (cadr args)) emf)
+		  (car args)))
+	   (t (error "1 or 2 args expected"))))
+    (fast-instance-boundp
+     (if (or (null args) (cdr args))
+	 (error "1 arg expected")
+	 (not (eq (%instance-ref (get-slots (car args)) 
+				 (fast-instance-boundp-index emf))
+		  *slot-unbound*))))
+    (function
+     (apply emf args))))
+
+;; This can be improved alot.
+(defun gf-make-function-from-emf (gf emf)
+  (etypecase emf
+    (fast-method-call (let* ((arg-info (gf-arg-info gf))
+			     (nreq (arg-info-number-required arg-info))
+			     (restp (arg-info-applyp arg-info)))
+			#'(lambda (&rest args)
+			    (trace-emf-call emf t args)
+			    (apply (fast-method-call-function emf)
+				   (fast-method-call-pv-cell emf)
+				   (fast-method-call-next-method-call emf)
+				   (if restp
+				       (let* ((rest-args (nthcdr nreq args))
+					      (req-args (ldiff args rest-args)))
+					 (nconc req-args rest-args))
+				       args)))))
+    (method-call #'(lambda (&rest args)
+		     (trace-emf-call emf t args)
+		     (apply (method-call-function emf)
+			args
+			(method-call-call-method-args emf))))
+    (function emf)))
+
+(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
+					   &body body)
+  `(macrolet ((call-next-method-bind (&body body)
+		`(let () ,@body))
+	      (call-next-method-body (cnm-args)
+		`(if ,',next-method-call
+		     ,(if (and (null ',rest-arg)
+			       (consp cnm-args)
+			       (eq (car cnm-args) 'list))
+			  `(invoke-effective-method-function
+			    ,',next-method-call nil
+			    ,@(cdr cnm-args))
+			  (let ((call `(invoke-effective-method-function
+					,',next-method-call 
+					,',(not (null rest-arg))
+					,@',args 
+					,@',(when rest-arg `(,rest-arg)))))
+			    `(if ,cnm-args
+				 (bind-args ((,@',args ,@',(when rest-arg
+							     `(&rest ,rest-arg)))
+					     ,cnm-args)
+					    ,call)
+				 ,call)))
+		     (error "No next method.")))
+	      (next-method-p-body ()
+	        `(not (null ,',next-method-call))))
+     ,@body))
+
+(defmacro bind-lexical-method-functions 
+    ((&key call-next-method-p next-method-p-p closurep applyp)
+     &body body)
+  (cond ((and (null call-next-method-p) (null next-method-p-p)
+	      (null closurep)
+	      (null applyp))
+	 `(let () ,@body))
+	 ((and (null closurep)
+	       (null applyp))
+	 ;; OK to use MACROLET, and all args are mandatory 
+	 ;; (else APPLYP would be true).
+	 `(call-next-method-bind
+	    (macrolet ((call-next-method (&rest cnm-args)
+			 `(call-next-method-body ,(when cnm-args `(list ,@cnm-args))))
+		       (next-method-p ()
+			 `(next-method-p-body)))
+	       ,@body)))
+	(t
+	 `(call-next-method-bind
+	    (flet (,@(and call-next-method-p
+		       '((call-next-method (&rest cnm-args)
+			  #+Genera
+			  (declare (dbg:invisible-frame :clos-internal))
+			  (call-next-method-body cnm-args))))
+		     ,@(and next-method-p-p
+			 '((next-method-p ()
+			    (next-method-p-body)))))
+	      ,@body)))))
+
+(defmacro bind-args ((lambda-list args) &body body)
+  #|| ; Lucid and Allegro don't compile the function inline
+  `(apply #'(lambda ,lambda-list ,@body) ,args)
+  ||#
+  (let ((args-tail '.args-tail.)
+	(key '.key.)
+	(state 'required))
+    (flet ((process-var (var)
+	     (if (memq var lambda-list-keywords)
+		 (progn
+		   (case var
+		     (&optional         (setq state 'optional))
+		     (&key              (setq state 'key))
+		     (&allow-other-keys)
+		     (&rest             (setq state 'rest))
+		     (&aux              (setq state 'aux))
+		     (otherwise
+		      (error "Encountered the non-standard lambda list keyword ~S."
+			     var)))
+		   nil)
+		 (case state
+		   (required `((,var (pop ,args-tail))))
+		   (optional (cond ((not (consp var))
+				    `((,var (when ,args-tail (pop ,args-tail)))))
+				   ((null (cddr var))
+				    `((,(car var) (if ,args-tail
+						      (pop ,args-tail)
+						      ,(cadr var)))))
+				   (t
+				    `((,(caddr var) ,args-tail)
+				      (,(car var) (if ,args-tail
+						      (pop ,args-tail)
+						      ,(cadr var)))))))
+		   (rest `((,var ,args-tail)))
+		   (key (cond ((not (consp var))
+			       `((,var (get-key-arg ,(make-keyword var)
+					            ,args-tail))))
+			      ((null (cddr var))
+			       (multiple-value-bind (keyword variable)
+				   (if (consp (car var))
+				       (values (caar var) (cadar var))
+				       (values (make-keyword (car var)) (car var)))
+				 `((,key (get-key-arg1 ,keyword ,args-tail))
+				   (,variable (if (consp ,key)
+						  (car ,key)
+						  ,(cadr var))))))
+			      (t
+			       (multiple-value-bind (keyword variable)
+				   (if (consp (car var))
+				       (values (caar var) (cadar var))
+				       (values (make-keyword (car var)) (car var)))
+				 `((,key (get-key-arg1 ,keyword ,args-tail))
+				   (,(caddr var) ,key)
+				   (,variable (if (consp ,key)
+						  (car ,key)
+						  ,(cadr var))))))))
+		   (aux `(,var))))))
+      (let ((bindings (mapcan #'process-var lambda-list)))
+	`(let* ((,args-tail ,args)
+		,@bindings)
+	   ,@(unless bindings `((declare (ignore ,args-tail))))
+	   ,@body)))))
+
+(defun get-key-arg (keyword list)
+  (loop (when (atom list) (return nil))
+	(when (eq (car list) keyword) (return (cadr list)))
+	(setq list (cddr list))))
+
+(defun get-key-arg1 (keyword list)
+  (loop (when (atom list) (return nil))
+	(when (eq (car list) keyword) (return (cdr list)))
+	(setq list (cddr list))))
+
+(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+  (let ((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
+				   ;should be in the method definition
+    (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)
+		    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 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)))
+		      (ecase (car form)
+			(slot-value
+			 (optimize-slot-value     slots parameter form))
+			(set-slot-value
+			 (optimize-set-slot-value slots parameter form))
+			(slot-boundp
+			 (optimize-slot-boundp    slots parameter form)))))
+		   ((and (eq (car form) 'apply)
+			 (consp (cadr form))
+			 (eq (car (cadr form)) 'function)
+			 (generic-function-name-p (cadr (cadr form))))
+		    (optimize-generic-function-call 
+		     form required-parameters env slots calls))
+		   ((and (or (symbolp (car form))
+			     (and (consp (car form))
+				  (eq (caar form) 'setf)))
+			 (generic-function-name-p (car form)))
+		    (optimize-generic-function-call 
+		     form required-parameters env slots calls))
+		   (t form))))
+	  
+      (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
+	(values walked-lambda
+		call-next-method-p closurep next-method-p-p)))))
+
+(defun generic-function-name-p (name)
+  (and (gboundp name)
+       (if (eq *boot-state* 'complete)
+	   (standard-generic-function-p (gdefinition name))
+	   (funcallable-instance-p (gdefinition name)))))
 
 (defun make-parameter-references (specialized-lambda-list
-                                  required-parameters
-                                  declarations
-                                  generic-function-name
-                                  specializers)
+				  required-parameters
+				  declarations
+				  method-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, there is a~%~
                       redundant ignore declaration for the parameter ~S."
-                     generic-function-name
-                     specializers
-                     (car s)))
-              (t
-               (gather (car s) references)))))))
+		     method-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))
+(defvar *mf1* nil) (defvar *mf1p* nil) (defvar *mf1cp* nil)
+(defvar *mf2* nil) (defvar *mf2p* nil) (defvar *mf2cp* nil)
 
 (defun method-function-plist (method-function)
-  (gethash method-function *method-function-plist*))
+  (unless (eq method-function *mf1*)
+    (rotatef *mf1* *mf2*)
+    (rotatef *mf1p* *mf2p*)
+    (rotatef *mf1cp* *mf2cp*))
+  (unless (or (eq method-function *mf1*) (null *mf1cp*))
+    (setf (gethash *mf1* *method-function-plist*) *mf1p*))
+  (unless (eq method-function *mf1*)
+    (setf *mf1* method-function
+	  *mf1cp* nil
+	  *mf1p* (gethash method-function *method-function-plist*)))
+  *mf1p*)
 
 (defun #-setf SETF\ PCL\ METHOD-FUNCTION-PLIST #+setf (setf method-function-plist)
        (val method-function)
-  (setf (gethash method-function *method-function-plist*) val))
-
-(defun method-function-get (method-function key)
-  (getf (method-function-plist method-function) key))
+  (unless (eq method-function *mf1*)
+    (rotatef *mf1* *mf2*)
+    (rotatef *mf1cp* *mf2cp*)
+    (rotatef *mf1p* *mf2p*))
+  (unless (or (eq method-function *mf1*) (null *mf1cp*))
+    (setf (gethash *mf1* *method-function-plist*) *mf1p*))
+  (setf *mf1* method-function
+	*mf1cp* t
+	*mf1p* val))
+
+(defun method-function-get (method-function key &optional default)
+  (getf (method-function-plist method-function) key default))
 
 (defun #-setf SETF\ PCL\ METHOD-FUNCTION-GET #+setf (setf method-function-get)
        (val method-function key)
-  (setf (getf  (method-function-plist method-function) key) val))
+  (setf (getf (method-function-plist method-function) key) val))
 
-(defun method-function-method (method-function)
-  (method-function-get method-function 'method))
 
-(defun set-method-function-method (method-function new-value)
-  (setf (method-function-get method-function 'method) new-value))
+(defun method-function-pv-table (method-function)
+  (method-function-get method-function :pv-table))
+
+(defun method-function-method (method-function)
+  (method-function-get method-function :method))
 
-(defsetf method-function-method set-method-function-method)
+(defun method-function-needs-next-methods-p (method-function)
+  (method-function-get method-function :needs-next-methods-p t))
 
 
 
-(defun load-defmethod
-       (class name quals specls ll doc function optimized-function
-        closure-generator initargs)
+(defmacro method-function-closure-generator (method-function)
+  `(method-function-get ,method-function 'closure-generator))
+
+(defun load-defmethod (class name quals specls ll initargs &optional pv-table-symbol)
   (when (listp name) (do-standard-defsetf-1 (cadr name)))
-  (let ((method-spec (make-method-spec name quals specls)))
+  (setq initargs (copy-tree initargs))
+  (let ((method-spec (or (getf initargs ':method-spec)
+			 (make-method-spec name quals specls))))
+    (setf (getf initargs ':method-spec) method-spec)
     (record-definition 'method 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 function class
-      optimized-function closure-generator initargs)))
+    (load-defmethod-internal class name quals specls ll initargs pv-table-symbol)))
 
 (defun load-defmethod-internal
-       (gf-spec qualifiers specializers lambda-list doc fn method-class
-        optimized-function closure-generator initargs)
+    (method-class gf-spec qualifiers specializers lambda-list 
+		  initargs pv-table-symbol)
   (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
-
-  (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))))
+  (when pv-table-symbol
+    (setf (getf (getf initargs ':plist) :pv-table-symbol)
+	  pv-table-symbol))
+  (let ((method (apply #'add-named-method
+		       gf-spec qualifiers specializers lambda-list
+		       :definition-source `((defmethod ,gf-spec
+						,@qualifiers
+					      ,specializers)
+					    ,(load-truename))
+		       initargs)))
+    (unless (or (eq method-class 'standard-method)
+		(eq (find-class method-class nil) (class-of method)))
       (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))))
+               may mean that this method was compiled improperly.~%"
+	      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 initialize-method-function (initargs &optional return-function-p method)
+  (let* ((mf (getf initargs ':function))
+	 (method-spec (getf initargs ':method-spec))
+	 (plist (getf initargs ':plist))
+	 (pv-table-symbol (getf plist ':pv-table-symbol))
+	 (pv-table nil)
+	 (mff (getf initargs ':fast-function)))
+    (flet ((set-mf-property (p v)
+	     (when mf
+	       (setf (method-function-get mf p) v))
+	     (when mff
+	       (setf (method-function-get mff p) v))))
+      (when method-spec
+	(when mf
+	  (setq mf (set-function-name mf method-spec)))
+	(when mff
+	  (let ((name `(,(or (get (car method-spec) 'fast-sym)
+			     (setf (get (car method-spec) 'fast-sym)
+				   (intern (format nil "FAST-~A"
+						   (car method-spec))
+					   *the-pcl-package*)))
+			 ,@(cdr method-spec))))
+	    (set-function-name mff name)
+	    (unless mf
+	      (set-mf-property :name name)))))
+      (when plist
+	(let ((snl (getf plist :slot-name-lists))
+	      (cl (getf plist :call-list)))
+	  (when (or snl cl)
+	    (setq pv-table (intern-pv-table :slot-name-lists snl
+					    :call-list cl))
+	    (when pv-table (set pv-table-symbol pv-table))
+	    (set-mf-property :pv-table pv-table)))    
+	(loop (when (null plist) (return nil))
+	      (set-mf-property (pop plist) (pop plist)))      
+	(when method
+	  (set-mf-property :method method))    
+	(when return-function-p
+	  (or mf (method-function-from-fast-function mff)))))))
+
+
+
+(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)
+  #-cmu (declare (ignore lambda-list))
+  (when (consp spec)
+    (setq spec (get-setf-function-name (cadr spec))))
+  (let (#+cmu
+	(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)
@@ -1502,7 +1224,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)
@@ -1510,12 +1232,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) ()
@@ -1530,6 +1252,216 @@ work during bootstrapping.
   (make-specializable name)
   (funcall continuation :specialize-it))
 
+(defvar *sgf-wrapper* 
+  (make-wrapper (early-class-size 'standard-generic-function)))
+
+(defvar *sgf-slots-init*
+  (mapcar #'(lambda (canonical-slot)
+	      (if (memq (getf canonical-slot :name) '(arg-info source))
+		  *slot-unbound*
+		  (let ((initfunction (getf canonical-slot :initfunction)))
+		    (if initfunction
+			(funcall initfunction)
+			*slot-unbound*))))
+	  (early-collect-inheritance 'standard-generic-function)))
+
+(defvar *sgf-method-class-index* 
+  (bootstrap-slot-index 'standard-generic-function 'method-class))
+
+(defun early-gf-p (x)
+  (and (fsc-instance-p x)
+       (eq (instance-ref (get-slots x) *sgf-method-class-index*)
+	   *slot-unbound*)))
+
+(defvar *sgf-methods-index* 
+  (bootstrap-slot-index 'standard-generic-function 'methods))
+
+(defmacro early-gf-methods (gf)
+  `(instance-ref (get-slots ,gf) *sgf-methods-index*))
+
+(defvar *sgf-arg-info-index* 
+  (bootstrap-slot-index 'standard-generic-function 'arg-info))
+
+(defmacro early-gf-arg-info (gf)
+  `(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
+
+(defvar *sgf-dfun-state-index* 
+  (bootstrap-slot-index 'standard-generic-function 'dfun-state))
+
+(defstruct (arg-info
+	     (:conc-name nil)
+	     (:constructor make-arg-info ()))
+  (arg-info-lambda-list :no-lambda-list)
+  arg-info-precedence
+  arg-info-metatypes
+  arg-info-number-optional
+  arg-info-key/rest-p
+  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-info-static-c-a-m-emf
+  (gf-info-c-a-m-emf-std-p t)
+  gf-info-fast-mf-p)
+
+(defun arg-info-valid-p (arg-info)
+  (not (null (arg-info-number-optional arg-info))))
+
+(defun arg-info-applyp (arg-info)
+  (or (plusp (arg-info-number-optional arg-info))
+      (arg-info-key/rest-p arg-info)))
+
+(defun arg-info-number-required (arg-info)
+  (length (arg-info-metatypes arg-info)))
+
+(defun arg-info-nkeys (arg-info)
+  (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
+
+(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
+			argument-precedence-order)
+  (let* ((arg-info (if (eq *boot-state* 'complete)
+		       (gf-arg-info gf)
+		       (early-gf-arg-info gf)))
+	 (methods (if (eq *boot-state* 'complete)
+		      (generic-function-methods gf)
+		      (early-gf-methods gf)))
+	 (was-valid-p (integerp (arg-info-number-optional arg-info)))
+	 (first-p (and new-method (null (cdr methods)))))
+    (when (and (not lambda-list-p) methods)      
+      (setq lambda-list (gf-lambda-list gf)))
+    (when (or lambda-list-p
+	      (and first-p (eq (arg-info-lambda-list arg-info) ':no-lambda-list)))
+      (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+	  (analyze-lambda-list lambda-list)
+	(declare (ignore allow-other-keys-p))
+	(when (and methods (not first-p))
+	  (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)))
+	    (unless (and (= nreq gf-nreq)
+			 (= nopt gf-nopt)
+			 (eq (or keysp restp) gf-key/rest-p))
+	      (error "The lambda-list ~S is incompatible with ~
+                     existing methods of ~S."
+		     lambda-list gf))))
+	(when lambda-list-p
+	  (setf (arg-info-lambda-list arg-info) lambda-list))
+	(setf (arg-info-metatypes arg-info) (make-list nreq))
+	(setf (arg-info-precedence arg-info)
+	      (compute-precedence lambda-list nreq argument-precedence-order))
+	(setf (arg-info-number-optional arg-info) nopt)
+	(setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
+	(setf (arg-info-keywords arg-info) 
+	      (if lambda-list-p
+		  (if allow-other-keys-p t keywords)
+		  (arg-info-key/rest-p arg-info)))))
+    (when new-method
+      (check-method-arg-info gf arg-info new-method))
+    (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
+    arg-info))
+
+(defun check-method-arg-info (gf arg-info method)
+  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+      (analyze-lambda-list (if (consp method)
+			       (early-method-lambda-list method)
+			       (method-lambda-list method)))
+    (flet ((lose (string &rest args)
+	     (error "Attempt to add the method ~S to the generic function ~S.~%~
+                   But ~A" method gf (apply #'format nil string args)))
+	   (compare (x y)
+	     (if (> x y) "more" "fewer")))
+      (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)))
+	(unless (= nreq gf-nreq)
+	  (lose "the method has ~A required arguments than the generic function."
+		(compare nreq gf-nreq)))
+	(unless (= nopt gf-nopt)
+	  (lose "the method has ~S optional arguments than the generic function."
+		(compare nopt gf-nopt)))
+	(unless (eq (or keysp restp) gf-key/rest-p)
+	  (error "the method and generic function differ in whether they accept~%~
+                  rest or keyword arguments."))
+	(when (consp gf-keywords)
+	  (unless (or (and restp (not keysp))
+		      allow-other-keys-p
+		      (every #'(lambda (k) (memq k keywords)) gf-keywords))
+	    (lose "the method does not accept each of the keyword arguments~%~
+                 ~S." gf-keywords)))))))
+
+(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)  
+  (let* ((existing-p (and methods (cdr methods) new-method))
+	 (nreq (length (arg-info-metatypes arg-info)))
+	 (metatypes (if existing-p
+			(arg-info-metatypes arg-info)
+			(make-list nreq)))
+	 (type (if existing-p
+		   (gf-info-simple-accessor-type arg-info)
+		   nil)))
+    (when (arg-info-valid-p arg-info)
+      (dolist (method (if new-method (list new-method) methods))
+	(let* ((specializers (if (or (eq *boot-state* 'complete)
+				     (not (consp method)))
+				 (method-specializers method)
+				 (early-method-specializers method t)))
+	       (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+			  (class-of method)
+			  (early-method-class method)))
+	       (new-type (when (and class
+				    (or (not (eq *boot-state* 'complete))
+					(eq (generic-function-method-combination gf)
+					    *standard-method-combination*)))
+			   (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)))))
+	  (setq metatypes (mapcar #'raise-metatype metatypes specializers))
+	  (setq type (cond ((null type) new-type)
+			   ((eq type new-type) type)
+			   (t nil)))))
+      (setf (arg-info-metatypes arg-info) metatypes)
+      (setf (gf-info-simple-accessor-type arg-info) type)))
+  (when (or (not was-valid-p) first-p)
+    (multiple-value-bind (c-a-m-emf std-p)
+	(if (early-gf-p gf)
+	    (values t t)
+	    (compute-applicable-methods-emf 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)
+      (unless (gf-info-c-a-m-emf-std-p arg-info)
+	(setf (gf-info-simple-accessor-type arg-info) t))))
+  (unless was-valid-p
+    (let ((name (if (eq *boot-state* 'complete)
+		    (generic-function-name gf)
+		    (early-gf-name gf))))
+      (setf (gf-precompute-dfun-and-emf-p arg-info) 
+	    (let* ((sym (if (atom name) name (cadr name)))
+		   (pkg-list (cons *the-pcl-package* 
+				   (package-use-list *the-pcl-package*))))
+	      (and sym (symbolp sym)
+		   (not (null (memq (symbol-package sym) pkg-list)))
+		   (not (find #\space (symbol-name sym))))))))
+  (setf (gf-info-fast-mf-p arg-info)
+	(or (not (eq *boot-state* 'complete))
+	    (let* ((method-class (generic-function-method-class gf))
+		   (methods (compute-applicable-methods 
+			     #'make-method-lambda
+			     (list gf (class-prototype method-class)
+				   '(lambda) nil))))
+	      (and methods (null (cdr methods))
+		   (let ((specls (method-specializers (car methods))))
+		     (and (classp (car specls))
+			  (eq 'standard-generic-function (class-name (car specls)))
+			  (classp (cadr specls))
+			  (eq 'standard-method (class-name (cadr specls)))))))))
+  arg-info)
+
 ;;;
 ;;; This is the early definition of ensure-generic-function-using-class.
 ;;; 
@@ -1541,82 +1473,129 @@ 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))))
-
-(defun early-gf-p (x)
-  (and (fsc-instance-p x)
-       (listp (fsc-instance-slots x))))
-
-(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)))
-
+  (cond ((and existing (early-gf-p existing))
+	 existing)
+	((assoc spec *generic-function-fixups* :test #'equal)
+	 (if existing
+	     (make-early-gf spec lambda-list lambda-list-p existing)	       
+	     (error "The function ~S is not already defined" spec)))
+	(existing
+	 (error "~S should be on the list ~S" spec '*generic-function-fixups*))
+	(t
+	 (pushnew spec *early-generic-functions* :test #'equal)
+	 (make-early-gf spec lambda-list lambda-list-p))))
+
+(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
+  (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
+    (set-funcallable-instance-function 
+     fin 
+     (or function
+	 (if (eq spec 'print-object)
+	     #'(lambda (instance stream)
+		 (printing-random-thing (instance stream)
+		   (format stream "std-instance")))
+	     #'(lambda (&rest args)
+		 (declare (ignore args))
+		 (error "The function of the funcallable-instance ~S~
+                         has not been set" fin)))))
+    (setf (gdefinition spec) fin)
+    (bootstrap-set-slot 'standard-generic-function fin 'name spec)
+    (bootstrap-set-slot 'standard-generic-function fin 'source (load-truename))
+    (set-function-name fin spec)
+    (let ((arg-info (make-arg-info)))
+      (setf (early-gf-arg-info fin) arg-info)
+      (when lambda-list-p
+	(proclaim-defgeneric spec lambda-list)
+	(set-arg-info fin :lambda-list lambda-list)))
+    fin))
+
+(defun set-dfun (gf &optional dfun cache info)
+  (when cache
+    (setf (cache-owner cache) gf))
+  (let ((new-state (if (and dfun (or cache info))
+		       (list* dfun cache info)
+		       dfun)))
+    (if (eq *boot-state* 'complete)
+	(setf (gf-dfun-state gf) new-state)
+	(setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state)))
+  dfun)
+
+(defun gf-dfun-cache (gf)
+  (let ((state (if (eq *boot-state* 'complete)
+		   (gf-dfun-state gf)
+		   (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
+    (typecase state
+      (function nil)
+      (cons (cadr state)))))
+
+(defun gf-dfun-info (gf)
+  (let ((state (if (eq *boot-state* 'complete)
+		   (gf-dfun-state gf)
+		   (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
+    (typecase state
+      (function nil)
+      (cons (cddr state)))))
+
+(defvar *sgf-name-index* 
+  (bootstrap-slot-index 'standard-generic-function 'name))
+
+(defun early-gf-name (gf)
+  (instance-ref (get-slots gf) *sgf-name-index*))
+
+(defun gf-lambda-list (gf)
+  (let ((arg-info (if (eq *boot-state* 'complete)
+		      (gf-arg-info gf)
+		      (early-gf-arg-info gf))))
+    (if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
+	(let ((methods (if (eq *boot-state* 'complete)
+			   (generic-function-methods gf)
+			   (early-gf-methods gf))))
+	  (if (null methods)
+	      (progn
+		(warn "No way to determine the lambda list for ~S." gf)
+		nil)
+	      (let* ((method (car (last methods)))
+		     (ll (if (consp method)
+			     (early-method-lambda-list method)
+			     (method-lambda-list method)))
+		     (k (member '&key ll)))
+		(if k 
+		    (append (ldiff ll (cdr k)) '(&allow-other-keys))
+		    ll))))
+	(arg-info-lambda-list arg-info))))
 
 (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)
+	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)
@@ -1625,28 +1604,41 @@ 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 optimized-function
-    closure-generator doc &optional slot-name other-initargs)
+(defun get-generic-function-info (gf)
+  ;; values   nreq applyp metatypes nkeys arg-info
+  (multiple-value-bind (applyp metatypes arg-info)
+      (let* ((arg-info (if (early-gf-p gf)
+			   (early-gf-arg-info gf)
+			   (gf-arg-info gf)))
+	     (metatypes (arg-info-metatypes arg-info)))
+	(values (arg-info-applyp arg-info)
+		metatypes
+		arg-info))
+    (values (length metatypes) applyp metatypes
+	    (count-if #'(lambda (x) (neq x 't)) metatypes)
+	    arg-info)))
+
+(defun early-make-a-method (class qualifiers arglist specializers initargs doc
+			    &optional slot-name)
+  (initialize-method-function 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
@@ -1655,67 +1647,61 @@ 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!
-          
-          (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)
-          )))
+	(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!
+	  
+	  (getf initargs ':function)
+	  (getf initargs ':fast-function)
+	  
+	  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
+		initargs
+		doc
+		slot-name)
+	  )))
 
 (defun real-make-a-method
-  (class qualifiers lambda-list specializers function optimized-function
-   closure-generator doc &optional slot-name other-initargs)
+       (class qualifiers lambda-list specializers initargs doc
+	&optional slot-name)
   (setq specializers (parse-specializers specializers))
-  (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))
+  (apply #'make-instance class 
+	 :qualifiers qualifiers
+	 :lambda-list lambda-list
+	 :specializers specializers
+	 :documentation doc
+	 :slot-name slot-name
+	 :allow-other-keys t
+	 initargs))
 
 (defun early-method-function (early-method)
-  (cadr early-method))
+  (values (cadr early-method) (caddr early-method)))
+
+(defun early-method-class (early-method)
+  (find-class (car (fifth early-method))))
 
 (defun early-method-standard-accessor-p (early-method)
-  (let ((class (car (cadddr early-method))))
+  (let ((class (first (fifth early-method))))
     (or (eq class 'standard-reader-method)
         (eq class 'standard-writer-method)
         (eq class 'standard-boundp-method))))
 
+(defun early-method-standard-accessor-slot-name (early-method)
+  (seventh (fifth early-method)))
+
 ;;;
 ;;; Fetch the specializers of an early method.  This is basically just a
 ;;; simple accessor except that when the second argument is t, this converts
@@ -1732,43 +1718,38 @@ 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 (fourth early-method)
+		 (setf (fourth early-method)
+		       (mapcar #'find-class (cadddr (fifth early-method))))))
+	    (t
+	     (cadddr (fifth early-method))))
       (error "~S is not an early-method." early-method)))
 
 (defun early-method-qualifiers (early-method)
-  (cadr (cadddr early-method)))
+  (cadr (fifth early-method)))
+
+(defun early-method-lambda-list (early-method)
+  (caddr (fifth early-method)))
 
 (defun early-add-named-method (generic-function-name
-                               method-class
-                               qualifiers
-                               specializers
-                               arglist
-                               function
-                               optimized-function
-                               closure-generator
-                               &rest other-initargs)
+			       qualifiers
+			       specializers
+			       arglist
+			       &rest 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 method-class
-                             qualifiers
-                             arglist
-                             specializers
-                             function
-                             optimized-function
-                             closure-generator
-                             ()
-                             ()
-                             other-initargs)))
+	 (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
+			     initargs
+			     ())))
     (when existing (remove-method gf existing))
     (add-method gf new)))
 
@@ -1783,7 +1764,10 @@ work during bootstrapping.
   (when (not (and (listp method) (eq (car method) :early-method)))
     (error "Early add-method didn't get an early method."))
   (push method (early-gf-methods generic-function))
-  (early-update-discriminator-code generic-function))
+  (set-arg-info generic-function :new-method method)
+  (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+		 :test #'equal)
+    (update-dfun generic-function)))
 
 ;;;
 ;;; This is the early version of remove method.
@@ -1794,237 +1778,104 @@ 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)))
-  (early-update-discriminator-code generic-function))
+	(remove method (early-gf-methods generic-function)))
+  (set-arg-info generic-function)
+  (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+		 :test #'equal)
+    (update-dfun 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 ~
-                              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))))))
-    (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))
-
-(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)))))
-
-(defun early-dfun (methods args)
-  (let ((primary ())
-        (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 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))
-    (flet ((do-main-combined-method (&rest arguments)
-             (dolist (m before) (apply (cadr m) arguments))
-             (multiple-value-prog1
-               (let ((*next-methods* (mapcar #'car (cdr primary))))
-                 (apply (cadar primary) arguments))
-               (dolist (m after) (apply (cadr m) arguments)))))
-      (if (null around)
-          (apply #'do-main-combined-method args)
-          (let ((*next-methods*
-                  (append (mapcar #'cadr (cdr around))
-                          (list #'do-main-combined-method))))
-            (apply (cadar around) args))))))
-
 (defvar *fegf-debug-p* nil)
 
 (defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
-  (allocate-instance (find-class 'standard-generic-function)) ;Be sure this
-                                                              ;class has an
-                                                              ;instance.
-  (let* ((class (find-class 'standard-generic-function))
-         (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 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
-                             '(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
-                              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))))))))
-          
+  (setq *fegf-started-p* t)
+  (let ((accessors nil))
+    ;; Rearrange *early-generic-functions* to speed up fix-early-generic-functions.
+    (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
+			   structure-class-p
+			   standard-class-p
+			   funcallable-standard-class-p
+			   specializerp)))
+      (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* ((gf (gdefinition early-gf-spec))
+	     (methods (mapcar #'(lambda (early-method)
+				  (let ((args (copy-list (fifth early-method))))
+				    (setf (fourth args)
+					  (early-method-specializers early-method t))
+				    (apply #'real-make-a-method args)))
+			      (early-gf-methods gf))))
+	(setf (generic-function-method-class gf) *the-class-standard-method*)
+	(setf (generic-function-method-combination gf) *standard-method-combination*)
+	(set-methods gf methods)))
+	  
     (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*
-                ((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)))))
+      (let* ((fspec (car fixup))
+	     (gf (gdefinition fspec))
+	     (methods (mapcar #'(lambda (method)
+				  (let* ((lambda-list (first method))
+					 (specializers (second method))
+					 (method-fn-name (third method))
+					 (fn-name (or method-fn-name fspec))
+					 (fn (symbol-function fn-name))
+					 (initargs 
+					  (list :function
+						(set-function-name
+						 #'(lambda (args next-methods)
+						     (declare (ignore next-methods))
+						     (apply fn args))
+						 `(call ,fn-name)))))
+				    (make-a-method 'standard-method
+						   ()
+						   lambda-list
+						   specializers
+						   initargs
+						   nil)))
+			      (cdr fixup))))
+	(setf (generic-function-method-class gf) *the-class-standard-method*)
+	(setf (generic-function-method-combination gf) *standard-method-combination*)
+	(set-methods gf methods)))))
 
 
 ;;;
@@ -2033,32 +1884,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))
@@ -2068,10 +1919,41 @@ 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)
@@ -2099,145 +1981,150 @@ 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 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))
+	  ((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)
-             (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)))))))
+		   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)))))))
 
 
 (eval-when (load eval)
   (setq *boot-state* 'early))
 
 
-#-cmu
+#-cmu ;; CMUCL Has a real symbol-macrolet
+(progn
 (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 (ext::ignorable ,in))
-       ,@(let ((instance (un-the instance)))
-           (and (symbolp instance)
+       #+cmu (declare (ignorable ,in))
+       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
+                             (third instance)
+                             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 (ext::ignorable ,in))
-       ,@(let ((instance (un-the instance)))
-           (and (symbolp instance)
+       #+cmu (declare (ignorable ,in))
+       ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
+                             (third instance)
+                             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 5fcc5d00a..f6d2ce9be 100644
--- a/pcl/braid.lisp
+++ b/pcl/braid.lisp
@@ -36,132 +36,115 @@
 
 (in-package 'pcl)
 
-(defun early-class-definition (class-name)
-  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
-      (error "~S is not a class in *early-class-definitions*." class-name)))
-
-(defun canonical-slot-name (canonical-slot)
-  (getf canonical-slot :name))
-
-(defun early-collect-inheritance (class-name)
-  (declare (values slots cpl default-initargs direct-subclasses))
-  (let ((cpl (early-collect-cpl class-name)))
-    (values (early-collect-slots cpl)
-	    cpl
-	    (early-collect-default-initargs cpl)
-	    (gathering1 (collecting)
-	      (dolist (definition *early-class-definitions*)
-		(when (memq class-name (ecd-superclass-names definition))
-		  (gather1 (ecd-class-name definition))))))))
-
-(defun early-collect-cpl (class-name)
-  (labels ((walk (c)
-	     (let* ((definition (early-class-definition c))
-		    (supers (ecd-superclass-names definition)))
-	       (cons c
-		     (apply #'append (mapcar #'early-collect-cpl supers))))))
-    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
-
-(defun early-collect-slots (cpl)
-  (let* ((definitions (mapcar #'early-class-definition cpl))
-	 (super-slots (mapcar #'ecd-canonical-slots definitions))
-	 (slots (apply #'append (reverse super-slots))))
-    (dolist (s1 slots)
-      (let ((name1 (canonical-slot-name s1)))
-	(dolist (s2 (cdr (memq s1 slots)))
-	  (when (eq name1 (canonical-slot-name s2))
-	    (error "More than one early class defines a slot with the~%~
-                    name ~S.  This can't work because the bootstrap~%~
-                    object system doesn't know how to compute effective~%~
-                    slots."
-		   name1)))))
-    slots))
-
-(defun early-collect-default-initargs (cpl)
-  (let ((default-initargs ()))
-    (dolist (class-name cpl)
-      (let ((definition (early-class-definition class-name)))
-	(dolist (option (ecd-other-initargs definition))
-	  (unless (eq (car option) :default-initargs)
-	    (error "The defclass option ~S is not supported by the bootstrap~%~
-                    object system."
-		   (car option)))
-	  (setq default-initargs
-		(nconc default-initargs (reverse (cdr option)))))))
-    (reverse default-initargs)))
-
-
-;;;
-;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
-;;; the values of slots during bootstrapping.  During bootstrapping, there
-;;; are only two kinds of objects whose slots we need to access, CLASSes
-;;; and SLOT-DEFINITIONs.  The first argument to these functions tells whether the
-;;; object is a CLASS or a SLOT-DEFINITION.
-;;;
-;;; Note that the way this works it stores the slot in the same place in
-;;; memory that the full object system will expect to find it later.  This
-;;; is critical to the bootstrapping process, the whole changeover to the
-;;; full object system is predicated on this.
-;;;
-;;; One important point is that the layout of standard classes and standard
-;;; slots must be computed the same way in this file as it is by the full
-;;; object system later.
-;;; 
-(defun bootstrap-get-slot (type object slot-name)
-  (let ((index (bootstrap-slot-index type slot-name)))
-    (svref (std-instance-slots object) index)))
-
-(defun bootstrap-set-slot (type object slot-name new-value)
-  (let ((index (bootstrap-slot-index type slot-name)))
-    (setf (svref (std-instance-slots object) index) new-value)))
-
-(defvar *early-class-slots* nil)
-
-(defun early-class-slots (class-name)
-  (cdr (or (assoc class-name *early-class-slots*)
-	   (let ((a (cons class-name
-			  (mapcar #'canonical-slot-name
-				  (early-collect-inheritance class-name)))))
-	     (push a *early-class-slots*)
-	     a))))
-
-(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 (posq slot-name (the list (early-class-slots class-name)))
-      (error "~S not found" slot-name)))
-
+(defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p))
+  #-new-kcl-wrapper (declare (special *slot-unbound*))
+  #-new-kcl-wrapper
+  (let ((instance (%%allocate-instance--class))
+	(no-of-slots (wrapper-no-of-instance-slots wrapper)))
+    (setf (%std-instance-wrapper instance) wrapper)
+    (setf (%std-instance-slots instance) 
+	  (if slots-init-p
+	      (make-array no-of-slots :initial-contents slots-init)
+	      (make-array no-of-slots :initial-element *slot-unbound*)))
+    instance)
+  #+new-kcl-wrapper
+  (apply #'si:make-structure wrapper
+	 (if slots-init-p
+	     slots-init
+	     (let ((no-of-slots (si::s-data-length wrapper)))
+	       (if (< no-of-slots (fill-pointer *init-vector*))
+		   (aref *init-vector* no-of-slots)
+		   (get-init-list no-of-slots))))))
+
+(defmacro allocate-funcallable-instance-slots (wrapper &optional 
+						       slots-init-p slots-init)
+  #-new-kcl-wrapper
+  `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
+     ,(if slots-init-p
+	  `(if ,slots-init-p
+	       (make-array no-of-slots :initial-contents ,slots-init)
+	       (make-array no-of-slots :initial-element *slot-unbound*))
+	  `(make-array no-of-slots :initial-element *slot-unbound*)))
+  #+new-kcl-wrapper
+  (if slots-init-p
+      `(if ,slots-init-p
+	   (allocate-standard-instance ,wrapper ,slots-init)
+	   (allocate-standard-instance ,wrapper))
+      `(allocate-standard-instance ,wrapper)))
+
+(defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p))
+  (let ((fin (allocate-funcallable-instance-1)))
+    (set-funcallable-instance-function
+     fin #'(lambda (&rest args)
+	     (declare (ignore args))
+	     (error "The function of the funcallable-instance ~S has not been set"
+		    fin)))
+    (setf (fsc-instance-wrapper fin) wrapper
+	  (fsc-instance-slots fin) (allocate-funcallable-instance-slots
+				    wrapper slots-init-p slots-init))
+    fin))
+
+(defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p))
+  #-new-kcl-wrapper
+  (let* ((class (wrapper-class wrapper))
+	 (constructor (class-defstruct-constructor class)))
+    (if constructor
+	(let ((instance (funcall constructor))
+	      (slots (class-slots class)))
+	  (when slots-init-p
+	    (dolist (slot slots)
+	      (setf (slot-value-using-class class instance slot) (pop slots-init))))
+	  instance)
+	(error "Can't allocate an instance of class ~S" (class-name class))))
+  #+new-kcl-wrapper
+  (if slots-init-p
+      (allocate-standard-instance wrapper slots-init)
+      (allocate-standard-instance wrapper)))
 
 ;;;
 ;;; bootstrap-meta-braid
 ;;;
 ;;; This function builds the base metabraid from the early class definitions.
 ;;;   
+(defmacro initial-classes-and-wrappers (&rest classes)
+  `(progn
+     ,@(mapcar #'(lambda (class)
+		   (let ((wr (intern (format nil "~A-WRAPPER" class) 
+				     *the-pcl-package*)))
+		     `(setf ,wr ,(if (eq class 'standard-generic-function)
+				     '*sgf-wrapper*
+				     `(make-wrapper (early-class-size ',class)))
+		            ,class (allocate-standard-instance
+				    ,(if (eq class 'standard-generic-function)
+					 'funcallable-standard-class-wrapper
+					 'standard-class-wrapper))
+		            (wrapper-class ,wr) ,class
+		            #+new-kcl-wrapper (si::s-data-name ,wr)
+		                   #+new-kcl-wrapper ',class
+		            (find-class ',class) ,class)))
+	      classes)))		        
+
 (defun bootstrap-meta-braid ()
-  (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))
-	 (structure-class-wrapper (make-wrapper structure-class))
-	 (direct-slotd-wrapper    (make-wrapper direct-slotd))
-	 (effective-slotd-wrapper (make-wrapper effective-slotd))
-	 (class-eq-wrapper        (make-wrapper class-eq)))
+  (let* ((name 'class)
+	 (predicate-name (make-type-predicate-name name)))
+    (setf (symbol-function predicate-name)
+	  #'(lambda (x) (declare (ignore x)) t))
+    (do-satisfies-deftype name predicate-name))  
+  (let* ((*create-classes-from-internal-structure-definitions-p* nil)
+	 standard-class-wrapper standard-class
+	 funcallable-standard-class-wrapper funcallable-standard-class
+	 slot-class-wrapper slot-class
+	 built-in-class-wrapper built-in-class
+	 structure-class-wrapper structure-class
+	 standard-direct-slot-definition-wrapper standard-direct-slot-definition
+	 standard-effective-slot-definition-wrapper standard-effective-slot-definition
+	 class-eq-specializer-wrapper class-eq-specializer
+	 standard-generic-function-wrapper standard-generic-function)
+    (initial-classes-and-wrappers 
+     standard-class funcallable-standard-class
+     slot-class built-in-class structure-class
+     standard-direct-slot-definition standard-effective-slot-definition 
+     class-eq-specializer standard-generic-function)
     ;;
     ;; First, make a class metaobject for each of the early classes.  For
     ;; each metaobject we also set its wrapper.  Except for the class T,
@@ -170,29 +153,16 @@
     (dolist (definition *early-class-definitions*)
       (let* ((name (ecd-class-name definition))
 	     (meta (ecd-metaclass definition))
-	     (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)
-                      (standard-direct-slot-definition    direct-slotd)
-		      (standard-effective-slot-definition effective-slotd)
-		      (built-in-class                     built-in-class)
-		      (structure-class                    structure-class)
-		      (class-eq-specializer               class-eq)
-                      (otherwise (%allocate-instance--class original-slot-copy)))))
-	(when (eq meta 'standard-class)
-	  (inform-type-system-about-class class name))
-	(setf (std-instance-wrapper class)
-	      (ecase meta
-		(slot-class slot-class-wrapper)
-		(standard-class standard-class-wrapper)
-		(built-in-class built-in-class-wrapper)
-		(structure-class structure-class-wrapper)))
+	     (wrapper (ecase meta
+			(slot-class slot-class-wrapper)
+			(standard-class standard-class-wrapper)
+			(funcallable-standard-class funcallable-standard-class-wrapper)
+			(built-in-class built-in-class-wrapper)
+			(structure-class structure-class-wrapper)))
+             (class (or (find-class name nil)
+			(allocate-standard-instance wrapper))))
+	(when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class))
+	  (inform-type-system-about-std-class name))
         (setf (find-class name) class)))
     ;;
     ;;
@@ -205,397 +175,259 @@
 	    (direct-slots  (ecd-canonical-slots definition))
 	    (other-initargs (ecd-other-initargs definition)))
 	(let ((direct-default-initargs
-		(getf other-initargs :default-initargs)))
+	       (getf other-initargs :direct-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
-		       ((eq class slot-class)      slot-class-wrapper)
-		       ((eq class standard-class)  standard-class-wrapper)
-		       ((eq class direct-slotd)    direct-slotd-wrapper)
-		       ((eq class effective-slotd) effective-slotd-wrapper)
-		       ((eq class built-in-class)  built-in-class-wrapper)
-		       ((eq class structure-class) structure-class-wrapper)
-		       ((eq class class-eq)        class-eq-wrapper)
-		       (t (make-wrapper class))))
-		   (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))
-		    ((memq name '(slot-object
-				  standard-object
-				  structure-object
-				  built-in-class
-				  slot-class
-				  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*)
-			  class)))
+		   (wrapper (cond ((eq class slot-class)
+				   slot-class-wrapper)
+				  ((eq class standard-class) 
+				   standard-class-wrapper)
+				  ((eq class funcallable-standard-class) 
+				   funcallable-standard-class-wrapper)
+				  ((eq class standard-direct-slot-definition) 
+				   standard-direct-slot-definition-wrapper)
+				  ((eq class standard-effective-slot-definition) 
+				   standard-effective-slot-definition-wrapper)
+				  ((eq class built-in-class)  
+				   built-in-class-wrapper)
+				  ((eq class structure-class)
+				   structure-class-wrapper)
+				  ((eq class class-eq-specializer)
+				   class-eq-specializer-wrapper)
+				  ((eq class standard-generic-function)
+				   standard-generic-function-wrapper)
+				  (t (make-wrapper (length slots) class))))
+		   (proto nil))
+	      (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
+	      (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
+			   *the-pcl-package*)
+		   class)
 	      (dolist (slot slots)
 		(unless (eq (getf slot :allocation :instance) :instance)
 		  (error "Slot allocation ~S not supported in bootstrap.")))
 	      
-	      (setf (wrapper-instance-slots-layout wrapper) slot-names)
-	      (setf (wrapper-allocate-static-slot-storage-copy wrapper)
-                    static-slot-copy)
+	      (setf (wrapper-instance-slots-layout wrapper)
+		    (mapcar #'canonical-slot-name slots))
 	      (setf (wrapper-class-slots wrapper)
 		    ())
 	      
-	      (setq proto (%allocate-instance--class static-slot-copy))
-	      (setf (std-instance-wrapper proto) wrapper)
+	      (setq proto (if (eq meta 'funcallable-standard-class)
+			      (allocate-funcallable-instance wrapper)
+			      (allocate-standard-instance wrapper)))
 	    
 	      (setq direct-slots
 		    (bootstrap-make-slot-definitions 
-		      name class direct-slots direct-slotd-wrapper nil))
+		     name class direct-slots
+		     standard-direct-slot-definition-wrapper nil))
 	      (setq slots
 		    (bootstrap-make-slot-definitions 
-		      name class slots effective-slotd-wrapper t))
+		     name class slots
+		     standard-effective-slot-definition-wrapper t))
 	      
 	      (case meta
-		(standard-class
-		 (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))
-		(built-in-class ; *the-class-t*
-		 (bootstrap-initialize-built-in-class
-		  class name class-eq-wrapper source
-		  direct-supers direct-subclasses cpl wrapper
-		  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 nil)
-		 (bootstrap-set-slot 'slot-class class 'direct-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
-		  direct-supers direct-subclasses cpl wrapper)))
-	      
-	      (let ((class-name 'standard-direct-slot-definition))
-		(dolist (slotd direct-slots)
-		  (bootstrap-accessor-definitions
-		    name
-		    (bootstrap-get-slot class-name slotd 'name)
-		    (bootstrap-get-slot class-name slotd 'readers)
-		    (bootstrap-get-slot class-name slotd 'writers)))))))))))
-
-(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
-  (flet ((do-reader-definition (reader)
-           (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))))
-
+		((standard-class funcallable-standard-class)
+		 (bootstrap-initialize-class 
+		  meta
+		  class name class-eq-specializer-wrapper source
+		  direct-supers direct-subclasses cpl wrapper proto
+		  direct-slots slots direct-default-initargs default-initargs))
+		(built-in-class		; *the-class-t*
+		 (bootstrap-initialize-class 
+		  meta
+		  class name class-eq-specializer-wrapper source
+		  direct-supers direct-subclasses cpl wrapper proto))
+		(slot-class		; *the-class-slot-object*
+		 (bootstrap-initialize-class 
+		  meta
+		  class name class-eq-specializer-wrapper source
+		  direct-supers direct-subclasses cpl wrapper proto))
+		(structure-class	; *the-class-structure-object*
+		 (bootstrap-initialize-class 
+		  meta
+		  class name class-eq-specializer-wrapper source
+		  direct-supers direct-subclasses cpl wrapper))))))))
+
+    (let* ((smc-class (find-class 'standard-method-combination))
+	   (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper))
+	   (smc (allocate-standard-instance smc-wrapper)))
+      (flet ((set-slot (name value)
+	       (bootstrap-set-slot 'standard-method-combination smc name value)))
+	(set-slot 'source (load-truename))
+	(set-slot 'type 'standard)
+	(set-slot 'documentation "The standard method combination.")
+	(set-slot 'options ()))
+      (setq *standard-method-combination* smc))))
 
 ;;;
-;;; Initialize a standard class metaobject.
+;;; Initialize a class metaobject.
 ;;;
-(defun bootstrap-initialize-standard-class
-       (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))
+(defun bootstrap-initialize-class
+       (metaclass-name class name
+        class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
+	&optional proto direct-slots slots direct-default-initargs default-initargs)
   (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 '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 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))
+	   (bootstrap-set-slot metaclass-name class slot-name value)))
     (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 (%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))
+	      (let ((spec (allocate-standard-instance 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 'internal-slotds 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)
+    #+new-kcl-wrapper
+    (setf (si::s-data-name wrapper) name)
     (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
-				  predicate-name
 				  (make-class-predicate-name name)))
-    (set-slot 'plist nil)
-    (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)
-  (unless (eq name 'structure-object) (error "You forgot to do something"))
-  (flet ((classes (names) (mapcar #'find-class names))
-	 (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 (%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 'can-precede-list (classes (cdr cpl)))
-      (set-slot 'incompatible-superclass-list nil)
-      (set-slot 'wrapper wrapper)
-      (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
-				    (make-class-predicate-name name)))
-      (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 'documentation NIL))))
+    (set-slot 'plist
+	      `(,@(and direct-default-initargs
+		       `(direct-default-initargs ,direct-default-initargs))
+		,@(and default-initargs
+		       `(default-initargs ,default-initargs))))
+    (when (memq metaclass-name '(standard-class funcallable-standard-class
+				 structure-class slot-class))
+      (set-slot 'direct-slots direct-slots)
+      (set-slot 'slots slots)
+      (set-slot 'initialize-info nil))
+    (if (eq metaclass-name 'structure-class)
+	(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
+	  (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
+					(make-class-predicate-name name)))
+	  (set-slot 'defstruct-form 
+		    `(defstruct (structure-object (:constructor ,constructor-sym))))
+	  (set-slot 'defstruct-constructor constructor-sym)
+	  (set-slot 'from-defclass-p t)    
+	  (set-slot 'plist nil)
+	  (set-slot 'prototype (funcall constructor-sym)))
+	(set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
+    class))
 
 (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
 		  name class slot wrapper effective-p index))
 	    slots)))
 
-(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-original-static-slot-storage-copy slotd-class-name)))
+	 (slotd (allocate-standard-instance wrapper))
 	 (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)))
-      (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*))))
+      (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)
+	(let ((table (or (gethash slot-name *name->class->slotd-table*)
+			 (setf (gethash slot-name *name->class->slotd-table*)
+			       (make-hash-table :test 'eq :size 5)))))
+	  (setf (gethash class table) slotd)))
+      (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))
       slotd)))
 
-(defun early-initialize-slot-gfs ()
-  (maphash #'(lambda (name class+slotd-list)
-	       (let ((table (or (gethash name *name->class->slotd-table*)
-				(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)))
-                 (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*))
-
-(defun early-initialize-class-predicates ()
-  (dolist (definition *early-class-definitions*)
-    (let* ((name (ecd-class-name definition))
-	   (class (find-class name)))
-      (setf (find-class-predicate name)
-	    (make-class-predicate class))))
-  (dolist (e *built-in-classes*)
-    (let* ((name (car e))
-	   (class (find-class name))
-	   (predicate-name (class-predicate-name class)))
-      (setf (find-class-predicate name)
-	    (if (fboundp predicate-name)
-		(symbol-function predicate-name)
-		(make-class-predicate class))))))
+(defun bootstrap-accessor-definitions (early-p)
+  (let ((*early-p* early-p))
+    (dolist (definition *early-class-definitions*)
+      (let ((name (ecd-class-name definition))
+	    (meta (ecd-metaclass definition)))
+	(unless (eq meta 'built-in-class)
+	  (let ((direct-slots  (ecd-canonical-slots definition)))
+	    (dolist (slotd direct-slots)
+	      (let ((slot-name (getf slotd :name))
+		    (readers (getf slotd :readers))
+		    (writers (getf slotd :writers)))
+		(bootstrap-accessor-definitions1 name slot-name readers writers nil)
+		(bootstrap-accessor-definitions1 
+		 'slot-object
+		 slot-name
+		 (list (slot-reader-symbol slot-name))
+		 (list (slot-writer-symbol slot-name))
+		 (list (slot-boundp-symbol slot-name)))))))))))
+
+(defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
+  (multiple-value-bind (accessor-class make-method-function arglist specls doc)
+      (ecase type
+	(reader (values 'standard-reader-method #'make-std-reader-method-function
+			(list class-name) (list class-name)
+			"automatically generated reader method"))
+	(writer (values 'standard-writer-method #'make-std-writer-method-function
+			(list 'new-value class-name) (list 't class-name)
+			"automatically generated writer method"))
+	(boundp (values 'standard-boundp-method #'make-std-boundp-method-function
+			(list class-name) (list class-name)
+			"automatically generated boundp method")))
+    (let ((gf (ensure-generic-function accessor-name)))
+      (if (find specls (early-gf-methods gf) 
+		:key #'early-method-specializers
+		:test #'equal)
+	  (unless (assoc accessor-name *generic-function-fixups*
+			 :test #'equal)
+	    (update-dfun gf))
+	  (add-method gf
+		      (make-a-method accessor-class
+				     ()
+				     arglist specls
+				     (funcall make-method-function
+					      class-name slot-name)
+				     doc
+				     slot-name))))))
+
+(defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps)
+  (flet ((do-reader-definition (reader)
+	   (bootstrap-accessor-definition class-name reader slot-name 'reader))
+	 (do-writer-definition (writer)
+	   (bootstrap-accessor-definition class-name writer slot-name 'writer))
+	 (do-boundp-definition (boundp)
+	   (bootstrap-accessor-definition class-name boundp slot-name 'boundp)))
+    (dolist (reader readers) (do-reader-definition reader))
+    (dolist (writer writers) (do-writer-definition writer))
+    (dolist (boundp boundps) (do-boundp-definition boundp))))
+
+(defun bootstrap-class-predicates (early-p)
+  (let ((*early-p* early-p))
+    (dolist (definition *early-class-definitions*)
+      (let* ((name (ecd-class-name definition))
+	     (class (find-class name)))
+	(setf (find-class-predicate name)
+	      (make-class-predicate class (class-predicate-name class)))))))
 
 (defun bootstrap-built-in-classes ()
   ;;
@@ -616,12 +448,9 @@
   ;; class name.
   ;;
   (let* ((built-in-class (find-class 'built-in-class))
-	 (built-in-class-wrapper (class-wrapper built-in-class))
-	 (built-in-class-original-slot-copy
-           (early-class-original-static-slot-storage-copy 'built-in-class)))
+	 (built-in-class-wrapper (class-wrapper built-in-class)))
     (dolist (e *built-in-classes*)
-      (let ((class (%allocate-instance--class built-in-class-original-slot-copy)))
-	(setf (std-instance-wrapper class) built-in-class-wrapper)
+      (let ((class (allocate-standard-instance built-in-class-wrapper)))
 	(setf (find-class (car e)) class))))
 
   ;;
@@ -629,98 +458,136 @@
   ;;
   (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
     (dolist (e *built-in-classes*)
-      (destructuring-bind (name supers subs cpl prototype predicate-name) e
+      (destructuring-bind (name supers subs cpl prototype) e
 	(let* ((class (find-class name))
-	       (wrapper (make-wrapper class)))
+	       (wrapper (make-wrapper 0 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-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 predicate-name))))))
+		(wrapper-class-slots wrapper) ())
+
+	  (bootstrap-initialize-class 'built-in-class class
+				      name class-eq-wrapper nil
+				      supers subs
+				      (cons name cpl)
+				      wrapper prototype)))))
+  
+  (dolist (e *built-in-classes*)
+    (let* ((name (car e))
+	   (class (find-class name)))
+      (setf (find-class-predicate name)
+	    (make-class-predicate class (class-predicate-name class))))))
 
 
 ;;;
 ;;;
 ;;;
+#-new-kcl-wrapper
+(progn
+(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)))
+)
 
-(defun wrapper-of (x) 
-  (fast-wrapper-of x))
-
-(defun class-of (x) (wrapper-class (fast-wrapper-of x)))
+#|| ; 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)))))
+||#
+
+(defmacro wrapper-of-macro (x)
+  `(cond ((std-instance-p ,x)
+	  (std-instance-wrapper ,x))
+         ((fsc-instance-p ,x)
+	  (fsc-instance-wrapper ,x))	      
+         (t
+	  (#+new-kcl-wrapper built-in-wrapper-of
+	   #-new-kcl-wrapper built-in-or-structure-wrapper
+	   ,x))))
+
+(defun class-of (x)
+  (wrapper-class* (wrapper-of-macro x)))
+
+(defun wrapper-of (x)
+  (wrapper-of-macro x))
 
 (defun structure-wrapper (x)
   (class-wrapper (find-class (structure-type x))))
 
 (defvar find-structure-class nil)
 
-(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)))))
+(defun eval-form (form)
+  #'(lambda () (eval form)))
+
+(defun slot-initargs-from-structure-slotd (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)
+    :type ,(or (structure-slotd-type slotd) t)
+    :initform ,(structure-slotd-init-form slotd)
+    :initfunction ,(eval-form (structure-slotd-init-form slotd))))
+
+(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 #'slot-initargs-from-structure-slotd
+				(structure-type-slot-description-list symbol)))))
+      (error "~S is not a legal structure class name." symbol)))
 
 (eval-when (compile eval)
 
@@ -770,69 +637,62 @@
 
 
 
+(defun method-function-returning-nil (args next-methods)
+  (declare (ignore args next-methods))
+  nil)
+
+(defun method-function-returning-t (args next-methods)
+  (declare (ignore args next-methods))
+  t)
+
+(defun make-class-predicate (class name)
+  (let* ((gf (ensure-generic-function name))
+	 (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 #'method-function-returning-nil)
+	       (default-method-initargs (list :function
+					      default-method-function))
+	       (default-method (make-a-method 'standard-method
+					      ()
+					      (list 'object)
+					      (list *the-class-t*)
+					      default-method-initargs
+					      "class predicate default method")))
+	  (setf (method-function-get default-method-function :constant-value) nil)
+	  (add-method gf default-method)))
+      (let* ((class-method-function #'method-function-returning-t)
+	     (class-method-initargs (list :function
+					  class-method-function))
+	     (class-method (make-a-method 'standard-method
+					  ()
+					  (list 'object)
+					  (list class)
+					  class-method-initargs
+					  "class predicate class method")))
+	(setf (method-function-get class-method-function :constant-value) t)
+	(add-method gf class-method)))
+    gf))
 
 (eval-when (load eval)
   (clrhash *find-class*)
   (bootstrap-meta-braid)
+  (bootstrap-accessor-definitions t)
+  (bootstrap-class-predicates t)
+  (bootstrap-accessor-definitions nil)
+  (bootstrap-class-predicates nil)
   (bootstrap-built-in-classes)
-  (early-initialize-slot-gfs)
-  (early-initialize-class-predicates)
   (setq *boot-state* 'braid)
-  (setf (symbol-function 'load-defclass) #'real-load-defclass)
   )
 
 (deftype slot-object ()
   '(or standard-object structure-object))
 
-
-;;;
-;;; All of these method definitions must appear here because the bootstrap
-;;; only allows one method per generic function until the braid is fully
-;;; built.
-;;;
-(defmethod print-object (instance stream)
-  (printing-random-thing (instance stream)
-    (let ((name (class-name (class-of instance))))
-      (if name
-	  (format stream "~S" name)
-	  (format stream "Instance")))))
-
-(defmethod print-object ((class class) stream)
-  (named-object-print-function class stream))
-
-(defmethod print-object ((slotd slot-definition) stream)
-  (named-object-print-function slotd stream))
-
-(defun named-object-print-function (instance stream
-				    &optional (extra nil extra-p))
-  (printing-random-thing (instance stream)
-    (if extra-p					
-	(format stream "~A ~S ~:S"
-		(capitalize-words (class-name (class-of instance)))
-		(slot-value-or-default instance 'name)
-		extra)
-	(format stream "~A ~S"
-		(capitalize-words (class-name (class-of instance)))
-		(slot-value-or-default instance 'name)))))
-
-
-
-;;;
-;;;
-;;;
-(defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key)
-  (declare (ignore slot-names))
-  (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))
-  (declare (ignore slot-names))
-  (unless (eq allocation :instance)
-    (error "structure slots must have :instance allocation")))
-
-
-(defmethod inform-type-system-about-class ((class structure-class) name)
-  (inform-type-system-about-std-class name))
-
+(defmethod no-applicable-method (generic-function &rest args)
+  (cerror "Retry call to ~S"
+	  "No matching method for the generic-function ~S,~@
+          when called with arguments ~S."
+	  generic-function args)
+  (apply generic-function args))
diff --git a/pcl/cache.lisp b/pcl/cache.lisp
index e702439a1..ac3b00434 100644
--- a/pcl/cache.lisp
+++ b/pcl/cache.lisp
@@ -73,29 +73,7 @@
 ;;; 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
 ;;;
@@ -114,37 +92,30 @@
   `(svref (the simple-vector ,cache-vector)
           (#-cmu the #+cmu ext:truly-the fixnum ,location)))
 
-(defun emit-cache-vector-ref (cache-vector-operand location-operand)
-  (operand :iref cache-vector-operand location-operand))
-
-
 (defmacro cache-vector-size (cache-vector)
   `(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-simple
+  (without-interrupts  
     (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-simple
+  `(without-interrupts
      (multiple-value-prog1
        (progn ,@body)
        (let ((old-count (cache-vector-lock-count ,cache-vector)))
-	 (declare (type index old-count))
+	 (declare (fixnum old-count))
 	 (setf (cache-vector-lock-count ,cache-vector)
-               (the index
-	            (if (= old-count most-positive-fixnum)
-		        1
-                        (the index (1+ old-count)))))))))
+	       (if (= old-count most-positive-fixnum)
+		   1 (the fixnum (1+ old-count))))))))
 
 (deftype field-type ()
   '(integer 0    ;#.(position 'number wrapper-layout)
@@ -152,9 +123,9 @@
 
 (eval-when (compile load eval)
 (defun power-of-two-ceiling (x)
-  (declare (type index x))
+  (declare (fixnum x))
   ;;(expt 2 (ceiling (log x 2)))
-  (the index (ash 1 (integer-length (1- x)))))
+  (the fixnum (ash 1 (integer-length (1- x)))))
 
 (defconstant *nkeys-limit* 256)
 )
@@ -163,15 +134,16 @@
 	     (:print-function print-cache)
 	     (:constructor make-cache ())
 	     (:copier copy-cache-internal))
+  (owner nil)
   (nkeys 1 :type (integer 1 #.*nkeys-limit*))
-  (valuep nil :type boolean)
-  (nlines 0 :type index)
+  (valuep nil :type (member nil t))
+  (nlines 0 :type fixnum)
   (field 0 :type field-type)
-  (limit-fn #'default-limit-fn :type real-function)
-  (mask 0 :type index)
-  (size 0 :type index)
+  (limit-fn #'default-limit-fn :type function)
+  (mask 0 :type fixnum)
+  (size 0 :type fixnum)
   (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*))))
-  (max-location 0 :type index)
+  (max-location 0 :type fixnum)
   (vector #() :type simple-vector)
   (overflow nil :type list))
 
@@ -197,18 +169,18 @@
 (defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
 
 ;;;
-;;; Return a cache that has had flush-cache-internal called on it.  This
+;;; Return a cache that has had flush-cache-vector-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-simple
+    (without-interrupts
       (cond ((null entry)
 	     (setf (gethash size *free-cache-vectors*) (cons 0 nil))
 	     (get-cache-vector size))
 	    ((null (cdr entry))
-             (setf (car entry) (the fixnum (1+ (the fixnum (car entry)))))
+	     (incf (car entry))
 	     (flush-cache-vector-internal (allocate-cache-vector size)))
 	    (t
 	     (let ((cache (cdr entry)))
@@ -217,7 +189,7 @@
 
 (defun free-cache-vector (cache-vector)
   (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
-    (without-interrupts-simple
+    (without-interrupts
       (if (null entry)
 	  (error "Attempt to free a cache-vector not allocated by GET-CACHE-VECTOR.")
 	  (let ((thread (cdr entry)))
@@ -243,7 +215,6 @@
 	     (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))
@@ -283,16 +254,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 (type index n))
+    (declare (fixnum n))
     (loop
       (setq n
-	    (logand (the index wrapper-cache-number-mask)
-		    (the index (random most-positive-fixnum
-                                       *get-wrapper-cache-number*))))
+	    (logand wrapper-cache-number-mask
+		    (random most-positive-fixnum *get-wrapper-cache-number*)))
       (unless (zerop n) (return n)))))
 
 
@@ -326,18 +297,8 @@
 ;;; 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
@@ -348,34 +309,25 @@
 	       number
 	       number
 	       number
-               wrapper-identifier
 	       state
 	       instance-slots-layout
 	       class-slots
 	       class
-               allocate-static-slot-storage-copy
-               unreserved-field))
-
-(defconstant wrapper-length (length wrapper-layout))
-
-(deftype wrapper () `(simple-vector 15)) ; #.(length wrapper-layout)
+	       no-of-instance-slots))
 )
 
 (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 ()
-  `(the field-type (wrapper-field 'number)))
+  `(wrapper-field 'number))
 
 (defmacro next-wrapper-cache-number-index (field-number)
   `(next-wrapper-field ,field-number))
@@ -388,74 +340,45 @@
 (defmacro cache-number-vector-ref (cnv n)
   `(svref ,cnv ,n))
 
-(defconstant *wrapper-identifier-symbol* (gensym "WRAPPER-IDENTIFIER"))
 
 (defmacro wrapper-ref (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*)))))
+  `(svref ,wrapper ,n))
 
 (defmacro wrapper-state (wrapper)
   `(wrapper-ref ,wrapper ,(wrapper-field 'state)))
 
 (defmacro wrapper-instance-slots-layout (wrapper)
-  `(the list
-        (wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))))
+  `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout)))
 
 (defmacro wrapper-class-slots (wrapper)
-  `(the list
-        (wrapper-ref ,wrapper ,(wrapper-field 'class-slots))))
+  `(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 wrapper-no-of-instance-slots (wrapper)
+  `(wrapper-ref ,wrapper ,(wrapper-field 'no-of-instance-slots)))
 
 (defmacro make-wrapper-internal ()
-  `(let ((wrapper (make-array ,(length (the list wrapper-layout)) :adjustable nil)))
-     (declare (type wrapper wrapper))
+  `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil)))
      ,@(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)
-			      (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)
+			      (get-wrapper-cache-number))))
+	     ((state instance-slots-layout class-slots class no-of-instance-slots)))))
+     (setf (wrapper-state wrapper) 't)     
      wrapper))
 
-(defun make-wrapper (class)
+(defun make-wrapper (no-of-instance-slots &optional class)
   (let ((wrapper (make-wrapper-internal)))
+    (setf (wrapper-no-of-instance-slots wrapper) no-of-instance-slots)
     (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
@@ -474,108 +397,90 @@
 #+structure-wrapper
 (progn
 
+#-new-kcl-wrapper
 (defun make-wrapper-cache-number-vector ()
-  (let ((cnv (make-array wrapper-cache-number-vector-length)))
+  (let ((cnv (make-array #.wrapper-cache-number-vector-length
+			 :element-type 'fixnum)))
     (dotimes (i #.wrapper-cache-number-vector-length)
-      (setf (svref cnv i) (get-wrapper-cache-number)))
+      (setf (aref cnv i) (get-wrapper-cache-number)))
     cnv))
 
 (defstruct (wrapper
+	     #+new-kcl-wrapper (:include si::basic-wrapper)
 	     (:print-function print-wrapper)
-	     (:constructor make-wrapper (class)))
+	     #-new-kcl-wrapper
+	     (:constructor make-wrapper (no-of-instance-slots &optional class))
+	     #+new-kcl-wrapper
+	     (:constructor make-wrapper-internal))
+  #-new-kcl-wrapper
   (cache-number-vector (make-wrapper-cache-number-vector)
 		       :type cache-number-vector)
-  (state t :type (or (member t) cons)) ; a cons whose car is one of: flush or obsolete
+  #-new-kcl-wrapper
+  (state t :type (or (member t) cons)) 
+  ;;  either t or a list (state-sym new-wrapper)
+  ;;           where state-sym is either :flush or :obsolete
   (instance-slots-layout nil :type list)
   (class-slots nil :type list)
-  (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)
+  #-new-kcl-wrapper
+  (no-of-instance-slots 0 :type fixnum)
+  #-new-kcl-wrapper
+  (class *the-class-t* :type class))
+
+(unless (boundp '*the-class-t*) (setq *the-class-t* nil))
+
+#+new-kcl-wrapper
+(defmacro wrapper-no-of-instance-slots (wrapper)
+  `(si::s-data-length ,wrapper))
+
+#+new-kcl-wrapper
+(defun make-wrapper (size &optional class)
+  (multiple-value-bind (raw slot-positions)
+      (if (< size 50)
+	  (values si::*all-t-s-type* si::*standard-slot-positions*)
+	  (values (make-array size :element-type 'unsigned-char)
+		  (let ((array (make-array size :element-type 'unsigned-short)))
+		    (dotimes (i size)
+		      (declare (fixnum i))
+		      (setf (aref array i) (* #.(si::size-of t) i))))))
+    (make-wrapper-internal :length size
+			   :raw raw
+			   :print-function 'print-std-instance
+			   :slot-position slot-positions
+			   :size (* size #.(si::size-of t))
+			   :class class)))
 
 (defun print-wrapper (wrapper stream depth)
   (declare (ignore depth))
   (printing-random-thing (wrapper stream)
-    (format stream "wrapper ~S" (wrapper-class wrapper))))
+    (format stream "Wrapper ~S" (wrapper-class wrapper))))
 
 (defmacro first-wrapper-cache-number-index ()
   0)
 
 (defmacro next-wrapper-cache-number-index (field-number)
-  `(and (< (the index ,field-number) #.(1- wrapper-cache-number-vector-length))
-        (1+ (the index ,field-number))))
+  `(and (< ,field-number #.(1- wrapper-cache-number-vector-length))
+        (1+ ,field-number)))
 
 (defmacro cache-number-vector-ref (cnv n)
-  `(svref ,cnv ,n))
+  `(#-kcl svref #+kcl aref ,cnv ,n))
 
-(defun emit-wrapper-cache-number-vector (wrapper-operand)
-  (operand :wrapper-cache-number-vector wrapper-operand))
+)
 
-(defun emit-cache-number-vector-ref (cnv-operand field-operand)
-  (operand :iref cnv-operand field-operand))
+(defmacro wrapper-cache-number-vector-ref (wrapper n)
+  `(the fixnum
+        (#-structure-wrapper svref #+structure-wrapper aref
+          (wrapper-cache-number-vector ,wrapper) ,n)))
 
-) ;#+structure-wrapper
+(defmacro class-no-of-instance-slots (class)
+  `(wrapper-no-of-instance-slots (class-wrapper ,class)))
 
-(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))))
+(defmacro wrapper-class* (wrapper)
+  #-new-kcl-wrapper
+  `(wrapper-class ,wrapper)
+  #+new-kcl-wrapper
+  `(let ((wrapper ,wrapper))
+     (or (wrapper-class wrapper)
+         (find-structure-class (si::s-data-name wrapper)))))
 
 ;;;
 ;;; The wrapper cache machinery provides general mechanism for trapping on
@@ -597,7 +502,7 @@
 
 (defun invalidate-wrapper (owrapper state nwrapper)
   (ecase state
-    ((flush obsolete)
+    ((:flush :obsolete)
      (let ((new-previous ()))
        ;;
        ;; First off, a previous call to invalidate-wrapper may have recorded
@@ -609,8 +514,8 @@
        ;; kind of transitivity of wrapper updates.
        ;; 
        (dolist (previous (gethash owrapper *previous-nwrappers*))
-	 (when (eq state 'obsolete)
-	   (setf (car previous) 'obsolete))
+	 (when (eq state ':obsolete)
+	   (setf (car previous) ':obsolete))
 	 (setf (cadr previous) nwrapper)
 	 (push previous new-previous))
        
@@ -624,42 +529,54 @@
        (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)
-  (fast-check-wrapper-validity instance wrapper-of))
-
-
+  (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))
+			    #+new-kcl-wrapper
+			    (t (built-in-wrapper-of ,object))
+			    #-new-kcl-wrapper
+			    (t (wrapper-of ,object)))))
+       (if (eq 't (wrapper-state ,owrapper))
+	   ,owrapper
+	   (check-wrapper-validity ,object)))))
 
 
 (defvar *free-caches* nil)
 
 (defun get-cache (nkeys valuep limit-fn nlines)
-  (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))))
+  (let ((cache (or (without-interrupts (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
@@ -668,32 +585,27 @@
 	    (cache-mask cache) cache-mask
 	    (cache-size cache) actual-size
 	    (cache-line-size cache) 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-max-location cache) (let ((line (1- nlines)))
+					 (if (= nkeys 1)
+					     (* line line-size)
+					     (1+ (* 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-simple (pop *free-caches*))
-                   (make-cache))))
-    (declare (type cache cache) (type index nkeys)
-             (type boolean valuep))
+	(cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+    (declare (type cache cache))
     (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
+      (setf (cache-owner cache) (cache-owner old-cache)
+	    (cache-nkeys cache) nkeys
 	    (cache-valuep cache) valuep
 	    (cache-nlines cache) nlines
 	    (cache-field cache) new-field
@@ -701,12 +613,10 @@
 	    (cache-mask cache) cache-mask
 	    (cache-size cache) actual-size
 	    (cache-line-size cache) 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-max-location cache) (let ((line (1- nlines)))
+					 (if (= nkeys 1)
+					     (* line line-size)
+					     (1+ (* line line-size))))
 	    (cache-vector cache) (get-cache-vector actual-size)
 	    (cache-overflow cache) nil)
       cache)))
@@ -716,8 +626,7 @@
 	 (size (cache-size old-cache))
 	 (old-vector (cache-vector old-cache))
 	 (new-vector (get-cache-vector size)))
-    (declare (type simple-vector old-vector new-vector)
-             (type index         size))
+    (declare (simple-vector old-vector new-vector))
     (dotimes (i size)
       (setf (svref new-vector i) (svref old-vector i)))
     (setf (cache-vector new-cache) new-vector)
@@ -726,42 +635,43 @@
 (defun free-cache (cache)
   (free-cache-vector (cache-vector cache))
   (setf (cache-vector cache) #())
+  (setf (cache-owner cache) nil)
   (push cache *free-caches*)
   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 (type index nkeys))
+  ;;(declare (values cache-mask actual-size line-size nlines))
+  (declare (fixnum nkeys))
   (if (= nkeys 1)
       (let* ((line-size (if valuep 2 1))
 	     (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-			     (the index
+			     (the fixnum 
 				  (* line-size
-				     (power-of-two-ceiling 
-					(the index nlines-or-cache-vector))))
+				     (the fixnum 
+					  (power-of-two-ceiling 
+					    nlines-or-cache-vector))))
 			     (cache-vector-size nlines-or-cache-vector))))
-	(declare (type index line-size cache-size))
-	(values (logxor (the index (1- cache-size)) (the index (1- line-size)))
+	(declare (fixnum line-size cache-size))
+	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
 		cache-size
 		line-size
-		(the index (floor cache-size line-size))))
+		(the fixnum (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 index
+			     (the fixnum
 				  (* line-size
-				     (the index
+				     (the fixnum
 					  (power-of-two-ceiling 
 					    nlines-or-cache-vector))))
 			     (1- (cache-vector-size nlines-or-cache-vector)))))
-	(declare (type index line-size cache-size))
-	(values (logxor (the index (1- cache-size)) (the index (1- line-size)))
-		(the index (1+ cache-size))
+	(declare (fixnum line-size cache-size))
+	(values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+		(the fixnum (1+ cache-size))
 		line-size
-		(the index (floor cache-size line-size))))))
+		(the fixnum (floor cache-size line-size))))))
 
 
 
@@ -785,21 +695,20 @@
 ;;; compute the primary location of an entry.  
 ;;;
 (defun compute-primary-cache-location (field mask wrappers)
-  (declare (type field-type field) (type index mask))
+  (declare (type field-type field) (fixnum mask))
   (if (not (listp wrappers))
-      (the index
-          (logand mask (the index (wrapper-cache-number-vector-ref wrappers field))))
+      (logand mask (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
       (let ((location 0) (i 0))
-	(declare (type index location i))
+	(declare (fixnum 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 (type index wrapper-cache-number))
+	    (declare (fixnum wrapper-cache-number))
 	    (if (zerop wrapper-cache-number)
 		(return-from compute-primary-cache-location 0)
-		(setq location (the index (+ location wrapper-cache-number)))))
+		(setq location (the fixnum (+ location wrapper-cache-number)))))
 	  ;;
 	  ;; Then, if we are working with lots of wrappers, deal with
 	  ;; the wrapper-cache-number-mask stuff.
@@ -807,9 +716,9 @@
 	  (when (and (not (zerop i))
 		     (zerop (mod i wrapper-cache-number-adds-ok)))
 	    (setq location
-		  (the index (logand location wrapper-cache-number-mask))))
-	  (setf i (the index (1+ i))))
-	(the index (1+ (the index (logand mask location)))))))
+		  (logand location wrapper-cache-number-mask)))
+	  (incf i))
+	(the fixnum (1+ (logand mask location))))))
 
 ;;;
 ;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
@@ -823,72 +732,27 @@
 ;;; invalid to suggest to its caller that it would be provident to blow away
 ;;; the cache line in question.
 ;;;
-(defun compute-primary-cache-location-from-location (field cache location)
-  (declare (type field-type field) (type index location))
+(defun compute-primary-cache-location-from-location (to-cache from-location 
+						     &optional (from-cache to-cache))
+  (declare (type cache to-cache from-cache) (fixnum from-location))
   (let ((result 0)
-	(cache-vector (cache-vector cache))
-	(mask (cache-mask cache))
-	(nkeys (cache-nkeys cache)))
-    (declare (type index result mask nkeys) (simple-vector cache-vector))
+	(cache-vector (cache-vector from-cache))
+	(field (cache-field to-cache))
+	(mask (cache-mask to-cache))
+	(nkeys (cache-nkeys to-cache)))
+    (declare (type field-type field) (fixnum result mask nkeys)
+	     (simple-vector cache-vector))
     (dotimes (i nkeys)
-      (let* ((wrapper (cache-vector-ref cache-vector (+ i location)))
+      (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
 	     (wcn (wrapper-cache-number-vector-ref wrapper field)))
-	(declare (type index wcn))
-	(setq result (the index (+ result wcn))))
+	(declare (fixnum wcn))
+	(setq result (+ result wcn)))
       (when (and (not (zerop i))
 		 (zerop (mod i wrapper-cache-number-adds-ok)))
-	(setq result (the index (logand result wrapper-cache-number-mask)))))
+	(setq result (logand result wrapper-cache-number-mask))))    
     (if (= nkeys 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) 
-		       #+structure-wrapper (cnv fixnum-vector))
-    (let ((field wrapper-cache-no))
-      (flatten-lap
-        (opcode :move (operand :cvar 'mask) mask)
-        (opcode :move (operand :cvar 'field) field)
-	#-structure-wrapper
-        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-	#+structure-wrapper
-	(opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-	#+structure-wrapper
-	(opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no)
-        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
-  (with-lap-registers ((field index)
-		       (mask index))
-    (let ((add-wrapper-cache-numbers
-	   (flatten-lap
-	    (gathering1 (flattening-lap)
-	       (iterate ((wrapper (list-elements wrappers))
-			 (i (interval :from 1)))
-		 (gather1
-		  (with-lap-registers ((wrapper-cache-no index)
-				       #+structure-wrapper (cnv fixnum-vector))
-		    (flatten-lap
-		     #-structure-wrapper
-		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
-		     #+structure-wrapper
-		     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
-		     #+structure-wrapper
-		     (opcode :move (emit-cache-number-vector-ref cnv field)
-			     wrapper-cache-no)
-		     (opcode :izerop wrapper-cache-no miss-label)
-		     (opcode :move (operand :i+ primary wrapper-cache-no) primary)
-		     (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)
-       (opcode :move (operand :cvar 'field) field)
-       (opcode :move (operand :cvar 'mask) mask)
-       add-wrapper-cache-numbers
-       (opcode :move (operand :ilogand primary mask) primary)
-       (opcode :move (operand :i1+ primary) primary)))))
-
+	(the fixnum (1+ (logand mask result))))))
 
 
 ;;;
@@ -934,77 +798,54 @@
 	      ((eq metatype new-metatype) new-metatype)
 	      (t 'class))))))
 
-
-
-(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
-  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
-    (with-lap-registers ((arg t))
-      (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"))
-                #+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
-		   (opcode :move (operand :fsc-slots arg) slot))
-	      (opcode :go exit-emit-fetch-wrapper)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
-	      (and slot
-		   (opcode :move (operand :std-slots arg) slot))
-	      (opcode :label exit-emit-fetch-wrapper))))
-	(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"))
-                #+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)
-	      (opcode :label get-std-inst-wrapper)
-	      (opcode :move (operand :std-wrapper arg) dest)
-	      (opcode :label exit-emit-fetch-wrapper))))
-	((built-in-instance structure-instance)
-	  (when slot (error "Can't do a slot reg for this metatype."))
-	  (let ()
-	    (flatten-lap
-	      (opcode :move (operand :arg argument) arg)
-	      (opcode :std-instance-p arg miss-label)
-	      (opcode :fsc-instance-p arg miss-label)
-	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest))))))))
+(defmacro with-dfun-wrappers ((args metatypes)
+			      (dfun-wrappers invalid-wrapper-p 
+					     &optional wrappers classes types)
+			      invalid-arguments-form
+			      &body body)
+  `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
+	  (,dfun-wrappers nil) (dfun-wrappers-tail nil)
+	  ,@(when wrappers
+	      `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
+     (dolist (mt ,metatypes)
+       (unless args-tail
+	 (setq invalid-arguments-p t)
+	 (return nil))
+       (let* ((arg (pop args-tail))
+	      (wrapper nil)
+	      ,@(when wrappers
+		  `((class *the-class-t*)
+		    (type 't))))
+	 (unless (eq mt 't)
+	   (setq wrapper (wrapper-of arg))
+	   (when (invalid-wrapper-p wrapper)
+	     (setq ,invalid-wrapper-p t)
+	     (setq wrapper (check-wrapper-validity arg)))
+	   (cond ((null ,dfun-wrappers)
+		  (setq ,dfun-wrappers wrapper))
+		 ((not (consp ,dfun-wrappers))
+		  (setq dfun-wrappers-tail (list wrapper))
+		  (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
+		 (t
+		  (let ((new-dfun-wrappers-tail (list wrapper)))
+		    (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
+		    (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
+	   ,@(when wrappers
+	       `((setq class (wrapper-class* wrapper))
+		 (setq type `(class-eq ,class)))))
+	 ,@(when wrappers
+	     `((push wrapper wrappers-rev)
+	       (push class classes-rev)
+	       (push type types-rev)))))
+     (if invalid-arguments-p
+	 ,invalid-arguments-form
+	 (let* (,@(when wrappers
+		    `((,wrappers (nreverse wrappers-rev))
+		      (,classes (nreverse classes-rev))
+		      (,types (mapcar #'(lambda (class)
+					  `(class-eq ,class))
+			              ,classes)))))
+	   ,@body))))
 
 
 ;;;
@@ -1017,14 +858,12 @@
 (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*)))
 
@@ -1047,6 +886,18 @@
     (when applyp
       (gather1 '&rest))))
 
+(defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
+  (let ((required
+	 (gathering1 (collecting)
+	    (iterate ((i (interval :from 0))
+		      (s (list-elements metatypes)))
+	      (progn s)
+	      (gather1 (dfun-arg-symbol i))))))
+    `(,(if (eq emf-type 'fast-method-call)
+	   'invoke-effective-method-function-fast
+	   'invoke-effective-method-function)
+      ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
+
 (defun make-dfun-call (metatypes applyp fn-variable)
   (let ((required
 	  (gathering1 (collecting)
@@ -1055,8 +906,30 @@
 	      (progn s)
 	      (gather1 (dfun-arg-symbol i))))))
     (if applyp
-	`(method-function-apply   ,fn-variable ,@required .dfun-rest-arg.)
-	`(method-function-funcall ,fn-variable ,@required))))
+	`(function-apply   ,fn-variable ,@required .dfun-rest-arg.)
+	`(function-funcall ,fn-variable ,@required))))
+
+(defun make-dfun-arg-list (metatypes applyp)
+  (let ((required
+	  (gathering1 (collecting)
+	    (iterate ((i (interval :from 0))
+		      (s (list-elements metatypes)))
+	      (progn s)
+	      (gather1 (dfun-arg-symbol i))))))
+    (if applyp
+	`(list* ,@required .dfun-rest-arg.)
+	`(list ,@required))))
+
+(defun make-fast-method-call-lambda-list (metatypes applyp)
+  (gathering1 (collecting)
+    (gather1 '.pv-cell.)
+    (gather1 '.next-method-call.)
+    (iterate ((i (interval :from 0))
+	      (s (list-elements metatypes)))
+      (progn s)
+      (gather1 (dfun-arg-symbol i)))
+    (when applyp
+      (gather1 '.dfun-rest-arg.))))
 
 
 ;;;
@@ -1087,18 +960,19 @@
     (size () (cache-size .cache.))
     (mask () (cache-mask .cache.))
     (field () (cache-field .cache.))
+    (overflow () (cache-overflow .cache.))
 
     ;;
     ;; Return T IFF this cache location is reserved.  The only time
     ;; this is true is for line number 0 of an nkeys=1 cache.  
     ;;
     (line-reserved-p (line)
-      (declare (type index line))
+      (declare (fixnum line))
       (and (= (nkeys) 1)
            (= line 0)))
     ;;
     (location-reserved-p (location)
-      (declare (type index location))
+      (declare (fixnum location))
       (and (= (nkeys) 1)
            (= location 0)))
     ;;
@@ -1108,21 +982,21 @@
     ;; by line size.  
     ;; 	  
     (line-location (line)
-      (declare (type index line))
+      (declare (fixnum line))
       (when (line-reserved-p line)
         (error "line is reserved"))
       (if (= (nkeys) 1)
-	  (the index (* line (line-size)))
-	  (the index (1+ (the index (* line (line-size)))))))
+	  (the fixnum (* line (line-size)))
+	  (the fixnum (1+ (the fixnum (* line (line-size)))))))
     ;;
     ;; Given a cache location, return the line.  This is the inverse
     ;; of LINE-LOCATION.
     ;; 	  
     (location-line (location)
-      (declare (type index location))
+      (declare (fixnum location))
       (if (= (nkeys) 1)
 	  (floor location (line-size))
-	  (floor (the index (1- location)) (line-size))))
+	  (floor (the fixnum (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
@@ -1130,12 +1004,12 @@
     ;; line is reserved.
     ;;
     (line-wrappers (line)
-      (declare (type index line))
+      (declare (fixnum 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 (type index location))
+      (declare (fixnum location))
       (if (= (nkeys) 1)
 	  (cache-vector-ref (vector) location)
 	  (let ((list (make-list (nkeys)))
@@ -1148,12 +1022,12 @@
     ;; wrappers are the same as wrappers.
     ;;
     (line-matches-wrappers-p (line wrappers)
-      (declare (type index line))
+      (declare (fixnum 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 (type index loc))
+      (declare (fixnum loc))
       (let ((cache-vector (vector)))
 	(declare (simple-vector cache-vector))
 	(if (= (nkeys) 1)
@@ -1167,12 +1041,12 @@
     ;; an error is signalled if the line is reserved.
     ;; 
     (line-value (line)
-      (declare (type index line))
+      (declare (fixnum line))
       (when (line-reserved-p line) (error "Line is reserved."))
       (location-value (line-location line)))
     ;;
     (location-value (loc)
-      (declare (type index loc))
+      (declare (fixnum loc))
       (and (valuep)
            (cache-vector-ref (vector) (+ loc (nkeys)))))
     ;;
@@ -1189,12 +1063,12 @@
     ;; An error is signalled if the line is reserved.
     ;;
     (line-valid-p (line wrappers)
-      (declare (type index line))
+      (declare (fixnum line))
       (when (line-reserved-p line) (error "Line is reserved."))
       (location-valid-p (line-location line) wrappers))
     ;;
     (location-valid-p (loc wrappers)
-      (declare (type index loc))
+      (declare (fixnum loc))
       (let ((cache-vector (vector))
 	    (wrappers-mismatch-p (null wrappers)))
 	(declare (simple-vector cache-vector))
@@ -1211,9 +1085,9 @@
     ;; How many unreserved lines separate line-1 and line-2.
     ;;
     (line-separation (line-1 line-2)
-     (declare (type index line-1 line-2))
+     (declare (fixnum line-1 line-2))
      (let ((diff (the fixnum (- line-2 line-1))))
-       (declare (type fixnum diff))
+       (declare (fixnum diff))
        (when (minusp diff)
 	 (setq diff (+ diff (nlines)))
 	 (when (line-reserved-p 0)
@@ -1224,32 +1098,32 @@
     ;; return a reserved line.
     ;; 
     (next-line (line)
-     (declare (type index line))
-     (if (= line (the index (1- (nlines))))
+     (declare (fixnum line))
+     (if (= line (the fixnum (1- (nlines))))
 	 (if (line-reserved-p 0) 1 0)
-	 (the index (1+ line))))
+	 (the fixnum (1+ line))))
     ;;
     (next-location (loc)
-      (declare (type index loc))
+      (declare (fixnum loc))
       (if (= loc (max-location))
 	  (if (= (nkeys) 1)
 	      (line-size)
 	      1)
-	  (the index (+ loc (line-size)))))
+	  (the fixnum (+ 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
     ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
     ;; easier packaging up of the call to it.
     ;; 
-    (line-primary (field line)
-      (declare (type index field line))
-      (location-line (line-primary-location field line)))
+    (line-primary (line)
+      (declare (fixnum line))
+      (location-line (line-primary-location line)))
     ;;
-    (line-primary-location (field line)
-     (declare (type index field line))
+    (line-primary-location (line)
+     (declare (fixnum line))
      (compute-primary-cache-location-from-location
-       field (cache) (line-location line)))
+       (cache) (line-location line)))
     ))
 
 (defmacro with-local-cache-functions ((cache) &body body)
@@ -1264,7 +1138,7 @@
 			*local-cache-functions*)
        ,@body)))
 
-) ;eval-when
+)
 
 ;;;
 ;;; Here is where we actually fill, recache and expand caches.
@@ -1285,55 +1159,66 @@
 ;;;
 (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 (< (the index (ceiling (* (cache-count cache) 1.25)))
-	      (the index
-                   (if (= (cache-nkeys cache) 1)
-		       (1- (cache-nlines cache))
-		       (cache-nlines cache))))
+      (and (< (ceiling (* (cache-count cache) 1.25))
+	      (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))
+(defvar *check-cache-p* nil)
+
+(defmacro maybe-check-cache (cache)
+  `(progn
+     (when *check-cache-p*
+       (check-cache ,cache))
+     ,cache))
+
+(defun check-cache (cache)
+  (with-local-cache-functions (cache)
+    (let ((location (if (= (nkeys) 1) 0 1))
+	  (limit (funcall (limit-fn) (nlines))))
+      (dotimes (i (nlines) cache)
+	(when (and (not (location-reserved-p location))
+		   (line-full-p i))
+	  (let* ((home-loc (compute-primary-cache-location-from-location 
+			    cache location))
+		 (home (location-line (if (location-reserved-p home-loc)
+					  (next-location home-loc)
+					  home-loc)))
+		 (sep (when home (line-separation home i))))
+	    (when (and sep (> sep limit))
+	      (error "bad cache ~S ~@
+                      value at location ~D is ~D lines from its home. limit is ~D."
+		     cache location sep limit))))
+	(setq location (next-location location))))))
+
+(defun probe-cache (cache wrappers &optional default limit-fn)
+  ;;(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-function (limit-fn) (nlines))))
-      (declare (type index location limit))
+	   (limit (funcall (or limit-fn (limit-fn)) (nlines))))
+      (declare (fixnum location limit))
       (when (location-reserved-p location)
 	(setq location (next-location location)))
-      (dotimes (i limit default)
+      (dotimes (i (1+ limit))
 	(when (location-matches-wrappers-p location wrappers)
-	  (return (or (not (valuep)) (location-value location))))
-	(setq location (next-location location))))))
+	  (return-from probe-cache (or (not (valuep))
+				       (location-value location))))
+	(setq location (next-location location)))
+      (dolist (entry (overflow))
+	(when (equal (car entry) wrappers)
+	  (return-from probe-cache (or (not (valuep))
+				       (cdr entry)))))
+      default)))
 
 (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)
@@ -1341,18 +1226,38 @@
 	  (let ((value (funcall function (line-wrappers i) (line-value i))))
 	    (when set-p
 	      (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
-		    value))))))))
+		    value)))))
+      (dolist (entry (overflow))
+	(let ((value (funcall function (car entry) (cdr entry))))
+	  (when set-p
+	    (setf (cdr entry) value))))))
+  cache)
 
+(defun cache-count (cache)
+  (with-local-cache-functions (cache)
+    (let ((count 0))
+      (declare (fixnum count))
+      (dotimes (i (nlines) count)
+	(unless (line-reserved-p i)
+	  (when (line-full-p i)
+	    (incf count)))))))
+
+(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 (type index location primary))
+      (declare (fixnum location primary))
       (multiple-value-bind (free emptyp)
 	  (find-free-cache-line primary cache wrappers)
 	(when (or forcep emptyp)
@@ -1361,32 +1266,33 @@
 		  (cache-overflow cache)))
 	  ;;(fill-line free wrappers value)
 	  (let ((line free))
-	    (declare (type index line))
+	    (declare (fixnum line))
 	    (when (line-reserved-p line)
 	      (error "Attempt to fill a reserved line."))
 	    (let ((loc (line-location line))
 		  (cache-vector (vector)))
-	      (declare (type index loc) (simple-vector cache-vector))
+	      (declare (fixnum 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 (type index i))
+		       (declare (fixnum i))
 		       (dolist (w wrappers)
 			 (setf (cache-vector-ref cache-vector (+ loc i)) w)
-			 (setq i (the index (1+ i)))))
+			 (setq i (the fixnum (1+ i)))))
 		     (when (valuep)
 		       (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
-			     value))))))
-	  cache)))))
+			     value))))
+	      (maybe-check-cache cache))))))))
 
 (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
-  (declare (type index from-line))
-  (with-local-cache-functions (from-cache)
-    (let ((primary (line-primary (field) from-line)))
-      (declare (type index primary))
+  (declare (fixnum from-line))
+  (with-local-cache-functions (cache)
+    (let ((primary (location-line (compute-primary-cache-location-from-location
+				   cache (line-location from-line) from-cache))))
+      (declare (fixnum primary))
       (multiple-value-bind (free emptyp)
 	  (find-free-cache-line primary cache)
 	(when (or forcep emptyp)
@@ -1394,25 +1300,25 @@
 	    (push (cons (line-wrappers free) (line-value free))
 		  (cache-overflow cache)))
 	  ;;(transfer-line from-cache-vector from-line cache-vector free)
-	  (let ((from-cache-vector (vector))
-		(to-cache-vector (cache-vector cache))
+	  (let ((from-cache-vector (cache-vector from-cache))
+		(to-cache-vector (vector))
 		(to-line free))
-	    (declare (type index to-line))
+	    (declare (fixnum 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 (type index from-loc to-loc))
+		  (declare (fixnum from-loc to-loc))
 		  (modify-cache to-cache-vector
 				(dotimes (i (line-size))
 				  (setf (cache-vector-ref to-cache-vector
 							  (+ to-loc i))
 					(cache-vector-ref from-cache-vector
-							  (+ from-loc i))))))))
-	  cache)))))
+							  (+ from-loc i)))))))
+	    (maybe-check-cache cache)))))))
 
 ;;;
-;;; Returns NIL or (values <field> <cache>)
+;;; Returns NIL or (values <field> <cache-vector>)
 ;;; 
 ;;; 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
@@ -1427,7 +1333,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) (the index nfield))
+	(setf (cache-field ncache) nfield)
 	(labels ((try-one-fill-from-line (line)
 		   (fill-cache-from-cache-p nil ncache cache line))
 		 (try-one-fill (wrappers value)
@@ -1441,7 +1347,7 @@
 		       (return nil)))
 		   (try-one-fill wrappers value))
 	      (progn (when free-old-cache-p (free-cache cache))
-		     (return ncache))
+		     (return (maybe-check-cache ncache)))
 	      (flush-cache-vector-internal (cache-vector ncache))))))))
 
 		       
@@ -1449,9 +1355,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 (the index (* (nlines) 2)))))
+    (let ((ncache (get-cache-from-cache cache (* (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))))
@@ -1470,9 +1376,9 @@
 	(unless (try-one-fill wrappers value)
 	  (do-one-fill wrappers value))
 	(when free-old-cache-p (free-cache cache))
-	ncache))))
-
+	(maybe-check-cache ncache)))))
 
+
 ;;;
 ;;; This is the heart of the cache filling mechanism.  It implements the decisions
 ;;; about where entries are placed.
@@ -1483,78 +1389,71 @@
 ;;;   <empty?>           is <line> in fact empty?
 ;;;
 (defun find-free-cache-line (primary cache &optional wrappers)
-  (declare (values line empty?))
-  (declare (type index primary))
+  ;;(declare (values line empty?))
+  (declare (fixnum primary))
   (with-local-cache-functions (cache)
     (when (line-reserved-p primary) (setq primary (next-line primary)))
-    (let ((limit (funcall-function (limit-fn) (nlines)))
-	  (field (field))
+    (let ((limit (funcall (limit-fn) (nlines)))
 	  (wrappedp nil)
 	  (lines nil)
-	  (p primary) (s primary)
-	  (successp nil))
-      (declare (type index p s limit) (type field-type field)
-               (type boolean wrappedp successp))
+	  (p primary) (s primary))
+      (declare (fixnum p s limit))
       (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) (the index (1+ nsep))))
+	       (nsep (line-separation p s) (1+ nsep)))
 	      (())
-	   (declare (type index line nsep))
+	   (declare (fixnum 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)))
-	   (let ((osep (line-separation (line-primary field line) line)))
-	     (when (and wrappedp (>= line primary))
-	       ;; have gone all the way around the cache, time to quit
-	       (push line lines)
-	       (return-from find-free (setq successp nil)))
+	     (return-from find-free))
+	   (when (and wrappedp (>= line primary))
+	     ;; have gone all the way around the cache, time to quit
+	     (return-from find-free-cache-line (values primary nil)))
+	   (let ((osep (line-separation (line-primary line) line)))
+	     (when (>= osep limit)
+	       (return-from find-free-cache-line (values primary nil)))
 	     (when (cond ((= nsep limit) t)
-			 ((= nsep osep) (zerop (the index (random 2))))
+			 ((= nsep osep) (zerop (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 index (1- (nlines)))) (setq wrappedp t))
-	       (setq p (line-primary field line))
+	       (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
+	       (setq p (line-primary line))
 	       (setq s (next-line line))
 	       (push line lines)
 	       (return nil)))
-	   (when (= line (the index (1- (nlines)))) (setq wrappedp t)))))
+	   (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
       ;; Do all the displacing.
       (loop 
        (when (null (cdr lines)) (return nil))
        (let ((dline (pop lines))
 	     (line (car lines)))
-	 (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 (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))
-				   (cache-vector-ref cache-vector (+ from-loc i)))
-			     (setf (cache-vector-ref cache-vector (+ from-loc i))
-				   nil)))))))
-      (values (car lines) successp))))
+	 (declare (fixnum dline line))
+	 ;;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))
+	   (modify-cache cache-vector
+			 (dotimes (i (line-size))
+			   (setf (cache-vector-ref cache-vector (+ to-loc i))
+				 (cache-vector-ref cache-vector (+ from-loc i)))
+			   (setf (cache-vector-ref cache-vector (+ from-loc i))
+				 nil))))))
+      (values (car lines) t))))
 
 (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 2c0b1a5ff..ab684398e 100644
--- a/pcl/cmu-low.lisp
+++ b/pcl/cmu-low.lisp
@@ -29,16 +29,9 @@
 
 (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 index ,count) ,result)
-     (declare (type index ,var))
+  `(lisp:dotimes (,var (the fixnum ,count) ,result)
+     (declare (fixnum ,var))
      ,@body))
 
 ;;; Just use our without-interrupts.  We don't have the INTERRUPTS-ON/OFF local
@@ -60,17 +53,6 @@
       `(and (ext:structurep ,n-x)
             (eq (kernel:structure-ref ,n-x 0) 'std-instance)))))
 
-  ;;   
-;;;;;; Cache No's
-  ;;  
-
-(proclaim '(inline object-cache-no))
-
-(defun object-cache-no (symbol mask)
-  (logand (ext:truly-the fixnum (system:%primitive make-fixnum symbol))
-          (the fixnum mask)))
-
-
 (defun function-arglist (fcn)
   "Returns the argument list of a compiled function, if possible."
   (cond ((symbolp fcn)
@@ -111,28 +93,378 @@
 (in-package "C")
 
 ;;From compiler/ir1util
-(def-source-context pcl::defmethod (name &rest stuff)
-  (declare (type list stuff))
+(def-source-context pcl:defmethod (name &rest 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)
+	`(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>"))))
+	`(pcl:defmethod ,name "<illegal syntax>"))))
 
+(define-info-type type kind (member :primitive :defined :structure :class nil)
+  (if (or (info type builtin name)
+	  (info type translator name))
+      :primitive
+      nil))
+(define-info-type type class-info (or pcl::class symbol null) nil)
 
-(in-package 'pcl)
+(in-package "KERNEL")
+
+(export '(clos-type clos-type-class))
+
+(defmacro cold-load-init (&rest forms)
+  `(progn ,@forms))
+
+(defstruct (clos-type (:include ctype
+				 (:class-info (type-class-or-lose 'clos))
+				 (:enumerable t))
+		       (:print-function %print-type))
+  ;;
+  ;; The CLOS class.
+  (class nil))
+
+(define-type-class clos)
+
+(define-type-method (clos :unparse) (x)
+  (clos-type-class x))
+
+(define-type-method (clos :complex-union) (type1 type2)
+  (make-union-type (list type1 type2)))
+
+(define-type-method (clos :simple-=) (type1 type2)
+  (values (eq (clos-type-class type1)
+	      (clos-type-class type2))
+	  t))
+
+(define-type-method (clos :simple-subtypep) (type1 type2)
+  (let ((class1 (pcl:find-class (clos-type-class type1) nil))
+	(class2 (pcl:find-class (clos-type-class type2) nil)))
+    (if (and class1 class2)
+	(values (member class2
+			(pcl:class-precedence-list class2))  t)
+      (values nil nil))))
+
+;; Add the new ctype to its supertypes.
+;;
+(let ((the-type-* (values-specifier-type '*)))
+  (pushnew 'clos (named-type-subclasses the-type-*)))
+(let ((the-type-t (values-specifier-type 't)))
+  (pushnew 'clos (named-type-subclasses the-type-t)))
+
+(defun-cached (values-specifier-type
+	       :hash-function (lambda (x)
+				(the fixnum
+				     (logand (the fixnum (cache-hash-eq x))
+					     #x3FF)))
+	       :hash-bits 10)
+    ((spec eq))
+  (or (info type builtin spec)
+      (let ((expand (type-expand spec)))
+	(if (eq expand spec)
+	    (let* ((lspec (if (atom spec) (list spec) spec))
+		   (fun (info type translator (car lspec))))
+	      (cond
+		(fun (funcall fun lspec))
+		((and (symbolp spec)
+		      (eq (info type kind spec) :structure))
+		 (make-structure-type :name spec))
+		((and (symbolp spec)
+		      (eq (info type kind spec) :class))
+		 (make-clos-type :class spec))
+		((or (and (consp spec) (symbolp (car spec)))
+		     (symbolp spec))
+		 (signal 'parse-unknown-type :specifier spec)
+		 ;;
+		 ;; Inhibit caching...
+		 (return-from values-specifier-type
+		   (make-unknown-type :specifier spec)))
+		(t
+		 (error "Bad thing to be a type specifier: ~S."
+			spec))))
+	    (values-specifier-type expand)))))
+
+(defun ctypep (obj type)
+  (declare (type ctype type))
+  (etypecase type
+    ((or numeric-type named-type member-type array-type)
+     (values (typep obj (type-specifier type)) t))
+    (structure-type
+     (if (structurep obj)
+	 (let* ((name (structure-type-name type))
+		(info (info type structure-info name))
+		(defined-info (info type defined-structure-info name)))
+	   (if (and info defined-info
+		    (equal (c::dd-includes info)
+			   (c::dd-includes defined-info)))
+	       (values (typep obj name) t)
+	       (values nil nil)))
+	 (values nil t)))
+    (clos-type
+     (let ((class (clos-type-class type)))
+       (if (pcl::std-instance-p obj)
+	   (values (pcl::*typep obj class) t)
+	   (values nil t))))
+    (union-type
+     (dolist (mem (union-type-types type) (values nil t))
+       (multiple-value-bind (val win)
+			    (ctypep obj mem)
+	 (unless win (return (values nil nil)))
+	 (when val (return (values t t))))))
+    (function-type
+     (values (functionp obj) t))
+    (unknown-type
+     (values nil nil))
+    (alien-type-type
+     (values (alien-typep obj (alien-type-type-alien-type type)) t))
+    (hairy-type
+     ;; Now the tricky stuff.
+     (let* ((hairy-spec (hairy-type-specifier type))
+	    (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+       (ecase symbol
+	 (and
+	  (if (atom hairy-spec)
+	      (values t t)
+	      (dolist (spec (cdr hairy-spec) (values t t))
+		(multiple-value-bind (res win)
+				     (ctypep obj (specifier-type spec))
+		  (unless win (return (values nil nil)))
+		  (unless res (return (values nil t)))))))
+	 (not
+	  (multiple-value-bind
+	      (res win)
+	      (ctypep obj (specifier-type (cadr hairy-spec)))
+	    (if win
+		(values (not res) t)
+		(values nil nil))))
+	 (satisfies
+	  (let ((fun (second hairy-spec)))
+	    (cond ((and (consp fun) (eq (car fun) 'lambda))
+		   (values (not (null (funcall (coerce fun 'function) obj)))
+			   t))
+		  ((and (symbolp fun) (fboundp fun))
+		   (values (not (null (funcall fun obj))) t))
+		  (t
+		   (values nil nil))))))))))
+
+(in-package "LISP")
+
+(defun %%typep (object type)
+  (declare (type ctype type))
+  (etypecase type
+    (named-type
+     (ecase (named-type-name type)
+       ((* t)
+	t)
+       ((nil)
+	nil)
+       (character (characterp object))
+       (base-char (base-char-p object))
+       (standard-char (and (characterp object) (standard-char-p object)))
+       (extended-char
+	(and (characterp object) (not (base-char-p object))))
+       (function (functionp object))
+       (cons (consp object))
+       (symbol (symbolp object))
+       (keyword
+	(and (symbolp object)
+	     (eq (symbol-package object)
+		 (symbol-package :foo))))
+       (system-area-pointer (system-area-pointer-p object))
+       (weak-pointer (weak-pointer-p object))
+       (code-component (code-component-p object))
+       (lra (lra-p object))
+       (fdefn (fdefn-p object))
+       (scavenger-hook (scavenger-hook-p object))
+       (structure (structurep object))))
+    (numeric-type
+     (and (numberp object)
+	  (let ((num (if (complexp object) (realpart object) object)))
+	    (ecase (numeric-type-class type)
+	      (integer (integerp num))
+	      (rational (rationalp num))
+	      (float
+	       (ecase (numeric-type-format type)
+		 (short-float (typep object 'short-float))
+		 (single-float (typep object 'single-float))
+		 (double-float (typep object 'double-float))
+		 (long-float (typep object 'long-float))
+		 ((nil) (floatp num))))
+	      ((nil) t)))
+	  (flet ((bound-test (val)
+			     (let ((low (numeric-type-low type))
+				   (high (numeric-type-high type)))
+			       (and (cond ((null low) t)
+					  ((listp low) (> val (car low)))
+					  (t (>= val low)))
+				    (cond ((null high) t)
+					  ((listp high) (< val (car high)))
+					  (t (<= val high)))))))
+	    (ecase (numeric-type-complexp type)
+	      ((nil) t)
+	      (:complex
+	       (and (complexp object)
+		    (bound-test (realpart object))
+		    (bound-test (imagpart object))))
+	      (:real
+	       (and (not (complexp object))
+		    (bound-test object)))))))
+    (array-type
+     (and (arrayp object)
+	  (ecase (array-type-complexp type)
+	    ((t) (not (typep object 'simple-array)))
+	    ((nil) (typep object 'simple-array))
+	    (* t))
+	  (or (eq (array-type-dimensions type) '*)
+	      (do ((want (array-type-dimensions type) (cdr want))
+		   (got (array-dimensions object) (cdr got)))
+		  ((and (null want) (null got)) t)
+		(unless (and want got
+			     (or (eq (car want) '*)
+				 (= (car want) (car got))))
+		  (return nil))))
+	  (or (eq (array-type-element-type type) *wild-type*)
+	      (type= (array-type-specialized-element-type type)
+		     (specifier-type (array-element-type object))))))
+    (member-type
+     (if (member object (member-type-members type)) t))
+    (structure-type
+     (structure-typep object (structure-type-name type)))
+    (clos-type
+     (pcl::*typep object (clos-type-class type)))
+    (union-type
+     (dolist (type (union-type-types type))
+       (when (%%typep object type)
+	 (return t))))
+    (unknown-type
+     ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
+     ;; a defined structure in the core.
+     (let ((orig-spec (unknown-type-specifier type)))
+       (if (and (symbolp orig-spec)
+		(info type defined-structure-info orig-spec))
+	   (structure-typep object orig-spec)
+	   (error "Unknown type specifier: ~S" orig-spec))))
+    (hairy-type
+     ;; Now the tricky stuff.
+     (let* ((hairy-spec (hairy-type-specifier type))
+	    (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+       (ecase symbol
+	 (and
+	  (or (atom hairy-spec)
+	      (dolist (spec (cdr hairy-spec) t)
+		(unless (%%typep object (specifier-type spec))
+		  (return nil)))))
+	 (not
+	  (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
+	    (error "Invalid type specifier: ~S" hairy-spec))
+	  (not (%%typep object (specifier-type (cadr hairy-spec)))))
+	 (satisfies
+	  (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
+	    (error "Invalid type specifier: ~S" hairy-spec))
+	  (let ((fn (cadr hairy-spec)))
+	    (if (funcall (typecase fn
+			   (function fn)
+			   (symbol (symbol-function fn))
+			   (t
+			    (coerce fn 'function)))
+			 object)
+		t
+		nil))))))
+    (alien-type-type
+     (alien-internals:alien-typep object (alien-type-type-alien-type type)))
+    (function-type
+     (error "Function types are not a legal argument to TYPEP:~%  ~S"
+	    (type-specifier type)))))
+
+(defun %deftype (name expander &optional doc)
+  (ecase (info type kind name)
+    (:primitive
+     (error "Illegal to redefine standard type: ~S." name))
+    (:structure
+     (warn "Redefining structure type ~S with DEFTYPE." name)
+     (c::undefine-structure (info type structure-info name)))
+    (:class
+     (warn "Redefining class ~S with DEFTYPE." name))
+    ((nil :defined)))
+  (setf (info type kind name) :defined)
+  (setf (info type expander name) expander)
+  (when doc
+    (setf (documentation name 'type) doc))
+  ;; ### Bootstrap hack -- we need to define types before %note-type-defined
+  ;; is defined.
+  (when (fboundp 'c::%note-type-defined)
+    (c::%note-type-defined name))
+  name)
+
+(defun type-of (object)
+  "Return the type of OBJECT."
+  (typecase object
+    ;; First the ones that we can tell by testing the lowtag
+    (fixnum 'fixnum)
+    (function (type-specifier (ctype-of object)))
+    (null 'null)
+    (list 'cons)
+
+    ;; Any other immediates.
+    (character
+     (typecase object
+       (standard-char 'standard-char)
+       (base-char 'base-char)
+       (t 'character)))
+
+    ;; And now for the complicated ones.
+    (number
+     (etypecase object
+       (fixnum 'fixnum)
+       (bignum 'bignum)
+       (float
+	(etypecase object
+	  (double-float 'double-float)
+	  (single-float 'single-float)
+	  (short-float 'short-float)
+	  (long-float 'long-float)))
+       (ratio 'ratio)
+       (complex 'complex)))
+    (symbol
+     (if (eq (symbol-package object)
+	     (symbol-package :foo))
+	 'keyword
+	 'symbol))
+    (structure
+     (let ((name (structure-ref object 0)))
+       (case name
+	 (pcl::std-instance
+	  (pcl:class-name (pcl:class-of object)))
+	 (alien-internals:alien-value
+	  `(alien:alien
+	    ,(alien-internals:unparse-alien-type
+	      (alien-internals:alien-value-type object))))
+	 (t name))))
+    (array (type-specifier (ctype-of object)))
+    (system-area-pointer 'system-area-pointer)
+    (weak-pointer 'weak-pointer)
+    (code-component 'code-component)
+    (lra 'lra)
+    (fdefn 'fdefn)
+    (scavenger-hook 'scavenger-hook)
+    (t
+     (warn "Can't figure out the type of ~S" object)
+     t)))
+
+(in-package "PCL")
 
 (pushnew :structure-wrapper *features*)
-(pushnew :structure-functions *features*)
 
-(import 'ext:structurep)
+(defun structure-functions-exist-p ()
+  t)
+
+(defun structure-instance-p (x)
+  (and (structurep x)
+       (not (eq (kernel:structure-ref x 0) 'std-instance))))
 
-(defmacro structure-type (x)
-  `(kernel:structure-ref ,x 0))
+(defun structure-type (x)
+  (kernel:structure-ref x 0))
 
-(defun known-structure-type-p (type)
+(defun structure-type-p (type)
   (not (null (ext:info c::type c::defined-structure-info type))))
 
 (defun structure-type-included-type-name (type)
@@ -142,9 +474,8 @@
 	include)))
 
 (defun structure-type-slot-description-list (type)
-  (nthcdr (length (the list
-                       (let ((include (structure-type-included-type-name type)))
-		         (and include (structure-type-slot-description-list include)))))
+  (nthcdr (length (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)
@@ -160,3 +491,8 @@
   (unless (c::dsd-read-only slotd)
     (fdefinition `(setf ,(c::dsd-accessor slotd)))))
 
+(defun structure-slotd-type (slotd)
+  (c::dsd-type slotd))
+
+(defun structure-slotd-init-form (slotd)
+  (c::dsd-default slotd))
diff --git a/pcl/combin.lisp b/pcl/combin.lisp
index 60215f20b..430905251 100644
--- a/pcl/combin.lisp
+++ b/pcl/combin.lisp
@@ -27,48 +27,82 @@
 
 (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 (assq method method-alist))
-      (if wrappers
-	  (method-function-for-caching method wrappers)
-	  (or (method-optimized-function method)
-              #'null-wrappers-method-function))))
+  (let ((fn (cadr (assoc method method-alist))))
+    (if fn
+	(values fn nil nil nil)
+	(multiple-value-bind (mf fmf)
+	    (if (listp method)
+		(early-method-function method)
+		(values nil (method-fast-function method)))
+	  (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+	    (if (and fmf (or (null pv-table) wrappers))
+		(let* ((pv-wrappers (when pv-table 
+				      (pv-wrappers-from-all-wrappers
+				       pv-table wrappers)))
+		       (pv-cell (when (and pv-table pv-wrappers)
+				  (pv-table-lookup pv-table pv-wrappers))))
+		  (values mf t fmf pv-cell))
+		(values 
+		 (or mf (if (listp method)
+			    (setf (cadr method)
+				  (method-function-from-fast-function fmf))
+			    (method-function method)))
+		 t nil nil)))))))
 
 (defun make-effective-method-function (generic-function form &optional 
 				       method-alist wrappers)
-  (funcall-function (make-effective-method-function1 generic-function form)
-	            method-alist wrappers))
+  (funcall (make-effective-method-function1 generic-function form
+					    (not (null method-alist))
+					    (not (null wrappers)))
+	   method-alist wrappers))
 
-(defun make-effective-method-function1 (generic-function form)
+(defun make-effective-method-function1 (generic-function form 
+					method-alist-p wrappers-p)
   (if (and (listp form)
-	   (eq (car form) 'call-method)
-	   (method-p (cadr form))
-	   (or (every #'method-p (caddr form))
-	       (not (method-needs-next-methods-p (cadr form)))))
+	   (eq (car form) 'call-method))
       (make-effective-method-function-simple generic-function form)
       ;;
       ;; We have some sort of `real' effective method.  Go off and get a
       ;; compiled function for it.  Most of the real hair here is done by
       ;; the GET-FUNCTION mechanism.
       ;; 
-      (make-effective-method-function-internal generic-function form)))
+      (make-effective-method-function-internal generic-function form
+					       method-alist-p wrappers-p)))
+
+(defun make-effective-method-function-type (generic-function form
+					    method-alist-p wrappers-p)
+  (if (and (listp form)
+	   (eq (car form) 'call-method))
+      (let* ((cm-args (cdr form))
+	     (method (car cm-args)))
+	(when method
+	  (if (if (listp method)
+		  (eq (car method) ':early-method)
+		  (method-p method))
+	      (if method-alist-p
+		  't
+		  (multiple-value-bind (mf fmf)
+		      (if (listp method)
+			  (early-method-function method)
+			  (values nil (method-fast-function method)))
+		    (declare (ignore mf))
+		    (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+		      (if (and fmf (or (null pv-table) wrappers-p))
+			  'fast-method-call
+			  'method-call))))
+	      (if (and (consp method) (eq (car method) 'make-method))
+		  (make-effective-method-function-type 
+		   generic-function (cadr method) method-alist-p wrappers-p)
+		  (type-of method)))))
+      'fast-method-call))
 
-(defun make-effective-method-function-simple (generic-function form)
+(defun make-effective-method-function-simple (generic-function form
+							       &optional no-fmf-p)
   ;;
   ;; The effective method is just a call to call-method.  This opens up
   ;; the possibility of just using the method function of the method as
-  ;; as the effective method function.
+  ;; the effective method function.
   ;;
   ;; But we have to be careful.  If that method function will ask for
   ;; the next methods we have to provide them.  We do not look to see
@@ -76,48 +110,47 @@
   ;; asks about them.  If it does, we must tell it whether there are
   ;; or aren't to prevent the leaky next methods bug.
   ;; 
-  (let ((method (cadr form)))
-    (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)
-		  (let ((*next-methods* .next-methods.))
-		    ,(make-dfun-call metatypes applyp '.method.)))
-	       #'default-test-converter ;This could be optimized by making
-					;the interface from here to the
-					;walker more clear so that the
-					;form wouldn't get walked at all.
-	       #'(lambda (form)
-		   (if (memq form '(.next-methods. .method.))
-		       (values form (list form))
-		       form))
-	       #'(lambda (form)
-		   (cond ((eq form '.next-methods.)
-			  (list (cons '.meth-list. next-methods)))
-			 ((eq form '.method.)
-			  (list (cons '.meth. method))))))
-	    #'(lambda (method-alist wrappers)
-		(flet ((fix-meth (meth)
-			 (get-method-function meth method-alist wrappers)))
-		  (apply-function cfunction
-				  (mapcar #'(lambda (constant)
-					      (cond ((atom constant)
-						     constant)
-						    ((eq (car constant) '.meth.)
-						     (fix-meth (cdr constant)))
-						    ((eq (car constant) '.meth-list.)
-						     (mapcar #'fix-meth (cdr constant)))
-						    (t constant)))
-					  constants)))))))))
+  (let* ((cm-args (cdr form))
+	 (fmf-p (and (null no-fmf-p)
+		     (or (not (eq *boot-state* 'complete))
+			 (gf-fast-method-function-p generic-function))
+		     (null (cddr cm-args))))
+	 (method (car cm-args))
+	 (cm-args1 (cdr cm-args)))
+    #'(lambda (method-alist wrappers)
+	(make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
+						method-alist wrappers))))
+
+(defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers)
+  (multiple-value-bind (mf real-mf-p fmf pv-cell)
+      (get-method-function method method-alist wrappers)
+    (if fmf
+	(let* ((next-methods (car cm-args))
+	       (next (make-effective-method-function-simple1
+		      gf (car next-methods)
+		      (list* (cdr next-methods) (cdr cm-args))
+		      fmf-p method-alist wrappers))
+	       (arg-info (method-function-get fmf ':arg-info)))
+	  (make-fast-method-call :function fmf
+				 :pv-cell pv-cell
+				 :next-method-call next
+				 :arg-info arg-info))
+	(if real-mf-p
+	    (make-method-call :function mf
+			      :call-method-args cm-args)
+	    mf))))
+
+(defun make-effective-method-function-simple1 (gf method cm-args fmf-p
+						  &optional method-alist wrappers)
+  (when method
+    (if (if (listp method)
+	    (eq (car method) ':early-method)
+	    (method-p method))
+	(make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
+	(if (and (consp method) (eq (car method) 'make-method))
+	    (make-effective-method-function gf (cadr method) method-alist wrappers)
+	    method))))
 
-(declaim (type list *global-effective-method-gensyms*))
 (defvar *global-effective-method-gensyms* ())
 (defvar *rebound-effective-method-gensyms*)
 
@@ -133,75 +166,190 @@
 (let ((*rebound-effective-method-gensyms* ()))
   (dotimes (i 10) (get-effective-method-gensym)))
 
-(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)
-		       '.call-method-with-next.
-		       '.call-method-without-next.)
-		   (default-test-converter form)))
-	     (code-converter (form)
-	       (if (and (consp form) (eq (car form) 'call-method))
-		   ;;
-		   ;; We have a `call' to CALL-METHOD.  There may or may not be next
-		   ;; methods and the two cases are a little different.  It controls
-		   ;; how many gensyms we will generate.
-		   ;;
-		   (let ((gensyms
-			  (if (caddr form)
-			      (list (get-effective-method-gensym)
-				    (get-effective-method-gensym))
-			      (list (get-effective-method-gensym)))))
-		     (values `(let ((*next-methods* ,(cadr gensyms)))
-			       ,(make-dfun-call metatypes applyp (car gensyms)))
-			     gensyms))
-		   (default-code-converter form)))
-	     (constant-converter (form)
-	       (if (and (consp form) (eq (car form) 'call-method))
-		   (if (caddr form)
-		       (list (cons '.meth. (check-for-make-method (cadr form)))
-			     (cons '.meth-list.
-				   (mapcar #'check-for-make-method (caddr form))))
-		       (list (cons '.meth. (check-for-make-method (cadr form)))))
-		   (default-constant-converter form)))
-	     (check-for-make-method (effective-method)
-	       (cond ((method-p effective-method)
-		      effective-method)
-		     ((and (listp effective-method)
-			   (eq (car effective-method) 'make-method))
-		      (make-effective-method-function1
-		       generic-function
-		       (make-progn (cadr effective-method))))
-		     (t
-		      (error "Effective-method form is malformed.")))))
+(defun expand-effective-method-function (gf effective-method &optional env)
+  (declare (ignore env))
+  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+      (get-generic-function-info gf)
+    (declare (ignore nreq nkeys arg-info))
+    `(lambda ,(make-fast-method-call-lambda-list metatypes applyp)
+       (declare (ignore .pv-cell. .next-method-call.))
+       ,effective-method)))
+
+(defun expand-emf-call-method (gf form metatypes applyp env)
+  (declare (ignore gf metatypes applyp env))
+  `(call-method ,(cdr form)))
+
+(defmacro call-method (&rest args)
+  (declare (ignore args))
+  `(error "~S outsize of a effective method form" 'call-method))
+
+(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
+  (cond ((and (consp form) (eq (car form) 'call-method))
+	 (case (make-effective-method-function-type 
+		generic-function form method-alist-p wrappers-p)
+	   (fast-method-call
+	    '.fast-call-method.)
+	   (t
+	    '.call-method.)))
+	((and (consp form) (eq (car form) 'call-method-list))
+	 (case (if (every #'(lambda (form)
+			      (eq 'fast-method-call
+				  (make-effective-method-function-type 
+				   generic-function form 
+				   method-alist-p wrappers-p)))
+			  (cdr form))
+		   'fast-method-call
+		   't)
+	   (fast-method-call
+	    '.fast-call-method-list.)
+	   (t
+	    '.call-method-list.)))
+	(t
+	 (default-test-converter form))))
+
+(defun memf-code-converter (form generic-function 
+				 metatypes applyp method-alist-p wrappers-p)
+  (cond ((and (consp form) (eq (car form) 'call-method))
+	 (let ((gensym (get-effective-method-gensym)))
+	   (values (make-emf-call metatypes applyp gensym
+				  (make-effective-method-function-type 
+				   generic-function form method-alist-p wrappers-p))
+		   (list gensym))))
+	((and (consp form) (eq (car form) 'call-method-list))
+	 (let ((gensym (get-effective-method-gensym))
+	       (type (if (every #'(lambda (form)
+				    (eq 'fast-method-call
+					(make-effective-method-function-type 
+					 generic-function form 
+					 method-alist-p wrappers-p)))
+				(cdr form))
+			 'fast-method-call
+			 't)))
+	   (values `(dolist (emf ,gensym nil)
+		      ,(make-emf-call metatypes applyp 'emf type))
+		   (list gensym))))		     
+	(t
+	 (default-code-converter form))))
+
+(defun memf-constant-converter (form generic-function)
+  (cond ((and (consp form) (eq (car form) 'call-method))
+	 (list (cons '.meth.
+		     (make-effective-method-function-simple
+		      generic-function form))))
+	((and (consp form) (eq (car form) 'call-method-list))
+	 (list (cons '.meth-list.
+		     (mapcar #'(lambda (form)
+				 (make-effective-method-function-simple
+				  generic-function form))
+			     (cdr form)))))
+	(t
+	 (default-constant-converter form))))
+
+(defun make-effective-method-function-internal (generic-function effective-method
+					        method-alist-p wrappers-p)
+  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+      (get-generic-function-info generic-function)
+    (declare (ignore nkeys arg-info))
+    (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
+	   (name (if (early-gf-p generic-function)
+		     (early-gf-name generic-function)
+		     (generic-function-name generic-function)))
+	   (arg-info (cons nreq applyp))
+	   (effective-method-lambda (expand-effective-method-function
+				     generic-function effective-method)))
       (multiple-value-bind (cfunction constants)
-	  (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp)
-			   ,effective-method)
-			 #'test-converter
-			 #'code-converter
-			 #'constant-converter)
+	  (get-function1 effective-method-lambda
+			 #'(lambda (form)
+			     (memf-test-converter form generic-function
+						  method-alist-p wrappers-p))
+			 #'(lambda (form)
+			     (memf-code-converter form generic-function
+						  metatypes applyp
+						  method-alist-p wrappers-p))
+			 #'(lambda (form)
+			     (memf-constant-converter form generic-function)))
 	#'(lambda (method-alist wrappers)
-	    (flet ((fix-meth (meth)
-		     (if (method-p meth)
-			 (get-method-function meth method-alist wrappers)
-			 (funcall-function meth method-alist wrappers))))
-	      (apply-function cfunction
-			      (mapcar #'(lambda (constant)
-					  (cond ((atom constant)
-						 constant)
-						((eq (car constant) '.meth.)
-						 (fix-meth (cdr constant)))
-						((eq (car constant) '.meth-list.)
-						 (mapcar #'fix-meth (cdr constant)))
-						(t constant)))
-				      constants))))))))
+	    (let* ((constants 
+		    (mapcar #'(lambda (constant)
+				(if (consp constant)
+				    (case (car constant)
+				      (.meth.
+				       (funcall (cdr constant)
+						method-alist wrappers))
+				      (.meth-list.
+				       (mapcar #'(lambda (fn)
+						   (funcall fn method-alist wrappers))
+					       (cdr constant)))
+				      (t constant))
+				    constant))
+			    constants))
+		   (function (set-function-name
+			      (apply cfunction constants)
+			      `(combined-method ,name))))
+	      (make-fast-method-call :function function
+				     :arg-info arg-info)))))))
+
+(defmacro call-method-list (&rest calls)
+  `(progn ,@calls))
+
+(defun make-call-methods (methods)
+  `(call-method-list
+    ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
+
+(defun standard-compute-effective-method (generic-function combin applicable-methods)
+  (declare (ignore combin))
+  (let ((before ())
+	(primary ())
+	(after ())
+	(around ()))
+    (dolist (m applicable-methods)
+      (let ((qualifiers (if (listp m)
+			    (early-method-qualifiers m)
+			    (method-qualifiers m))))			    
+	(cond ((member ':before qualifiers)  (push m before))
+	      ((member ':after  qualifiers)  (push m after))
+	      ((member ':around  qualifiers) (push m around))
+	      (t
+	       (push m primary)))))
+    (setq before  (reverse before)
+	  after   (reverse after)
+	  primary (reverse primary)
+	  around  (reverse around))
+    (cond ((null primary)
+	   `(error "No primary method for the generic function ~S." ',generic-function))
+	  ((and (null before) (null after) (null around))
+	   ;;
+	   ;; By returning a single call-method `form' here we enable an important
+	   ;; implementation-specific optimization.
+	   ;; 
+	   `(call-method ,(first primary) ,(rest primary)))
+	  (t
+	   (let ((main-effective-method
+		   (if (or before after)
+		       `(multiple-value-prog1
+			  (progn ,(make-call-methods before)
+				 (call-method ,(first primary) ,(rest primary)))
+			  ,(make-call-methods (reverse after)))
+		       `(call-method ,(first primary) ,(rest primary)))))
+	     (if around
+		 `(call-method ,(first around)
+			       (,@(rest around) (make-method ,main-effective-method)))
+		 main-effective-method))))))
+
+;;;
+;;; The STANDARD method combination type.  This is coded by hand (rather than
+;;; with define-method-combination) for bootstrapping and efficiency reasons.
+;;; Note that the definition of the find-method-combination-method appears in
+;;; the file defcombin.lisp, this is because EQL methods can't appear in the
+;;; bootstrap.
+;;;
+;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
+;;; classes has to appear here for this reason.  This code must conform to
+;;; the code in the file defcombin, look there for more details.
+;;;
 
-
+(defun compute-effective-method (generic-function combin applicable-methods)
+  (standard-compute-effective-method generic-function combin applicable-methods))
 
 (defvar *invalid-method-error*
 	#'(lambda (&rest args)
@@ -243,52 +391,6 @@
   (declare (arglist format-string &rest format-arguments))
   (apply *method-combination-error* args))
 
-
-
-;;;
-;;; The STANDARD method combination type.  This is coded by hand (rather than
-;;; with define-method-combination) for bootstrapping and efficiency reasons.
-;;; Note that the definition of the find-method-combination-method appears in
-;;; the file defcombin.lisp, this is because EQL methods can't appear in the
-;;; bootstrap.
-;;;
-;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
-;;; classes has to appear here for this reason.  This code must conform to
-;;; the code in the file defcombin, look there for more details.
-;;;
-
-(defclass method-combination (metaobject) ()
-  (:predicate-name method-combination-p))
-
-
-(mapc
- #'proclaim-incompatible-superclasses
- '(;; superclass metaobject
-   (class eql-specializer class-eq-specializer method method-combination
-    generic-function slot-definition)
-   ))
-
-(defclass standard-method-combination
-	  (documentation-mixin definition-source-mixin method-combination)
-     ((type          :reader method-combination-type
-	             :initarg :type)
-      (options       :reader method-combination-options
-	             :initarg :options)))
-
-(defmethod print-object ((mc method-combination) stream)
-  (printing-random-thing (mc stream)
-    (format stream
-	    "Method-Combination ~S ~S"
-	    (method-combination-type mc)
-	    (method-combination-options mc))))
-
-(eval-when (load eval)
-  (setq *standard-method-combination*
-	(make-instance 'standard-method-combination
-		       :type 'standard
-		       :documentation "The standard method combination."
-		       :options ())))
-
 ;This definition appears in defcombin.lisp.
 ;
 ;(defmethod find-method-combination ((generic-function generic-function)
@@ -299,45 +401,3 @@
 ;      "The method combination type STANDARD accepts no options."))
 ;  *standard-method-combination*)
 
-(defun make-call-methods (methods)
-  (mapcar #'(lambda (method) `(call-method ,method ())) methods))
-
-(defmethod compute-effective-method ((generic-function generic-function)
-				     (combin standard-method-combination)
-				     applicable-methods)
-  (let ((before ())
-	(primary ())
-	(after ())
-	(around ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (method-qualifiers m)))
-	(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)
-	  after   (reverse after)
-	  primary (reverse primary)
-	  around  (reverse around))
-    (cond ((null primary)
-	   `(error "No primary method for the generic function ~S." ',generic-function))
-	  ((and (null before) (null after) (null around))
-	   ;;
-	   ;; By returning a single call-method `form' here we enable an important
-	   ;; implementation-specific optimization.
-	   ;; 
-	   `(call-method ,(first primary) ,(rest primary)))
-	  (t
-	   (let ((main-effective-method
-		   (if (or before after)
-		       `(multiple-value-prog1
-			  (progn ,@(make-call-methods before)
-				 (call-method ,(first primary) ,(rest primary)))
-			  ,@(make-call-methods (reverse after)))
-		       `(call-method ,(first primary) ,(rest primary)))))
-	     (if around
-		 `(call-method ,(first around)
-			       (,@(rest around) (make-method ,main-effective-method)))
-		 main-effective-method))))))
-
diff --git a/pcl/construct.lisp b/pcl/construct.lisp
index edbbc238a..197b7e9f1 100644
--- a/pcl/construct.lisp
+++ b/pcl/construct.lisp
@@ -229,8 +229,8 @@
     (format stream
 	    "~S ~S (~S)"
 	    (or (class-name (class-of constructor)) "Constructor")
-	    (or (constructor-name constructor) "Anonymous")
-	    (constructor-code-type constructor))))
+	    (or (slot-value-or-default constructor 'name) "Anonymous")
+	    (slot-value-or-default constructor 'code-type))))
 
 (defmethod describe-object ((constructor constructor) stream)
   (format stream
@@ -421,18 +421,21 @@
 	 (wrapper (class-wrapper class))
 	 (defaults (class-default-initargs class))
          (make
-           (compute-applicable-methods #'make-instance (list class)))
+           (compute-applicable-methods (gdefinition '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 (gdefinition 'default-initargs)
+				       (list class supplied-initarg-names))) ;?
          (allocate
-           (compute-applicable-methods #'allocate-instance (list class)))
+           (compute-applicable-methods (gdefinition 'allocate-instance)
+				       (list class)))
          (initialize
-           (compute-applicable-methods #'initialize-instance (list proto)))
+           (compute-applicable-methods (gdefinition 'initialize-instance)
+				       (list proto)))
          (shared
-           (compute-applicable-methods #'shared-initialize (list proto t)))
+           (compute-applicable-methods (gdefinition 'shared-initialize)
+				       (list proto t)))
 	 (code-generators
 	   (constructor-code-generators constructor)))
     (flet ((call-code-generator (generator)
@@ -441,12 +444,12 @@
 		 (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
-			      defaults
-			      (append initialize shared)))
+	      (not (check-initargs-1 class
+				     supplied-initarg-names
+				     (append initialize shared)
+				     nil nil)))
 	  ;; These are basic shared assumptions, if one of the
 	  ;; has been violated, we have to resort to the fallback
 	  ;; case.  Any of these assumptions could be moved out
@@ -465,10 +468,8 @@
 ;;; 
 
 (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))
@@ -535,36 +536,9 @@
 			      (equal '(:after) (method-qualifiers m))))
 	    methods))
 
-
-;;; 
-;;; if initargs are valid return nil, otherwise return t.
-;;;
-(defun check-initargs (class supplied-initarg-names defaults methods)
-  (let ((legal (apply #'append
-		      (mapcar #'slot-definition-initargs (class-slots class)))))
-    ;; Add to the set of slot-filling initargs the set of
-    ;; initargs that are accepted by the methods.  If at
-    ;; any point we come across &allow-other-keys, we can
-    ;; just quit.
-    (dolist (method methods)
-      (multiple-value-bind (keys allow-other-keys)
-	  (function-keywords method)
-	(when allow-other-keys
-	  (return-from check-initargs nil))
-	(setq legal (append keys legal))))
-    ;; Now check the supplied-initarg-names and the default initargs
-    ;; against the total set that we know are legal.
-    (dolist (key supplied-initarg-names)
-      (unless (memq key legal)
-	(return-from check-initargs t)))
-    (dolist (default defaults)
-      (unless (memq (car default) legal)
-	(return-from check-initargs t)))))
-
-
 ;;;
 ;;; This returns two values.  The first is a vector which can be used as the
-;;; initial value of the slots vector for the instance. The first is a symbol
+;;; initial value of the slots vector for the instance. The second is a symbol
 ;;; describing the initforms this class has.  
 ;;;
 ;;;  If the first value is:
@@ -575,12 +549,11 @@
 ;;;    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))
@@ -594,16 +567,11 @@
 	      (t
 	       (push (cons name *slot-unbound*) constants)
 	       (setq flag 't)))))
-    (values
-      (apply #'vector
-	     (mapcar #'cdr
-		     (sort constants #'(lambda (x y)
-					 (memq (car y)
-					       (memq (car x) layout))))))
-      flag)))
-
-(defmacro copy-constant-vector (constants)
-  `(copy-seq (the simple-vector ,constants)))
+    (let* ((constants-alist (sort constants #'(lambda (x y)
+						(memq (car y)
+						      (memq (car x) layout)))))
+	   (constants-list (mapcar #'cdr constants-alist)))
+    (values constants-list flag))))
 
 
 ;;;
@@ -627,7 +595,6 @@
 			     (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)
@@ -680,8 +647,7 @@
         (class name arglist supplied-initarg-names supplied-initargs)
   (declare (ignore name))
   (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class))
-	(wrapper-fetcher (wrapper-fetcher class)))
+	(slots-fetcher (slots-fetcher class)))
     `(function
        (lambda (class .wrapper. defaults init shared)
 	 (multiple-value-bind (.constants.
@@ -705,15 +671,12 @@
 	     (function
 	       (lambda ,arglist
 		 (declare #.*optimize-speed*)
-		 (let ((.instance. (,raw-allocator))
-		       (.slots. (copy-constant-vector .constants.))
-		       (.positions. .supplied-initarg-positions.)
-		       (.initargs. .constant-initargs.))		   
+		 (let* ((.instance. (,raw-allocator .wrapper. .constants.))
+			(.slots. (,slots-fetcher .instance.))
+			(.positions. .supplied-initarg-positions.)
+			(.initargs. .constant-initargs.))		   
 		   .positions.
 		   
-		   (setf (,slots-fetcher .instance.) .slots.)	     
-		   (setf (,wrapper-fetcher .instance.) .wrapper.)
-
 		   (dolist (entry .initfns-initargs-and-positions.)
 		     (let ((val (funcall (car entry)))
 			   (initarg (cadr entry)))
@@ -721,7 +684,7 @@
 			 (push val .initargs.)
 			 (push initarg .initargs.))
 		       (dolist (pos (cddr entry))
-			 (setf (%svref .slots. pos) val))))
+			 (setf (%instance-ref .slots. pos) val))))
 
 		   ,@(gathering1 (collecting)
 		       (doplist (initarg value) supplied-initargs
@@ -730,7 +693,7 @@
 				       (push .value. .initargs.)
 				       (push ',initarg .initargs.)
 				       (dolist (.p. (pop .positions.))
-					 (setf (%svref .slots. .p.)
+					 (setf (%instance-ref .slots. .p.)
 					       .value.)))))))
 
 		   (dolist (fn .shared-initfns.)
@@ -753,7 +716,6 @@
 	   (supplied-initarg-positions ())
 	   (constant-initargs ())
 	   (used-positions ()))
-      (declare (list layout))
 					       
       ;;
       ;; Go through each of the supplied initargs for three reasons.
@@ -852,8 +814,7 @@
         (class name arglist supplied-initarg-names supplied-initargs)
   (declare (ignore name))
   (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class))
-	(wrapper-fetcher (wrapper-fetcher class)))
+	(slots-fetcher (slots-fetcher class)))
     `(function
        (lambda (class .wrapper. defaults init shared)
 	 (multiple-value-bind (.constants.
@@ -870,17 +831,15 @@
 		      (null (non-pcl-shared-initialize-methods-p shared)))
 	     #'(lambda ,arglist
 		 (declare #.*optimize-speed*)
-		 (let ((.instance. (,raw-allocator))
-		       (.slots. (copy-constant-vector .constants.))
-		       (.positions. .supplied-initarg-positions.))
+		 (let* ((.instance. (,raw-allocator .wrapper. .constants.))
+			(.slots. (,slots-fetcher .instance.))
+			(.positions. .supplied-initarg-positions.))
 		   .positions.
-		   (setf (,slots-fetcher .instance.) .slots.)
-		   (setf (,wrapper-fetcher .instance.) .wrapper.)
 
 		   (dolist (entry .initfns-and-positions.)
 		     (let ((val (funcall (car entry))))
 		       (dolist (pos (cdr entry))
-			 (setf (%svref .slots. pos) val))))
+			 (setf (%instance-ref .slots. pos) val))))
 		 
 		   ,@(gathering1 (collecting)
 		       (doplist (initarg value) supplied-initargs
@@ -888,7 +847,7 @@
 			   (gather1
 			     `(let ((.value. ,value))
 				(dolist (.p. (pop .positions.))
-				  (setf (%svref .slots. .p.) .value.)))))))
+				  (setf (%instance-ref .slots. .p.) .value.)))))))
 		     
 		   .instance.))))))))
 
@@ -904,7 +863,6 @@
 	   (initfns-and-positions ())
 	   (supplied-initarg-positions ())
 	   (used-positions ()))
-      (declare (list layout))
       ;;
       ;; Go through each of the supplied initargs for three reasons.
       ;;
@@ -993,8 +951,7 @@
         (class name arglist supplied-initarg-names supplied-initargs)
   (declare (ignore name))
   (let ((raw-allocator (raw-instance-allocator class))
-	(slots-fetcher (slots-fetcher class))
-	(wrapper-fetcher (wrapper-fetcher class)))
+	(slots-fetcher (slots-fetcher class)))
     `(function
        (lambda (class .wrapper. defaults init shared)
 	 (when (and (null (non-pcl-initialize-instance-methods-p init))
@@ -1008,13 +965,10 @@
 	       (function
 		 (lambda ,arglist
 		   (declare #.*optimize-speed*)
-		   (let ((.instance. (,raw-allocator))
-			 (.slots. (copy-constant-vector .constants.))
-			 (.positions. .supplied-initarg-positions.))
-		     
+		   (let* ((.instance. (,raw-allocator .wrapper. .constants.))
+			  (.slots. (,slots-fetcher .instance.))
+			  (.positions. .supplied-initarg-positions.))
 		     .positions.
-		     (setf (,slots-fetcher .instance.) .slots.)	     
-		     (setf (,wrapper-fetcher .instance.) .wrapper.)
 		 
 		     ,@(gathering1 (collecting)
 			 (doplist (initarg value) supplied-initargs
@@ -1022,7 +976,7 @@
 			     (gather1
 			       `(let ((.value. ,value))
 				  (dolist (.p. (pop .positions.))
-				    (setf (%svref .slots. .p.) .value.)))))))
+				    (setf (%instance-ref .slots. .p.) .value.)))))))
 		     
 		     .instance.))))))))))
 
@@ -1037,7 +991,6 @@
 						(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 0cde7bfcf..23641de54 100644
--- a/pcl/cpatch.lisp
+++ b/pcl/cpatch.lisp
@@ -5,11 +5,6 @@
 ;; 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 6947fca9a..ff05e951e 100644
--- a/pcl/cpl.lisp
+++ b/pcl/cpl.lisp
@@ -95,7 +95,7 @@
   (cpd-class  nil)
   (cpd-supers ())
   (cpd-after  ())
-  (cpd-count  0 :type fixnum))
+  (cpd-count  0))
 
 (defun compute-std-cpl (class supers)
   (cond ((null supers)				;First two branches of COND
@@ -112,13 +112,12 @@
 
 (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 (type index nclasses))
+    (declare (fixnum nclasses))
     (labels ((get-cpd (c)
 	       (or (gethash c table)
 		   (setf (gethash c table) (make-cpd))))
@@ -150,7 +149,6 @@
 	  (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 ()))
@@ -197,7 +195,7 @@
       (decf nclasses)
       (push (cpd-class next-cpd) rcpl)
       (dolist (after (cpd-after next-cpd))
-	(when (zerop (the fixnum (decf (cpd-count after))))
+	(when (zerop (decf (cpd-count after)))
 	  (push after candidates))))))
 
 ;;;
diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp
index aee35dec1..e5ded1bda 100644
--- a/pcl/defclass.lisp
+++ b/pcl/defclass.lisp
@@ -159,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)
-                   *defclass-times*
+                   (if defstruct-p '(load eval) *defclass-times*)
 		   `(progn
 		      ,@(mapcar #'(lambda (x)
-                                    `(proclaim-defgeneric ',x '(self)))
-				*readers*)
+				    `(declaim (ftype (function (t) t) ,x)))
+				#+cmu *readers* #-cmu nil)
 		      ,@(mapcar #'(lambda (x)
 				    #-setf (when (consp x)
 					     (setq x (get-setf-function-name (cadr x))))
-                                    `(proclaim-defgeneric ',x '(new self)))
-				*writers*)
+				    `(declaim (ftype (function (t t) t) ,x)))
+				#+cmu *writers* #-cmu nil)
 		      (let ,(mapcar #'cdr *initfunctions*)
 			(load-defclass ',name
 				       ',metaclass
@@ -195,10 +195,17 @@
 							'(:from-defclass-p t))
 						      other-initargs))
 				       ',*accessors*))))))
-          defclass-form)))))
-
-(defun float-zero ()
-  0.0)
+          (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)))))))
 
 (defun make-initfunction (initform)
   (declare (special *initfunctions*))
@@ -211,17 +218,12 @@
 	((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)
-                         `(slot-initfunction-storage-form
-                            (function (lambda () ,initform)))))
+	     (setq entry (list initform
+			       (gensym)
+			       `(function (lambda () ,initform))))
 	     (push entry *initfunctions*))
 	   (cadr entry)))))
 
@@ -267,10 +269,8 @@
 			',spec))
 	   (if (eq initform unsupplied)
 	       `(list* ,@spec)
-	       `(list* :initfunction ,(make-initfunction initform)
-                       :initfunction-side-effect-free-p ,(simple-eval-access-p initform)
-                       ,@spec))))))
-
+	       `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
+						
 (defun canonicalize-defclass-option (class-name option)  
   (declare (ignore class-name))
   (case (car option)
@@ -282,8 +282,6 @@
 		      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)))))
 
@@ -299,9 +297,12 @@
 ;;; Each entry in *early-class-definitions* is an early-class-definition.
 ;;; 
 ;;;
-(declaim (type list *early-class-definitions*))
 (defparameter *early-class-definitions* ())
 
+(defun early-class-definition (class-name)
+  (or (find class-name *early-class-definitions* :key #'ecd-class-name)
+      (error "~S is not a class in *early-class-definitions*." class-name)))
+
 (defun make-early-class-definition
        (name source metaclass
 	superclass-names canonical-slots other-initargs)
@@ -316,6 +317,125 @@
 (defun ecd-canonical-slots   (ecd) (nth 5 ecd))
 (defun ecd-other-initargs    (ecd) (nth 6 ecd))
 
+(defvar *early-class-slots* nil)
+
+(defun canonical-slot-name (canonical-slot)
+  (getf canonical-slot :name))
+
+(defun early-class-slots (class-name)
+  (cdr (or (assoc class-name *early-class-slots*)
+	   (let ((a (cons class-name
+			  (mapcar #'canonical-slot-name
+				  (early-collect-inheritance class-name)))))
+	     (push a *early-class-slots*)
+	     a))))
+
+(defun early-class-size (class-name)
+  (length (early-class-slots class-name)))
+
+(defun early-collect-inheritance (class-name)
+  ;;(declare (values slots cpl default-initargs direct-subclasses))
+  (let ((cpl (early-collect-cpl class-name)))
+    (values (early-collect-slots cpl)
+	    cpl
+	    (early-collect-default-initargs cpl)
+	    (gathering1 (collecting)
+	      (dolist (definition *early-class-definitions*)
+		(when (memq class-name (ecd-superclass-names definition))
+		  (gather1 (ecd-class-name definition))))))))
+
+(defun early-collect-slots (cpl)
+  (let* ((definitions (mapcar #'early-class-definition cpl))
+	 (super-slots (mapcar #'ecd-canonical-slots definitions))
+	 (slots (apply #'append (reverse super-slots))))
+    (dolist (s1 slots)
+      (let ((name1 (canonical-slot-name s1)))
+	(dolist (s2 (cdr (memq s1 slots)))
+	  (when (eq name1 (canonical-slot-name s2))
+	    (error "More than one early class defines a slot with the~%~
+                    name ~S.  This can't work because the bootstrap~%~
+                    object system doesn't know how to compute effective~%~
+                    slots."
+		   name1)))))
+    slots))
+
+(defun early-collect-cpl (class-name)
+  (labels ((walk (c)
+	     (let* ((definition (early-class-definition c))
+		    (supers (ecd-superclass-names definition)))
+	       (cons c
+		     (apply #'append (mapcar #'early-collect-cpl supers))))))
+    (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
+
+(defun early-collect-default-initargs (cpl)
+  (let ((default-initargs ()))
+    (dolist (class-name cpl)
+      (let* ((definition (early-class-definition class-name))
+	     (others (ecd-other-initargs definition)))
+	(loop (when (null others) (return nil))
+	      (let ((initarg (pop others)))
+		(unless (eq initarg :direct-default-initargs)
+		 (error "The defclass option ~S is not supported by the bootstrap~%~
+                        object system."
+			initarg)))
+	      (setq default-initargs
+		    (nconc default-initargs (reverse (pop others)))))))
+    (reverse default-initargs)))
+
+(defun bootstrap-slot-index (class-name slot-name)
+  (or (position slot-name (early-class-slots class-name))
+      (error "~S not found" slot-name)))
+
+;;;
+;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
+;;; the values of slots during bootstrapping.  During bootstrapping, there
+;;; are only two kinds of objects whose slots we need to access, CLASSes
+;;; and SLOT-DEFINITIONs.  The first argument to these functions tells whether the
+;;; object is a CLASS or a SLOT-DEFINITION.
+;;;
+;;; Note that the way this works it stores the slot in the same place in
+;;; memory that the full object system will expect to find it later.  This
+;;; is critical to the bootstrapping process, the whole changeover to the
+;;; full object system is predicated on this.
+;;;
+;;; One important point is that the layout of standard classes and standard
+;;; slots must be computed the same way in this file as it is by the full
+;;; object system later.
+;;; 
+(defmacro bootstrap-get-slot (type object slot-name)
+  `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name)))
+
+(defun bootstrap-set-slot (type object slot-name new-value)
+  (setf (bootstrap-get-slot type object slot-name) new-value))
+
+(defun early-class-name (class)
+  (bootstrap-get-slot 'class class 'name))
+
+(defun early-class-precedence-list (class)
+  (bootstrap-get-slot 'pcl-class class 'class-precedence-list))
+
+(defun early-class-name-of (instance)
+  (early-class-name (class-of instance)))
+
+(defun early-class-slotds (class)
+  (bootstrap-get-slot 'slot-class class 'slots))
+
+(defun early-slot-definition-name (slotd)
+  (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
+
+(defun early-slot-definition-location (slotd)
+  (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
+
+(defun early-accessor-method-slot-name (method)
+  (bootstrap-get-slot 'standard-accessor-method method 'slot-name))
+
+(unless (fboundp 'class-name-of)
+  (setf (symbol-function 'class-name-of)
+	(symbol-function 'early-class-name-of)))
+  
+(defun early-class-direct-subclasses (class)
+  (bootstrap-get-slot 'class class 'direct-subclasses))
+
 (proclaim '(notinline load-defclass))
 (defun load-defclass
        (name metaclass supers canonical-slots canonical-options accessor-names)
@@ -331,241 +451,10 @@
 				       metaclass
 				       supers
 				       canonical-slots
-				       (apply #'append canonical-options)))
+				       canonical-options))
 	(existing
 	  (find name *early-class-definitions* :key #'ecd-class-name)))
     (setq *early-class-definitions*
 	  (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 2e60df97e..7d1434526 100644
--- a/pcl/defcombin.lisp
+++ b/pcl/defcombin.lisp
@@ -107,19 +107,10 @@
 	    :qualifiers ()
 	    :specializers specializers
 	    :lambda-list '(generic-function type options)
-            :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))
+	    :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))
@@ -231,23 +222,12 @@
 	     :qualifiers ()
 	     :specializers specializers
 	     :lambda-list '(generic-function type 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))
+	     :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)
@@ -257,18 +237,18 @@
 (defmethod compute-effective-method ((generic-function generic-function)
 				     (combin long-method-combination)
 				     applicable-methods)
-  (method-function-funcall (gethash (method-combination-type combin)
-		                    *long-method-combination-functions*)
-	                   generic-function
-	                   combin
-	                   applicable-methods))
+  (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)
@@ -350,7 +330,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 692acdfee..d5489f1b9 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -38,6 +38,8 @@
 						;EARLY
 						;BRAID
 						;COMPLETE
+(defvar *fegf-started-p* nil)
+
 
 )
 
@@ -99,7 +101,15 @@
 	      (symbol-function symbol))
   #+xerox (il:virginfn symbol)
   #+setf (fdefinition symbol)
-  #-(or Lispm Lucid excl Xerox setf) (symbol-function symbol))
+  #+kcl (symbol-function
+	  (let ((sym (get symbol 'si::traced)) first-form)
+	    (if (and sym
+		     (consp (symbol-function symbol))
+		     (consp (setq first-form (nth 3 (symbol-function symbol))))
+		     (eq (car first-form) 'si::trace-call))
+		sym
+		symbol)))
+  #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))
 
 ;;;
 ;;; If symbol names a function which is traced or advised, redefine
@@ -121,7 +131,16 @@
             (when brokenp (xcl:rebreak-function symbol))
             (when advisedp (xcl:readvise-function symbol)))
   #+setf (setf (fdefinition symbol) new-definition)
-  #-(or Lispm Lucid excl Xerox setf)
+  #+kcl (setf (symbol-function 
+	       (let ((sym (get symbol 'si::traced)) first-form)
+		 (if (and sym
+			  (consp (symbol-function symbol))
+			  (consp (setq first-form (nth 3 (symbol-function symbol))))
+			  (eq (car first-form) 'si::trace-call))
+		     sym
+		     symbol)))
+	      new-definition)  
+  #-(or Lispm Lucid excl Xerox setf kcl)
   (setf (symbol-function symbol) new-definition)
   
   new-definition)
@@ -147,9 +166,9 @@
     (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-vector* *the-class-symbol*
                     *the-class-string* *the-class-sequence*
                     *the-class-rational* *the-class-ratio*
                     *the-class-number* *the-class-null* *the-class-list*
@@ -161,17 +180,22 @@
                     *the-class-standard-object*
                     *the-class-structure-object*
                     *the-class-class*
-                    *the-class-method*
                     *the-class-generic-function*
                     *the-class-built-in-class*
                     *the-class-slot-class*
                     *the-class-structure-class*
                     *the-class-standard-class*
                     *the-class-funcallable-standard-class*
+                    *the-class-method*
                     *the-class-standard-method*
+	            *the-class-standard-reader-method*
+	            *the-class-standard-writer-method*
+	            *the-class-standard-boundp-method*
                     *the-class-standard-generic-function*
-                    *the-class-standard-direct-slot-definition*
-                    *the-class-standard-effective-slot-definition*))
+                    *the-class-standard-effective-slot-definition*
+
+                    *the-eslotd-standard-class-slots*
+                    *the-eslotd-funcallable-standard-class-slots*))
 
 (proclaim '(special *the-wrapper-of-t*
                     *the-wrapper-of-vector* *the-wrapper-of-symbol*
@@ -184,7 +208,6 @@
                     *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))
@@ -197,19 +220,26 @@
 	 (or (and (null args) (find-class type))
 	     (ecase type
 	       (class    (coerce-to-class (car args)))
+	       (prototype (make-instance 'class-prototype-specializer
+					 :object (coerce-to-class (car args))))
 	       (class-eq (class-eq-specializer (coerce-to-class (car args))))
 	       (eql      (intern-eql-specializer (car args))))))
 	((specializerp type) type)))
 
 (defun type-from-specializer (specl)
-  (when (symbolp specl)
-    (setq specl (find-class specl))) ;(or (find-class specl nil) (ensure-class specl))
-  (cond ((consp specl)
-         (unless (memq (car specl) '(class class-eq eql))
+  (cond ((eq specl 't)
+	 't)
+	((consp specl)
+         (unless (member (car specl) '(class prototype class-eq eql))
            (error "~S is not a legal specializer type" specl))
          specl)
-        ((specializerp specl)
-         (specializer-type specl))
+        ((progn
+	   (when (symbolp specl)
+	     ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
+	     (setq specl (find-class specl)))
+	   (or (not (eq *boot-state* 'complete))
+	       (specializerp specl)))
+	 (specializer-type specl))
         (t
          (error "~s is neither a type nor a specializer" specl))))
 
@@ -217,9 +247,12 @@
   (declare (special *the-class-t*))
   (setq type (type-from-specializer type))
   (if (atom type)
-      *the-class-t*
+      (if (eq type 't)
+	  *the-class-t*
+	  (error "bad argument to type-class"))
       (case (car type)
         (eql (class-of (cadr type)))
+	(prototype (class-of (cadr type))) ;?
         (class-eq (cadr type))
         (class (cadr type)))))
 
@@ -234,7 +267,7 @@
 (defun make-type-predicate (name)
   (let ((cell (find-class-cell name)))
     #'(lambda (x)
-	(funcall (the compiled-function (find-class-cell-predicate cell)) x))))
+	(funcall (the function (find-class-cell-predicate cell)) x))))
 
 
 ;This stuff isn't right.  Good thing it isn't used.
@@ -261,9 +294,12 @@
   `(satisfies ,(make-class-eq-predicate class)))
 ||#
 
+#-excl
 (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.
@@ -281,8 +317,9 @@
                (let ((type (specializer-type class)))
 		 (if (listp type) type `(,type)))
                `(,type))))
-        ((specializerp type)
-         (specializer-type type))
+        ((or (not (eq *boot-state* 'complete))
+	     (specializerp type))
+	 (specializer-type type))
         (t
          (error "~s is not a type" type))))
 
@@ -310,28 +347,31 @@
 	   (car type)
 	   type))))
 
-(declaim (ftype (function (T T) boolean) *typep))
 (defun *typep (object type)
   (setq type (*normalize-type type))
-  (cond ((memq (car type) '(eql wrapper-eq class-eq class))
+  (cond ((member (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))))
+  (if (equal type1 type2)
+      (values t t)
+      (if (eq *boot-state* 'early)
+	  (values (eq type1 type2) t)
+	  (let ((*in-precompute-effective-methods-p* t)) ; not a descriptive name
+	    (declare (special *in-precompute-effective-methods-p*))
+	    ;; This changes the way class-applicable-using-class-p works.
+	    (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)
+		  (values app-p (or app-p (not maybe-app-p))))
+		(subtypep (convert-to-system-type type1)
+			  (convert-to-system-type type2)))))))
 
 (defun do-satisfies-deftype (name predicate)
   #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
@@ -358,7 +398,6 @@
   (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"
@@ -371,7 +410,6 @@
 			   kind
 			   (symbol-name name)))))
 
-
 
 
 (defvar *built-in-class-symbols* ())
@@ -404,7 +442,7 @@
 (defun variable-class (var env)
   (caddr (variable-declaration 'class var env)))
 
-
+(defvar *name->class->slotd-table* (make-hash-table))
 
 
 ;;;
@@ -436,59 +474,62 @@
 	       classes)))
 
 (defun make-class-predicate-name (name)
-  (intern (format nil "~A class predicate" (symbol-name name))
-          (symbol-package name)))
+  (intern (format nil "~A::~A class predicate"
+		  (package-name (symbol-package name))
+		  name)
+	  *the-pcl-package*))
 
-(defun plist-value (object name &optional default)
-  (getf (object-plist object) name default))
+(defun plist-value (object name)
+  (getf (object-plist object) name))
 
 (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
-  (setf (getf (object-plist object) name) new-value))
+  (if new-value
+      (setf (getf (object-plist object) name) new-value)
+      (progn
+        (remf (object-plist object) name)
+        nil)))
 
 
 
 (defvar *built-in-classes*
   ;;
   ;; name       supers     subs                     cdr of cpl
-  ;; prototype	predicate-name
+  ;; prototype
   '(;(t         ()         (number sequence array character symbol) ())
-    (number     (t)        (complex float rational) (t)
-     1		numberp)
+    (number     (t)        (complex float rational) (t))
     (complex    (number)   ()                       (number t)
-     #c(1 1)	complexp)
+     #c(1 1))
     (float      (number)   ()                       (number t)
-     1.0	floatp)
-    (rational   (number)   (integer ratio)          (number t)
-     1		rationalp)
+     1.0)
+    (rational   (number)   (integer ratio)          (number t))
     (integer    (rational) ()                       (rational number t)
-     1		integerp)
+     1)
     (ratio      (rational) ()                       (rational number t)
      1/2)
 
-    (sequence   (t)        (list vector)            (t)
-     nil	sequencep)
-    (list       (sequence) (cons null)              (sequence t)
-     ()		listp)
+    (sequence   (t)        (list vector)            (t))
+    (list       (sequence) (cons null)              (sequence t))
     (cons       (list)     ()                       (list sequence t)
-     (nil)	consp)
+     (nil))
     
 
     (array      (t)        (vector)                 (t)
-     #2A((NIL))	arrayp)
+     #2A((NIL)))
     (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	bit-vector-p)
+     #*1)
     (character  (t)        ()                       (t)
-     #\c	characterp)
+     #\c)
    
     (symbol     (t)        (null)                   (t)
-     symbol	symbolp)
-    (null       (symbol)   ()                       (symbol list sequence t)
-     nil	null)))
+     symbol)
+    (null       (symbol 
+		 list)     ()                       (symbol list sequence t)
+     nil)))
 
 
 ;;;
@@ -526,95 +567,75 @@
 	:initform ()
 	:accessor object-plist)))
 
-(defclass documentation-mixin ()
-  ((documentation
-      :initform NIL
-      :initarg :documentation)))
+(defclass documentation-mixin (plist-mixin)
+     ())
 
 (defclass dependent-update-mixin (plist-mixin)
     ())
 
 ;;;
 ;;; The class CLASS is a specified basic class.  It is the common superclass
-;;; 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.
+;;; of any kind of class.  That is 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)
-     ((default-initargs
-        :reader class-default-initargs)
-      (direct-default-initargs
-        :initform nil
-        :reader class-direct-default-initargs)
-      (direct-slots
-        :initform nil
-	:reader class-direct-slots)
-      (direct-subclasses
+(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
+		 specializer)
+     ((name
+	:initform nil
+	:initarg  :name
+	:accessor class-name)
+      (class-eq-specializer
         :initform nil
-	:reader class-direct-subclasses)
+        :reader class-eq-specializer)
       (direct-superclasses
-        :initform nil
+	:initform ()
 	:reader class-direct-superclasses)
-      (finalized-p
+      (direct-subclasses
+	:initform ()
+	:reader class-direct-subclasses)
+      (direct-methods
+	:initform (cons nil nil))
+      (predicate-name
         :initform nil
-        :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)))
-
+	:reader class-predicate-name)))
 
 ;;;
 ;;; The class PCL-CLASS is an implementation-specific common superclass of
 ;;; all specified subclasses of the class CLASS.
 ;;; 
 (defclass pcl-class (class)
-     ((cached-in-generic-functions
-        :initform ()
-        :reader class-cached-in-generic-functions)
+     ((class-precedence-list
+	:reader class-precedence-list)
       (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)
-      (predicate-name
-        :initform nil
-	:reader class-predicate-name))
-      )
+      (prototype
+	:initform nil
+	:reader class-prototype)))
 
 (defclass slot-class (pcl-class)
-     ((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).")))
+     ((direct-slots
+	:initform ()
+	:accessor class-direct-slots)
+      (slots
+        :initform ()
+	:accessor class-slots)
+      (initialize-info
+        :initform nil
+	:accessor class-initialize-info)))
 
 ;;;
 ;;; The class STD-CLASS is an implementation-specific common superclass of
 ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
 ;;; 
 (defclass std-class (slot-class)
- ())
+     ())
 
 (defclass standard-class (std-class)
      ())
@@ -627,17 +648,16 @@
 (defclass built-in-class (pcl-class) ())
 
 (defclass structure-class (slot-class)
-     ((defstruct-conc-name
-        :initform nil
-        :reader class-defstruct-conc-name)
+     ((defstruct-form
+        :initform ()
+	:accessor class-defstruct-form)
       (defstruct-constructor
         :initform nil
-	:reader class-defstruct-constructor)
+	:accessor class-defstruct-constructor)
       (from-defclass-p
         :initform nil
-	:initarg :from-defclass-p
-        :reader class-from-defclass-p)))
-
+	:initarg :from-defclass-p)))
+     
 
 (defclass specializer-with-object (specializer) ())
 
@@ -646,6 +666,9 @@
 (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
   ((object :initarg :class :reader specializer-class :reader specializer-object)))
 
+(defclass class-prototype-specializer (specializer-with-object)
+  ((object :initarg :class :reader specializer-class :reader specializer-object)))
+
 (defclass eql-specializer (exact-class-specializer specializer-with-object)
   ((object :initarg :object :reader specializer-object 
 	   :reader eql-specializer-object)))
@@ -661,9 +684,7 @@
 ;;;
 ;;; Slot definitions.
 ;;;
-;;; Note that throughout PCL, "SLOT-DEFINITION" is abbreviated as "SLOTD".
-;;;
-(defclass slot-definition (documentation-mixin metaobject) 
+(defclass slot-definition (metaobject) 
      ((name
 	:initform nil
 	:initarg :name
@@ -674,7 +695,6 @@
 	:accessor slot-definition-initform)
       (initfunction
 	:initform nil
-        :type     (or function null)
 	:initarg :initfunction
 	:accessor slot-definition-initfunction)
       (readers
@@ -693,15 +713,13 @@
 	:initform t
 	:initarg :type
 	:accessor slot-definition-type)
+      (documentation
+	:initform ""
+	:initarg :documentation)
       (class
         :initform nil
 	:initarg :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)))
-
+	:accessor slot-definition-class)))
 
 (defclass standard-slot-definition (slot-definition)
   ((allocation
@@ -727,23 +745,14 @@
   ())
 
 (defclass effective-slot-definition (slot-definition)
-  ((location ; nil, a fixnum, a cons: (slot-name . value)
-    :initform nil
-    :accessor slot-definition-location)
-   (reader-function ; #'(lambda (object) ...)
+  ((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)
-   (internal-slotd
-    :initform NIL
-    :accessor slot-definition-internal-slotd
-    :documentation
-      "Internal-slotd structure with copies of slot-definition info
-       used for optimizations purposes.")))
+    :initform 0)))
 
 (defclass standard-direct-slot-definition (standard-slot-definition
 					   direct-slot-definition)
@@ -751,7 +760,9 @@
 
 (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)
@@ -761,38 +772,96 @@
 					       effective-slot-definition)
   ())
 
+(defclass method (metaobject) ())
+
+(defclass standard-method (definition-source-mixin plist-mixin method)
+     ((generic-function
+	:initform nil	
+	:accessor method-generic-function)
+;     (qualifiers
+;	:initform ()
+;	:initarg  :qualifiers
+;	:reader method-qualifiers)
+      (specializers
+	:initform ()
+	:initarg  :specializers
+	:reader method-specializers)
+      (lambda-list
+	:initform ()
+	:initarg  :lambda-list
+	:reader method-lambda-list)
+      (function
+	:initform nil
+	:initarg :function)		;no writer
+      (fast-function
+	:initform nil
+	:initarg :fast-function		;no writer
+	:reader method-fast-function)
+;     (documentation
+;	:initform nil
+;	:initarg  :documentation
+;	:reader method-documentation)
+      ))
+
+(defclass standard-accessor-method (standard-method)
+     ((slot-name :initform nil
+		 :initarg :slot-name
+		 :reader accessor-method-slot-name)
+      (slot-definition :initform nil
+		       :initarg :slot-definition
+		       :reader accessor-method-slot-definition)))
+
+(defclass standard-reader-method (standard-accessor-method) ())
+
+(defclass standard-writer-method (standard-accessor-method) ())
+
+(defclass standard-boundp-method (standard-accessor-method) ())
+
+(defclass generic-function (dependent-update-mixin
+			    definition-source-mixin
+			    documentation-mixin
+			    metaobject)
+     ()
+  (:metaclass funcallable-standard-class))
+    
+(defclass standard-generic-function (generic-function)
+     ((name
+	:initform nil
+	:initarg :name
+	:accessor generic-function-name)
+      (methods
+	:initform ()
+	:accessor generic-function-methods)
+      (method-class
+	:initarg :method-class
+	:accessor generic-function-method-class)
+      (method-combination
+	:initarg :method-combination
+	:accessor generic-function-method-combination)
+      (arg-info
+        :initform (make-arg-info)
+	:reader gf-arg-info)
+      (dfun-state
+	:initform ()
+	:accessor gf-dfun-state)
+      (pretty-arglist
+	:initform ()
+	:accessor gf-pretty-arglist)
+      )
+  (:metaclass funcallable-standard-class)
+  (:default-initargs :method-class *the-class-standard-method*
+		     :method-combination *standard-method-combination*))
 
+(defclass method-combination (metaobject) ())
 
-(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))))
-
+(defclass standard-method-combination
+	  (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)))
 
 (defparameter *early-class-predicates*
   '((specializer specializerp)
@@ -800,8 +869,18 @@
     (class-eq-specializer class-eq-specializer-p)
     (eql-specializer eql-specializer-p)
     (class classp)
+    (slot-class slot-class-p)
     (standard-class standard-class-p)
     (funcallable-standard-class funcallable-standard-class-p)
     (structure-class structure-class-p)
-    (forward-referenced-class forward-referenced-class-p)))
+    (forward-referenced-class forward-referenced-class-p)
+    (method method-p)
+    (standard-method standard-method-p)
+    (standard-accessor-method standard-accessor-method-p)
+    (standard-reader-method standard-reader-method-p)
+    (standard-writer-method standard-writer-method-p)
+    (standard-boundp-method standard-boundp-method-p)
+    (generic-function generic-function-p)
+    (standard-generic-function standard-generic-function-p)
+    (method-combination method-combination-p)))
 
diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp
index fad393bbc..4a758c239 100644
--- a/pcl/defsys.lisp
+++ b/pcl/defsys.lisp
@@ -50,17 +50,160 @@
 ;;;    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)
-				 (make-package :iterate
-					       :use '(:lisp :walker)))
-			     (find-package :lisp)))
+(in-package :user)
+
+#+excl
+(eval-when (compile load eval)
+  (when (eq (find-package :lisp) (find-package :common-lisp))
+    (let ((excl::*enable-package-locked-errors* nil))
+      (rename-package :common-lisp :common-lisp '(:cl)))
+    (make-package :lisp :use nil)
+    ((lambda (symbols)
+       (import symbols :lisp)
+       (export symbols :lisp))
+     '(&allow-other-keys &aux &body &environment &key &optional &rest &whole
+       * ** *** *applyhook* *break-on-warnings* *debug-io*
+       *default-pathname-defaults* *error-output* *evalhook* *features*
+       *load-verbose* *macroexpand-hook* *modules* *package* *print-array*
+       *print-base* *print-case* *print-circle* *print-escape*
+       *print-gensym* *print-length* *print-level* *print-pretty*
+       *print-radix* *query-io* *random-state* *read-base*
+       *read-default-float-format* *read-suppress* *readtable*
+       *standard-input* *standard-output* *terminal-io* *trace-output* +
+       ++ +++ - / // /// /= 1+ 1- < <= = > >= abs acons acos acosh adjoin
+       adjust-array adjustable-array-p akcl alpha-char-p alphanumericp and
+       append apply applyhook apropos apropos-list aref array
+       array-dimension array-dimension-limit array-dimensions
+       array-element-type array-has-fill-pointer-p array-in-bounds-p
+       array-rank array-rank-limit array-row-major-index array-total-size
+       array-total-size-limit arrayp ash asin asinh assert assoc assoc-if
+       assoc-if-not atan atanh atom bignum bit bit-and bit-andc1 bit-andc2
+       bit-eqv bit-ior bit-nand bit-nor bit-not bit-orc1 bit-orc2
+       bit-vector bit-vector-p bit-xor block boole boole-1 boole-2
+       boole-and boole-andc1 boole-andc2 boole-c1 boole-c2 boole-clr
+       boole-eqv boole-ior boole-nand boole-nor boole-orc1 boole-orc2
+       boole-set boole-xor both-case-p boundp break butlast byte
+       byte-position byte-size caaaar caaadr caaar caadar caaddr caadr
+       caar cadaar cadadr cadar caddar cadddr caddr cadr
+       call-arguments-limit car case catch ccase cdaaar cdaadr cdaar
+       cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr
+       cddr cdr ceiling cerror char char-bit char-bits char-bits-limit
+       char-code char-code-limit char-control-bit char-downcase char-equal
+       char-font char-font-limit char-greaterp char-hyper-bit char-int
+       char-lessp char-meta-bit char-name char-not-equal char-not-greaterp
+       char-not-lessp char-super-bit char-upcase char/= char< char<= char=
+       char> char>= character characterp check-type cis clear-input
+       clear-output close clrhash code-char coerce common commonp
+       compilation-speed compile compile-file compiled-function
+       compiled-function-p compiler-let complex complexp concatenate cond
+       conjugate cons consp constantp copy-alist copy-list copy-readtable
+       copy-seq copy-symbol copy-tree cos cosh count count-if count-if-not
+       ctypecase decf declaration declare decode-float
+       decode-universal-time defconstant define-modify-macro
+       define-setf-method defmacro defparameter defsetf defstruct deftype
+       defun defvar delete delete-duplicates delete-file delete-if
+       delete-if-not denominator deposit-field describe digit-char
+       digit-char-p directory directory-namestring disassemble do do*
+       do-all-symbols do-external-symbols do-symbols documentation dolist
+       dotimes double-float double-float-epsilon
+       double-float-negative-epsilon dpb dribble ecase ed eighth elt
+       encode-universal-time endp enough-namestring eq eql equal equalp
+       error etypecase eval eval-when evalhook evenp every exp export expt
+       fboundp fceiling ffloor fifth file-author file-length
+       file-namestring file-position file-write-date fill fill-pointer
+       find find-all-symbols find-if find-if-not find-package find-symbol
+       finish-output first fixnum flet float float-digits float-precision
+       float-radix float-sign floatp floor fmakunbound force-output format
+       fourth fresh-line fround ftruncate ftype funcall function functionp
+       gcd gensym gentemp get get-decoded-time
+       get-dispatch-macro-character get-internal-real-time
+       get-internal-run-time get-macro-character get-output-stream-string
+       get-properties get-setf-method get-setf-method-multiple-value
+       get-universal-time getf gethash gfun go graphic-char-p hash-table
+       hash-table-count hash-table-p host-namestring identity if ignore
+       imagpart import in-package incf inline input-stream-p inspect
+       int-char integer integer-decode-float integer-length integerp
+       intern internal-time-units-per-second intersection isqrt keyword
+       keywordp labels lambda lambda-list-keywords lambda-parameters-limit
+       last lcm ldb ldb-test ldiff least-negative-double-float
+       least-negative-long-float least-negative-short-float
+       least-negative-single-float least-positive-double-float
+       least-positive-long-float least-positive-short-float
+       least-positive-single-float length let let*
+       lisp-implementation-type lisp-implementation-version list list*
+       list-all-packages list-length listen listp load locally log logand
+       logandc1 logandc2 logbitp logcount logeqv logior lognand lognor
+       lognot logorc1 logorc2 logtest logxor long-float long-float-epsilon
+       long-float-negative-epsilon long-site-name loop lower-case-p
+       machine-instance machine-type machine-version macro-function
+       macroexpand macroexpand-1 macrolet make-array make-broadcast-stream
+       make-char make-concatenated-stream make-dispatch-macro-character
+       make-echo-stream make-hash-table make-list make-package
+       make-pathname make-random-state make-sequence make-string
+       make-string-input-stream make-string-output-stream make-symbol
+       make-synonym-stream make-two-way-stream makunbound map mapc mapcan
+       mapcar mapcon maphash mapl maplist mask-field max member member-if
+       member-if-not merge merge-pathnames min minusp mips mismatch mod
+       most-negative-double-float most-negative-fixnum
+       most-negative-long-float most-negative-short-float
+       most-negative-single-float most-positive-double-float
+       most-positive-fixnum most-positive-long-float
+       most-positive-short-float most-positive-single-float
+       multiple-value-bind multiple-value-call multiple-value-list
+       multiple-value-prog1 multiple-value-setq multiple-values-limit
+       name-char namestring nbutlast nconc nil nintersection ninth not
+       notany notevery notinline nreconc nreverse nset-difference
+       nset-exclusive-or nstring-capitalize nstring-downcase
+       nstring-upcase nsublis nsubst nsubst-if nsubst-if-not nsubstitute
+       nsubstitute-if nsubstitute-if-not nth nthcdr null number numberp
+       numerator nunion oddp open optimize or otherwise output-stream-p
+       package package-name package-nicknames package-shadowing-symbols
+       package-use-list package-used-by-list packagep pairlis
+       parse-integer parse-namestring pathname pathname-device
+       pathname-directory pathname-host pathname-name pathname-type
+       pathname-version pathnamep peek-char phase pi plusp pop position
+       position-if position-if-not pprint prin1 prin1-to-string princ
+       princ-to-string print probe-file proclaim prog prog* prog1 prog2
+       progn progv provide psetf psetq push pushnew quote random
+       random-state random-state-p rassoc rassoc-if rassoc-if-not ratio
+       rational rationalize rationalp read read-byte read-char
+       read-char-no-hang read-delimited-list read-from-string read-line
+       read-preserving-whitespace readtable readtablep realpart reduce rem
+       remf remhash remove remove-duplicates remove-if remove-if-not
+       remprop rename-file rename-package replace require rest return
+       return-from revappend reverse room rotatef round rplaca rplacd
+       safety satisfies sbit scale-float schar search second sequence set
+       set-char-bit set-difference set-dispatch-macro-character
+       set-exclusive-or set-macro-character set-syntax-from-char setf setq
+       seventh sfun shadow shadowing-import shiftf short-float
+       short-float-epsilon short-float-negative-epsilon short-site-name
+       signed-byte signum simple-array simple-bit-vector
+       simple-bit-vector-p simple-string simple-string-p simple-vector
+       simple-vector-p sin single-float single-float-epsilon
+       single-float-negative-epsilon sinh sixth sleep software-type
+       software-version some sort space special special-form-p speed sqrt
+       stable-sort standard-char standard-char-p step stream
+       stream-element-type streamp string string-capitalize string-char
+       string-char-p string-downcase string-equal string-greaterp
+       string-left-trim string-lessp string-not-equal string-not-greaterp
+       string-not-lessp string-right-trim string-trim string-upcase
+       string/= string< string<= string= string> string>= stringp
+       structure sublis subseq subsetp subst subst-if subst-if-not
+       substitute substitute-if substitute-if-not subtypep svref sxhash
+       symbol symbol-function symbol-name symbol-package symbol-plist
+       symbol-value symbolp t tagbody tailp tan tanh tenth terpri the
+       third throw time trace tree-equal truename truncate type type-of
+       typecase typep unexport unintern union unless unread-char
+       unsigned-byte untrace unuse-package unwind-protect upper-case-p
+       use-package user-homedir-pathname values values-list variable
+       vector vector-pop vector-push vector-push-extend vectorp warn when
+       with-input-from-string with-open-file with-open-stream
+       with-output-to-string write write-byte write-char write-line
+       write-string write-to-string y-or-n-p yes-or-no-p zerop))))
+
+(in-package :walker :use '(:lisp))
+(in-package :iterate :use '(:lisp :walker))
+(in-package :pcl :use '(:walker :iterate :lisp))
 
 (export (intern (symbol-name :iterate)		;Have to do this here,
 		(find-package :iterate))	;because in the defsystem
@@ -75,18 +218,16 @@
 ;;; 
 (defvar *the-pcl-package* (find-package :pcl))
 
-(defvar *pcl-system-date* "July 92 PCL (beta)")
+(defvar *pcl-system-date* "September 16 PCL")
 
 #+cmu
-(when (boundp 'ext::*herald-items*)
-  (setf (getf ext::*herald-items* :pcl)
-        `("    CLOS based on PCL version:  " ,*pcl-system-date*)))
-
+(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
@@ -155,8 +296,11 @@
 
   )
 
+#+(and excl sun4)
+(eval-when (eval compile load)
+  (pushnew :excl-sun4 *features*))
 
-
+
 ;;; Yet Another Sort Of General System Facility and friends.
 ;;;
 ;;; The entry points are defsystem and operate-on-system.  defsystem is used
@@ -289,7 +433,7 @@ and load your system with:
 	 #+(and Lucid PRISM)                 ("lisp"  . "abin")
 	 #+(and Lucid PA)                    ("lisp"  . "hbin")
 	 #+(and excl SPARC)                  ("cl"    . "sparc")
-	 #+(and excl m68k (not next))        ("cl"    . "m68k")
+	 #+(and excl m68k)                   ("cl"    . "m68k")
 	 #+excl                              ("cl"    . "fasl")
          #+cmu ("lisp" . #.(c:backend-fasl-file-type c:*backend*))
 	 #+HP-HPLabs                         ("l"     . "b")
@@ -484,14 +628,7 @@ 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))
-	(: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))))))
+	   #'make-load-without-dependencies-transformation))))))
 
 (defun true (&rest ignore)
   (declare (ignore ignore))
@@ -562,18 +699,6 @@ 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))
@@ -591,7 +716,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
@@ -613,10 +738,6 @@ 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."))))
@@ -630,8 +751,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*))
-
+    #+akcl   si:*load-pathname*
+    #-(or Lispm excl Xerox (and dec vax common) LUCID akcl) nil))
 
 #-(or cmu Symbolics)
 (defvar *pcl-directory*
@@ -708,34 +829,39 @@ and load your system with:
    (defclass    t                                   t (low))
    (defs        t                                   t (defclass macros iterate))
    (fngen       t                                   t (low))
-   (lap         t                                   t (low))
-   (plap        t                                   t (low))
-   (cpatch      t                                   t (low)    excl-sun4)
-   (quadlap     t                                   t (low)    excl-sun4)
    (cache       t                                   t (low defs))
-   (dlap        t                                   t (defs low fin cache lap))
+   ;;(lap         t                                   t (low)    excl-sun4)
+   ;;(plap        t                                   t (low)    excl-sun4)
+   ;;(cpatch      t                                   t (low)    excl-sun4)
+   ;;(quadlap     t                                   t (low)    excl-sun4)
+   ;;(dlap        t                                   t (defs low fin cache lap) 
+   ;;	                                                         excl-sun4)
+   ;;#-excl-sun4
+   (dlisp       t                                   t (defs low fin cache))
+   (dlisp2      t                                   t (low fin cache dlisp))
    (boot        t                                   t (defs fin))
-   (generic-functions t                             t (boot))
    (vector      t                                   t (boot defs cache fin))
+   (slots-boot  t                                   t (vector boot defs cache fin))
+   (combin      t                                   t (boot defs))
+   (dfun        t                                   t (boot low cache))
+   (fast-init   t                                   t (boot low))
+   (braid       (+ precom1 precom2)                 t (boot defs low fin cache))
+   (generic-functions t                             t (boot))
    (slots       t                                   t (vector boot defs low cache fin))
-   (init        t                                   t (vector boot defs low cache fin))
+   (init        t                                   t (vector boot defs low fast-init))
    (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))
    (methods     t                                   t (defclass boot defs low fin cache))
-   (combin      t                                   t (defclass boot defs low fin cache))
-   (dfun        t                                   t (dlap))
-   (fixup       (+ precom1 precom2)                 t (boot defs low fin))
+   (fixup       t                                   t (boot defs low fin))
    (defcombin   t                                   t (defclass boot defs low fin))
    (ctypes      t                                   t (defclass defcombin))
+   #+ignore
    (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))
+   (precom1     (dlisp)                             t (defs low cache fin dfun))
+   (precom2     (dlisp)                             t (defs low cache fin dfun))
    ))
 
 (defun compile-pcl (&optional m)
@@ -788,8 +914,8 @@ and load your system with:
 	  (lisp-implementation-version)
 	  *features*))
 
-
-
+
+
 ;;;;
 ;;;
 ;;; This stuff is not intended for external use.
@@ -868,5 +994,42 @@ and load your system with:
              (zwei:kill-buffer mail-buffer)))
       (zwei:make-buffer-current original-buffer))))
 
+(defun reset-pcl-package ()		; Try to do this safely
+  (let* ((vars '(*pcl-directory* 
+		 *default-pathname-extensions* 
+		 *pathname-extensions*
+		 *redefined-functions*))
+	 (names (mapcar #'symbol-name vars))
+	 (values (mapcar #'symbol-value vars)))
+    (declare (special *redefined-functions*))
+    (let ((pkg (find-package "PCL")))
+      (do-symbols (sym pkg)
+	(when (eq pkg (symbol-package sym))
+	  (if (or (constantp sym)
+		  (eq sym 'wrapper)
+		  (eq sym 'arg-info))
+	      (unintern sym pkg)
+	      (progn
+		(makunbound sym)
+		(unless (eq sym '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 *redefined-functions*)
+      (setf (symbol-function sym) (get sym ':definition-before-pcl)))
+    nil))
+
 
 
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
index d9c6b02ca..0972ec87a 100644
--- a/pcl/dfun.lisp
+++ b/pcl/dfun.lisp
@@ -81,7 +81,6 @@ have to do any method lookup to implement itself.
 And so, we are saved.
 
 |#
-
 
 
 ;An alist in which each entry is of the form :
@@ -106,32 +105,61 @@ And so, we are saved.
 	      (cons (car generator-entry) (caar args-entry))
 	      (caddr args-entry)))))
 
+(defvar *raise-metatypes-to-class-p* t)
 
-(declaim (ftype (function (T &rest T) real-function) get-dfun-constructor))
 (defun get-dfun-constructor (generator &rest args)
+  (when (and *raise-metatypes-to-class-p*
+	     (member generator '(emit-checking emit-caching
+				 emit-in-checking-cache-p emit-constant-value)))
+    (setq args (cons (mapcar #'(lambda (mt)
+				 (if (eq mt 't)
+				     mt
+				     'class))
+			     (car args))
+		     (cdr args))))						  
   (let* ((generator-entry (assq generator *dfun-constructors*))
 	 (args-entry (assoc args (cdr generator-entry) :test #'equal)))
     (if (null *enable-dfun-constructor-caching*)
-	(apply-function (symbol-function generator) args)
+	(apply (symbol-function generator) args)
 	(or (cadr args-entry)
-	    (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*))
-	      new)))))
+	    (multiple-value-bind (new not-best-p)
+		(apply (symbol-function generator) args)
+	      (let ((entry (list (copy-list args) new (unless not-best-p 'pcl)
+				 not-best-p)))
+		(if generator-entry
+		    (push entry (cdr generator-entry))
+		    (push (list generator entry)
+			  *dfun-constructors*)))
+	      (values new not-best-p))))))
 
 (defun load-precompiled-dfun-constructor (generator args system constructor)
   (let* ((generator-entry (assq generator *dfun-constructors*))
 	 (args-entry (assoc args (cdr generator-entry) :test #'equal)))
-    (unless args-entry
-      (if generator-entry
-	  (push (list args constructor system) (cdr generator-entry))
-	  (push (list generator (list args constructor system)) *dfun-constructors*)))))
+    (if args-entry
+	(when (fourth args-entry)
+	  (let* ((dfun-type (case generator
+			      (emit-checking 'checking)
+			      (emit-caching 'caching)
+			      (emit-constant-value 'constant-value)
+			      (emit-default-only 'default-method-only)))
+		 (metatypes (car args))
+		 (gfs (when dfun-type (gfs-of-type dfun-type))))
+	    (dolist (gf gfs)
+	      (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf)))
+			 (let ((gf-name (generic-function-name gf)))
+			   (and (not (eq gf-name 'slot-value-using-class))
+				(not (equal gf-name '(setf slot-value-using-class)))
+				(not (eq gf-name 'slot-boundp-using-class)))))
+		(update-dfun gf)))
+	    (setf (second args-entry) constructor)
+	    (setf (third args-entry) system)
+	    (setf (fourth args-entry) nil)))
+	(let ((entry (list args constructor system nil)))
+	  (if generator-entry
+	      (push entry (cdr generator-entry))
+	      (push (list generator entry) *dfun-constructors*))))))
 
 (defmacro precompile-dfun-constructors (&optional system)
-  #+excl (declare (ignore system))
-  #+excl ()
-  #-excl
   (let ((*precompiling-lap* t))
     `(progn
        ,@(gathering1 (collecting)
@@ -140,25 +168,16 @@ And so, we are saved.
 	       (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-function (symbol-function (car generator-entry))
-                                     (car args-entry))
-		   (gather1
-		     (make-top-level-form `(precompile-dfun-constructor 
-					    ,(car generator-entry))
-					  '(load)
-		       `(load-precompiled-dfun-constructor
-			  ',(car generator-entry)
-			  ',(car args-entry)
-			  ',system
-			  (precompile-lap-closure-generator ,closure-variables
-							    ,arguments
-							    ,iregs
-							    ,vregs
-			                                    ,fvregs
-							    ,tregs
-							    ,lap))))))))))))
+		 (gather1
+		   (make-top-level-form `(precompile-dfun-constructor 
+					  ,(car generator-entry))
+					'(load)
+		     `(load-precompiled-dfun-constructor
+		       ',(car generator-entry)
+		       ',(car args-entry)
+		       ',system
+		       ,(apply (symbol-function (car generator-entry))
+			       (car args-entry))))))))))))
 
 
 ;;;
@@ -210,6 +229,10 @@ And so, we are saved.
 	     (:constructor no-methods-dfun-info ())
 	     (:include dfun-info)))
 
+(defstruct (initial
+	     (:constructor initial-dfun-info ())
+	     (:include dfun-info)))
+
 (defstruct (initial-dispatch
 	     (:constructor initial-dispatch-dfun-info ())
 	     (:include dfun-info)))
@@ -289,7 +312,7 @@ And so, we are saved.
 
 (defmacro dfun-update (generic-function function &rest args)
   `(multiple-value-bind (dfun cache info)
-       (funcall-function ,function ,generic-function ,@args)
+       (funcall ,function ,generic-function ,@args)
      (update-dfun ,generic-function dfun cache info)))
 
 (defun accessor-miss-function (gf dfun-info)
@@ -302,47 +325,10 @@ 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)))
@@ -356,8 +342,6 @@ 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)))
@@ -371,8 +355,6 @@ 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)))
@@ -380,25 +362,20 @@ And so, we are saved.
     (declare (type cache cache))
     (values
      (funcall (get-dfun-constructor emit (consp index))
-	      (cache-field cache) (cache-vector cache) 
-	      (cache-mask cache) (cache-size cache)
+	      cache
 	      index
 	      (accessor-miss-function gf dfun-info))
      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)))				
+    (make-one-index-accessor-dfun gf type index cache)))
 
 (defun one-index-limit-fn (nlines)
   (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)))
@@ -406,14 +383,11 @@ And so, we are saved.
     (declare (type cache cache))
     (values
      (funcall (get-dfun-constructor emit)
-	      (cache-field cache) (cache-vector cache) 
-	      (cache-mask cache) (cache-size cache)
+	      cache
 	      (accessor-miss-function gf dfun-info))
      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)))
@@ -421,47 +395,27 @@ And so, we are saved.
 (defun n-n-accessors-limit-fn (nlines)
   (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
-		 (the index (+ (the index (hash-table-count table)) 3))))))
-    (maphash #'(lambda (classes value)
-		 (setq cache (fill-cache cache
-					 (class-wrapper classes)
-					 value
-					 t)))
-	     table)
-    cache))
-
-
-;;;
-;;;
-;;;
-
-
 (defun make-checking-dfun (generic-function function &optional cache)
   (unless cache
-    (when (some #'(lambda (method)
-		    (method-closure-generator method))
-		(generic-function-methods generic-function))
+    (when (use-caching-dfun-p generic-function)
       (return-from make-checking-dfun (make-caching-dfun generic-function)))
     (when (use-dispatch-dfun-p generic-function)
       (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
-  (let* ((arg-info (gf-arg-info generic-function))
-	 (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))
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-function-info generic-function)
+    (declare (ignore nreq))
     (if (every #'(lambda (mt) (eq mt 't)) metatypes)
-	(values function nil (default-method-only-dfun-info))
+	(let ((dfun-info (default-method-only-dfun-info)))
+	  (values 
+	   (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
+		    function)
+	   nil
+	   dfun-info))
 	(let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
 	       (dfun-info (checking-dfun-info function cache)))
 	  (values
 	   (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
-		    (cache-field cache) (cache-vector cache) 
-		    (cache-mask cache) (cache-size cache)
+		    cache
 		    function 
 		    #'(lambda (&rest args)
 			(declare (pcl-fast-call))
@@ -473,12 +427,30 @@ And so, we are saved.
 						  classes-list new-class)
   (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
     (if (every #'(lambda (mt) (eq mt 't)) metatypes)
-	(values function nil (default-method-only-dfun-info))
+	(values #'(lambda (&rest args)
+		    (invoke-emf function args))
+		nil (default-method-only-dfun-info))
 	(let ((cache (make-final-ordinary-dfun-internal 
 		      generic-function nil #'checking-limit-fn 
 		      classes-list new-class)))
 	  (make-checking-dfun generic-function function cache)))))
 
+(defun use-default-method-only-dfun-p (generic-function)
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-function-info generic-function)
+    (declare (ignore nreq applyp nkeys))
+    (every #'(lambda (mt) (eq mt 't)) metatypes)))
+
+(defun use-caching-dfun-p (generic-function)
+  (some #'(lambda (method)
+	    (let ((fmf (if (listp method)
+			   (third method)
+			   (method-fast-function method))))
+	      (method-function-get fmf ':slot-name-lists)))
+	(if (early-gf-p generic-function)
+	    (early-gf-methods generic-function)
+	    (generic-function-methods generic-function))))
+
 (defun checking-limit-fn (nlines)
   (default-limit-fn nlines))
 
@@ -492,22 +464,19 @@ And so, we are saved.
       (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
     (when (use-dispatch-dfun-p generic-function)
       (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
-  (let* ((arg-info (gf-arg-info generic-function))
-	 (metatypes (arg-info-metatypes arg-info))
-	 (applyp (arg-info-applyp arg-info))
-	 (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) 
-	      (cache-mask cache) (cache-size cache)
-	      #'(lambda (&rest args)
-		  (declare (pcl-fast-call))
-		  (caching-miss generic-function args dfun-info)))
-     cache
-     dfun-info)))
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-function-info generic-function)
+    (declare (ignore nreq))
+    (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
+	   (dfun-info (caching-dfun-info cache)))
+      (values
+       (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
+		cache
+		#'(lambda (&rest args)
+		    (declare (pcl-fast-call))
+		    (caching-miss generic-function args dfun-info)))
+       cache
+       dfun-info))))
 
 (defun make-final-caching-dfun (generic-function classes-list new-class)
   (let ((cache (make-final-ordinary-dfun-internal 
@@ -518,39 +487,57 @@ And so, we are saved.
 (defun caching-limit-fn (nlines)
   (default-limit-fn nlines))
 
-(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))
-	 (some #'(lambda (method)
-		   (every #'(lambda (specl) (eq specl *the-class-t*))
-			  (method-specializers method)))
-	       methods)
-	 (notany #'(lambda (method)
-		     (or (some #'eql-specializer-p
-			       (method-specializers method))
-			 (eq (plist-value method :constant-value default)
-			     default)))
-		methods))))
+(defun insure-caching-dfun (gf)
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-function-info gf)
+    (declare (ignore nreq nkeys))
+    (when (and metatypes
+	       (not (null (car metatypes)))
+	       (dolist (mt metatypes nil)
+		 (unless (eq mt 't) (return t))))
+      (get-dfun-constructor 'emit-caching metatypes applyp))))
+
+(defun use-constant-value-dfun-p (gf &optional boolean-values-p)
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-function-info gf)
+    (declare (ignore nreq metatypes nkeys))
+    (let* ((early-p (early-gf-p gf))
+	   (methods (if early-p
+			(early-gf-methods gf)
+			(generic-function-methods gf)))
+	   (default '(unknown)))
+      (and (null applyp)
+	   (or (not (eq *boot-state* 'complete))
+	       (compute-applicable-methods-emf-std-p gf))
+	   (notany #'(lambda (method)
+		       (or (and (eq *boot-state* 'complete)
+				(some #'eql-specializer-p
+				      (method-specializers method)))
+			   (let ((value (method-function-get 
+					 (if early-p
+					     (or (third method) (second method))
+					     (or (method-fast-function method)
+						 (method-function method)))
+					 :constant-value default)))
+			     (if boolean-values-p
+				 (not (or (eq value 't) (eq value nil)))
+				 (eq value default)))))
+		   methods)))))
 
 (defun make-constant-value-dfun (generic-function &optional cache)
-  (let* ((arg-info (gf-arg-info generic-function))
-	 (metatypes (arg-info-metatypes arg-info))
-	 (nkeys (arg-info-nkeys arg-info))
-	 (cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
-	 (dfun-info (constant-value-dfun-info cache)))
-    (values
-     (funcall (get-dfun-constructor 'emit-constant-value metatypes)
-	      (cache-field cache) (cache-vector cache) 
-	      (cache-mask cache) (cache-size cache)
-	      #'(lambda (&rest args)
-		  (declare (pcl-fast-call))
-		  (constant-value-miss generic-function args dfun-info)))
-     cache
-     dfun-info)))
+  (multiple-value-bind (nreq applyp metatypes nkeys)
+      (get-generic-function-info generic-function)
+    (declare (ignore nreq applyp))
+    (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
+	   (dfun-info (constant-value-dfun-info cache)))
+      (values
+       (funcall (get-dfun-constructor 'emit-constant-value metatypes)
+		cache
+		#'(lambda (&rest args)
+		    (declare (pcl-fast-call))
+		    (constant-value-miss generic-function args dfun-info)))
+       cache
+       dfun-info))))
 
 (defun make-final-constant-value-dfun (generic-function classes-list new-class)
   (let ((cache (make-final-ordinary-dfun-internal 
@@ -558,8 +545,57 @@ And so, we are saved.
 		classes-list new-class)))
     (make-constant-value-dfun generic-function cache)))
 
+(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
+  (when (eq *boot-state* 'complete)
+    (unless caching-p
+      (let* ((methods (generic-function-methods gf))
+	     (arg-info (gf-arg-info gf))
+	     (mt (arg-info-metatypes arg-info))
+	     (nreq (length mt)))
+	;;Is there a position at which every specializer is eql or non-standard?
+	(dotimes (i nreq nil)
+	  (when (not (eq 't (nth i mt)))
+	    (let ((some-std-class-specl-p nil))
+	      (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)))))
+		    (setq some-std-class-specl-p t))))
+	      (unless some-std-class-specl-p
+		(return-from use-dispatch-dfun-p t)))))))))
+
+(defun make-dispatch-dfun (gf)
+  (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
+
+(defun get-dispatch-function (gf)
+  (let ((methods (generic-function-methods gf)))
+    (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil 
+							nil nil t)
+		      nil nil)))
+
+(defun make-final-dispatch-dfun (gf)
+  (make-dispatch-dfun gf))
+
+(defun update-dispatch-dfuns ()
+  (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
+    (dfun-update gf #'make-dispatch-dfun)))
+
+(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)))))
+    (maphash #'(lambda (classes value)
+		 (setq cache (fill-cache cache
+					 (class-wrapper classes)
+					 value
+					 t)))
+	     table)
+    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
@@ -571,64 +607,23 @@ 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)
-  (some #'method-function-for-caching-p (generic-function-methods gf)))
-
-(defun use-dispatch-dfun-p (gf)
-  (unless (use-caching-dfun-p gf)
-    (let* ((methods (generic-function-methods gf))
-	   (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)))
-	  (let ((some-std-class-specl-p nil))
-	    (dolist (method methods)
-	      (let ((specl (nth i (method-specializers method))))
-		(when (and (not (eql-specializer-p specl))
-                           (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))))))))
-
-(defvar *lazy-dispatch-dfun-compute-p* t)
-(defvar *lazy-dfun-compute-p* nil)
-
-(defun make-dispatch-dfun (gf)
-  (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
-
-(defun make-final-dispatch-dfun (gf)
-  (if *lazy-dispatch-dfun-compute-p*
-      (values (let ((*lazy-dfun-compute-p* t))
-		(make-initial-dfun gf))
-	      nil (initial-dispatch-dfun-info))
-      (make-dispatch-dfun gf)))
-
-(defun before-precompile-random-code-segments ()
-  (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
-    (dfun-update gf #'make-dispatch-dfun)))
 
 (defvar *dfun-miss-gfs-on-stack* ())
 
-(defmacro dfun-miss ((gf args wrappers invalidp nfunction 
+(defmacro dfun-miss ((gf args wrappers invalidp nemf
 		      &optional type index caching-p applicable)
 		     &body body)
   (unless applicable (setq applicable (gensym)))
-  `(multiple-value-bind (,wrappers ,invalidp ,nfunction ,applicable 
-				   ,@(when type `(,type ,index)))
-       (cache-miss-values ,gf ,args ',(cond (type 'accessor)
-					    (caching-p 'caching)
+  `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp 
+			 ,@(when type `(,type ,index)))
+       (cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
+					    (type 'accessor)
 					    (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))
-     (method-function-apply ,nfunction ,args)))
+     (invoke-emf ,nemf ,args)))
 
 ;;;
 ;;; The dynamically adaptive method lookup algorithm is implemented is
@@ -643,78 +638,156 @@ And so, we are saved.
 ;;; simply select a new cache or cache field.  Those are not considered
 ;;; as state transitions.
 ;;; 
+(defvar *lazy-dfun-compute-p* t)
+(defvar *early-p* nil)
+
 (defun make-initial-dfun (gf)
-  (if (or *lazy-dfun-compute-p* (not (compute-applicable-methods-emf-std-p gf)))
-      #'(lambda (&rest args)
-	  #+Genera (declare (dbg:invisible-frame :pcl-internals))
-	  (initial-dfun args gf))
-      (make-final-dfun gf (precompute-effective-methods gf t))))
-
-(defun initial-dfun (args generic-function)
-  #+Genera (declare (dbg:invisible-frame :pcl-internals))
-  (dfun-miss (generic-function args wrappers invalidp nfunction ntype nindex)
+  (let ((initial-dfun 
+	 #'(lambda (&rest args)
+	     (initial-dfun gf args))))
+    (multiple-value-bind (dfun cache info)
+	(if (and (eq *boot-state* 'complete)
+		 (compute-applicable-methods-emf-std-p gf))
+	    (let* ((caching-p (use-caching-dfun-p gf))
+		   (classes-list (precompute-effective-methods 
+				  gf caching-p
+				  (not *lazy-dfun-compute-p*))))
+	      (if *lazy-dfun-compute-p*
+		  (cond ((use-dispatch-dfun-p gf caching-p)
+			 (values initial-dfun nil (initial-dispatch-dfun-info)))
+			(caching-p
+			 (insure-caching-dfun gf)
+			 (values initial-dfun nil (initial-dfun-info)))
+			(t
+			 (values initial-dfun nil (initial-dfun-info))))
+		  (make-final-dfun-internal gf classes-list)))
+	    (let ((arg-info (if (early-gf-p gf)
+				(early-gf-arg-info gf)
+				(gf-arg-info gf)))
+		  (type nil))
+	      (if (and (gf-precompute-dfun-and-emf-p arg-info)
+		       (setq type (final-accessor-dfun-type gf)))
+		  (if *early-p*
+		      (values (make-early-accessor gf type) nil nil)
+		      (make-final-accessor-dfun gf type))
+		  (values initial-dfun nil (initial-dfun-info)))))
+      (set-dfun gf dfun cache info))))
+
+(defun make-early-accessor (gf type)
+  (let* ((methods (early-gf-methods gf))
+	 (slot-name (early-method-standard-accessor-slot-name (car methods))))
+    (ecase type
+      (reader #'(lambda (instance)
+		  (let* ((class (class-of instance))
+			 (class-name (bootstrap-get-slot 'class class 'name)))
+		    (bootstrap-get-slot class-name instance slot-name))))
+      (writer #'(lambda (new-value instance)
+		  (let* ((class (class-of instance))
+			 (class-name (bootstrap-get-slot 'class class 'name)))
+		    (bootstrap-set-slot class-name instance slot-name new-value)))))))
+
+(defun initial-dfun (gf args)
+  (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
     (cond (invalidp)
 	  ((and ntype nindex)
-	   (dfun-update generic-function
-			#'make-one-class-accessor-dfun ntype wrappers nindex))
+	   (dfun-update 
+	    gf #'make-one-class-accessor-dfun ntype wrappers nindex))
+	  ((use-caching-dfun-p gf)
+	   (dfun-update gf #'make-caching-dfun))
 	  (t
-	   (dfun-update generic-function #'make-checking-dfun
-			;; nfunction is suitable only for caching, have to do this:
-			(multiple-value-bind (w i function)
-			    (cache-miss-values generic-function args 'checking)
-			  (declare (ignore w i))
-			  function))))))
+	   (dfun-update 
+	    gf #'make-checking-dfun
+	    ;; nemf is suitable only for caching, have to do this:
+	    (cache-miss-values gf args 'checking))))))
 
 (defun make-final-dfun (gf &optional classes-list)
   (multiple-value-bind (dfun cache info)
       (make-final-dfun-internal gf classes-list)
     (set-dfun gf dfun cache info)))
 
+(defvar *new-class* nil)
+
+(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
+
+(defmacro with-hash-table ((table test) &body forms)
+  `(let* ((.free. (assoc ',test *free-hash-tables*))
+	  (,table (if (cdr .free.)
+		      (pop (cdr .free.))
+		      (make-hash-table :test ',test))))
+     (multiple-value-prog1
+	 (progn ,@forms)
+       (clrhash ,table)
+       (push ,table (cdr .free.)))))
+
+(defmacro with-eq-hash-table ((table) &body forms)
+  `(with-hash-table (,table eq) ,@forms))
+
+(defun final-accessor-dfun-type (gf)
+  (let ((methods (if (early-gf-p gf)
+		     (early-gf-methods gf)
+		     (generic-function-methods gf))))
+    (cond ((every #'(lambda (method) 
+		      (if (consp method)
+			  (eq *the-class-standard-reader-method*
+			      (early-method-class method))
+			  (standard-reader-method-p method)))
+		  methods)
+	   'reader)
+	  ((every #'(lambda (method) 
+		      (if (consp method)
+			  (eq *the-class-standard-writer-method*
+			      (early-method-class method))
+			  (standard-writer-method-p method)))
+		  methods)
+	   'writer))))
+
+(defun make-final-accessor-dfun (gf type &optional classes-list new-class)
+  (with-eq-hash-table (table)
+    (multiple-value-bind (table all-index first second size no-class-slots-p)
+	(make-accessor-table gf type table)
+      (if table
+	  (cond ((= 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)))
+		 (let ((w0 (class-wrapper first))
+		       (w1 (class-wrapper second)))
+		   (make-two-class-accessor-dfun gf type w0 w1 all-index)))
+		((or (integerp all-index) (consp all-index))
+		 (make-final-one-index-accessor-dfun 
+		  gf type all-index table))
+		(no-class-slots-p
+		 (make-final-n-n-accessor-dfun gf type table))
+		(t
+		 (make-final-caching-dfun gf classes-list new-class)))
+	  (make-final-caching-dfun gf classes-list new-class)))))
+
 (defun make-final-dfun-internal (gf &optional classes-list)
   (let ((methods (generic-function-methods gf)) type
-	(new-class *new-class*) (*new-class* nil))
+	(new-class *new-class*) (*new-class* nil)
+	specls all-same-p)
     (cond ((null methods)
 	   (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)
-			     'writer)))
-	   (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 ((= (the index size) 1)
-			  (let ((w (class-wrapper first)))
-			    (make-one-class-accessor-dfun gf type w 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)))
-			 ((or (integerp all-index) (consp all-index))
-			  (make-final-one-index-accessor-dfun 
-			   gf type all-index table))
-			 (no-class-slots-p
-			  (make-final-n-n-accessor-dfun gf type table))
-			 (t
-			  (make-final-caching-dfun gf classes-list new-class)))
-		   (make-final-caching-dfun gf classes-list new-class)))))
-	  ((use-constant-value-dfun-p gf)
+	  ((setq type (final-accessor-dfun-type gf))
+	   (make-final-accessor-dfun gf type classes-list new-class))
+	  ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*))
+				 (setq specls (method-specializers (car methods))))
+			  (setq all-same-p
+				(every #'(lambda (method)
+					   (and (equal specls
+						       (method-specializers method))))
+				       methods))))
+		(use-constant-value-dfun-p gf))
 	   (make-final-constant-value-dfun gf classes-list new-class))
 	  ((use-dispatch-dfun-p gf)
 	   (make-final-dispatch-dfun gf))
-	  ((let ((specls (method-specializers (car methods))))
-	     (and (every #'(lambda (method)
-			     (and (equal specls (method-specializers method))))
-			 methods)
-		  (not (use-caching-dfun-p gf))))
-	   (let ((function (get-secondary-dispatch-function gf methods nil)))
-	     (make-final-checking-dfun gf function classes-list new-class)))
+	  ((and all-same-p (not (use-caching-dfun-p gf)))
+	   (let ((emf (get-secondary-dispatch-function gf methods nil)))
+	     (make-final-checking-dfun gf emf classes-list new-class)))
 	  (t
 	   (make-final-caching-dfun gf classes-list new-class)))))
 
@@ -725,7 +798,7 @@ And so, we are saved.
 	 (args (ecase otype			;The congruence rules assure
 		(reader (list object))		;us that this is safe despite
 		(writer (list new object)))))	;not knowing the new type yet.
-    (dfun-miss (gf args wrappers invalidp nfunction ntype nindex)
+    (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
       ;;
       ;; The following lexical functions change the state of the
       ;; dfun to that which is their name.  They accept arguments
@@ -733,13 +806,13 @@ And so, we are saved.
       ;; information from the lexical variables bound above.
       ;; 
       (flet ((two-class (index w0 w1)
-	       (when (zerop (the index (random 2))) (psetf w0 w1 w1 w0))
+	       (when (zerop (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))
 	     (n-n (&optional cache)
 	       (if (consp nindex)
-		   (dfun-update gf #'make-checking-dfun nfunction)
+		   (dfun-update gf #'make-checking-dfun nemf)
 		   (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
 	     (caching () ; because cached accessor emfs are much faster for accessors
 	       (dfun-update gf #'make-caching-dfun))
@@ -747,15 +820,13 @@ And so, we are saved.
 	     (do-fill (update-fn)
 	       (let ((ncache (fill-cache cache wrappers nindex)))
 		 (unless (eq ncache cache)
-		   (funcall-function update-fn ncache)))))
+		   (funcall update-fn ncache)))))
 	(cond ((null ntype)
 	       (caching))
 	      ((or invalidp
 		   (null nindex)))
 	      ((not (or (std-instance-p object)
-			(fsc-instance-p object)
-                        #+pcl-user-instances
-                        (user-instance-p object)))
+			(fsc-instance-p object)))
 	       (caching))
 	      ((or (neq ntype otype) (listp wrappers))
 	       (caching))
@@ -790,41 +861,594 @@ And so, we are saved.
 		      (do-fill #'n-n))))))))))
 
 (defun checking-miss (generic-function args dfun-info)
-  (let ((ofunction (dfun-info-function dfun-info))
+  (let ((oemf (dfun-info-function dfun-info))
 	(cache (dfun-info-cache dfun-info)))
-    (dfun-miss (generic-function args wrappers invalidp nfunction)
+    (dfun-miss (generic-function args wrappers invalidp nemf)
       (cond (invalidp)
-	    ((eq ofunction nfunction)
+	    ((eq oemf nemf)
 	     (let ((ncache (fill-cache cache wrappers nil)))
 	       (unless (eq ncache cache)
 		 (dfun-update generic-function #'make-checking-dfun 
-			      nfunction ncache))))
+			      nemf ncache))))
 	    (t
 	     (dfun-update generic-function #'make-caching-dfun))))))
 
 (defun caching-miss (generic-function args dfun-info)
   (let ((ocache (dfun-info-cache dfun-info)))
-    (dfun-miss (generic-function args wrappers invalidp function nil nil t)
+    (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
       (cond (invalidp)
 	    (t
-	     (let ((ncache (fill-cache ocache wrappers function)))
+	     (let ((ncache (fill-cache ocache wrappers emf)))
 	       (unless (eq ncache ocache)
 		 (dfun-update generic-function 
 			      #'make-caching-dfun ncache))))))))
 
 (defun constant-value-miss (generic-function args dfun-info)
   (let ((ocache (dfun-info-cache dfun-info)))
-    (dfun-miss (generic-function args wrappers invalidp function nil nil t)
+    (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
       (cond (invalidp)
 	    (t
-	     (let* ((value (method-constant-value (method-function-method function)))
+	     (let* ((function (typecase emf
+				(fast-method-call (fast-method-call-function emf))
+				(method-call (method-call-function emf))))
+		    (value (method-function-get function :constant-value))
 		    (ncache (fill-cache ocache wrappers value)))
 	       (unless (eq ncache ocache)
 		 (dfun-update generic-function
 			      #'make-constant-value-dfun ncache))))))))
-
 
+;;; Given a generic function and a set of arguments to that generic function,
+;;; returns a mess of values.
+;;;
+;;;  <function>   The compiled effective method function for this set of
+;;;               arguments. 
+;;;
+;;;  <applicable> Sorted list of applicable methods. 
+;;;
+;;;  <wrappers>   Is a single wrapper if the generic function has only
+;;;               one key, that is arg-info-nkeys of the arg-info is 1.
+;;;               Otherwise a list of the wrappers of the specialized
+;;;               arguments to the generic function.
+;;;
+;;;               Note that all these wrappers are valid.  This function
+;;;               does invalid wrapper traps when it finds an invalid
+;;;               wrapper and then returns the new, valid wrapper.
+;;;
+;;;  <invalidp>   True if any of the specialized arguments had an invalid
+;;;               wrapper, false otherwise.
+;;;
+;;;  <type>       READER or WRITER when the only method that would be run
+;;;               is a standard reader or writer method.  To be specific,
+;;;               the value is READER when the method combination is eq to
+;;;               *standard-method-combination*; there are no applicable
+;;;               :before, :after or :around methods; and the most specific
+;;;               primary method is a standard reader method.
+;;;
+;;;  <index>      If <type> is READER or WRITER, and the slot accessed is
+;;;               an :instance slot, this is the index number of that slot
+;;;               in the object argument.
+;;;
+(defun cache-miss-values (gf args state)
+  (if (null (if (early-gf-p gf)
+		(early-gf-methods gf)
+		(generic-function-methods gf)))
+      (apply #'no-applicable-method gf args)
+      (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+	  (get-generic-function-info gf)
+	(declare (ignore nreq applyp nkeys))
+	(with-dfun-wrappers (args metatypes)
+	  (dfun-wrappers invalid-wrapper-p wrappers classes types)
+	  (error "The function ~S requires at least ~D arguments"
+		 gf (length metatypes))
+	  (multiple-value-bind (emf methods accessor-type index)
+	      (cache-miss-values-internal gf arg-info wrappers classes types state)
+	    (values emf methods
+		    dfun-wrappers
+		    invalid-wrapper-p
+		    accessor-type index))))))
+
+(defun cache-miss-values-internal (gf arg-info wrappers classes types state)
+  (let* ((for-accessor-p (eq state 'accessor))
+	 (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
+	 (cam-std-p (or (null arg-info)
+			(gf-info-c-a-m-emf-std-p arg-info))))
+    (multiple-value-bind (methods all-applicable-and-sorted-p)
+	(if cam-std-p
+	    (compute-applicable-methods-using-types gf types)
+	    (compute-applicable-methods-using-classes gf classes))
+      (let ((emf (if (or cam-std-p all-applicable-and-sorted-p)
+		     (function-funcall (get-secondary-dispatch-function1
+					gf methods types nil (and for-cache-p wrappers)
+					all-applicable-and-sorted-p)
+				       nil (and for-cache-p wrappers))
+		     (default-secondary-dispatch-function gf))))
+	(multiple-value-bind (index accessor-type)
+	    (and for-accessor-p all-applicable-and-sorted-p methods
+		 (accessor-values gf arg-info classes methods))
+	  (values (if (integerp index) index emf)
+		  methods accessor-type index))))))
+
+(defun accessor-values (gf arg-info classes methods)
+  (declare (ignore gf))
+  (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
+	 (accessor-class (case accessor-type
+			   (reader (car classes))
+			   (writer (cadr classes))
+			   (boundp (car classes)))))
+    (accessor-values-internal accessor-type accessor-class methods)))
+
+(defun accessor-values1 (gf accessor-type accessor-class)
+  (let* ((type `(class-eq ,accessor-class))
+	 (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
+	 (methods (compute-applicable-methods-using-types gf types)))
+    (accessor-values-internal accessor-type accessor-class methods)))
+
+(defun accessor-values-internal (accessor-type accessor-class methods)
+  (let* ((meth (car methods))
+	 (early-p (not (eq *boot-state* 'complete)))
+	 (slot-name (when accessor-class
+		      (if (consp meth)
+			  (and (early-method-standard-accessor-p meth)
+			       (early-method-standard-accessor-slot-name meth))
+			  (and (member *the-class-standard-object*
+				       (if early-p
+					   (early-class-precedence-list accessor-class)
+					   (class-precedence-list accessor-class)))
+			       (if early-p
+				   (not (eq *the-class-standard-method*
+					    (early-method-class meth)))
+				   (standard-accessor-method-p meth))
+			       (if early-p
+				   (early-accessor-method-slot-name meth)
+				   (accessor-method-slot-name meth))))))
+	 (slotd (and accessor-class
+		     (if early-p
+			 (dolist (slot (early-class-slotds accessor-class) nil)
+			   (when (eql slot-name (early-slot-definition-name slot))
+			     (return slot)))
+			 (find-slot-definition accessor-class slot-name)))))
+    (when (and slotd
+	       (or early-p
+		   (slot-accessor-std-p slotd accessor-type)))
+      (values (if early-p
+		  (early-slot-definition-location slotd) 
+		  (slot-definition-location slotd))
+	      accessor-type))))
+
+(defun make-accessor-table (gf type &optional table)
+  (unless table (setq table (make-hash-table :test 'eq)))
+  (let ((methods (if (early-gf-p gf)
+		     (early-gf-methods gf)
+		     (generic-function-methods gf)))
+	(all-index nil)
+	(no-class-slots-p t)
+	(early-p (not (eq *boot-state* 'complete)))
+	first second (size 0))
+    (declare (fixnum size))
+    ;; class -> {(specl slotd)}
+    (dolist (method methods)
+      (let* ((specializers (if (consp method)
+			       (early-method-specializers method t)
+			       (method-specializers method)))
+	     (specl (if (eq type 'reader)
+			(car specializers)
+			(cadr specializers)))
+	     (specl-cpl (if early-p
+			    (early-class-precedence-list specl)
+			    (and (class-finalized-p specl)
+				 (class-precedence-list specl))))
+	     (so-p (member *the-class-standard-object* specl-cpl))
+	     (slot-name (if (consp method)
+			    (and (early-method-standard-accessor-p method)
+				 (early-method-standard-accessor-slot-name method))
+			    (accessor-method-slot-name method))))
+	(when (or (null specl-cpl)
+		  (member *the-class-structure-object* specl-cpl))
+	  (return-from make-accessor-table nil))
+	(maphash #'(lambda (class slotd)
+		     (let ((cpl (if early-p
+				    (early-class-precedence-list class)
+				    (class-precedence-list class))))
+		       (when (memq specl cpl)
+			 (unless (and (or so-p
+					  (member *the-class-standard-object* cpl))
+				      (or early-p
+					  (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*))))
+    (maphash #'(lambda (class specl+slotd-list)
+		 (dolist (sclass (if early-p
+				    (early-class-precedence-list class)
+				    (class-precedence-list class)) 
+			  (error "This can't happen"))
+		   (let ((a (assq sclass specl+slotd-list)))
+		     (when a
+		       (let* ((slotd (cdr a))
+			      (index (if early-p
+					 (early-slot-definition-location slotd) 
+					 (slot-definition-location slotd))))
+			 (unless index (return-from make-accessor-table nil))
+			 (setf (gethash class table) index)
+			 (when (consp index) (setq no-class-slots-p nil))
+			 (setq all-index (if (or (null all-index)
+						 (eql all-index index))
+					     index t))
+			 (incf size)
+			 (cond ((= size 1) (setq first class))
+			       ((= size 2) (setq second class)))
+			 (return nil))))))
+	     table)
+    (values table all-index first second size no-class-slots-p)))
+
+(defun compute-applicable-methods-using-types (generic-function types)
+  (let ((definite-p t) (possibly-applicable-methods nil))
+    (dolist (method (if (early-gf-p generic-function)
+			(early-gf-methods generic-function)
+			(generic-function-methods generic-function)))
+      (let ((specls (if (consp method)
+			(early-method-specializers method t)
+			(method-specializers method)))
+	    (types types)
+	    (possibly-applicable-p t) (applicable-p t))
+	(dolist (specl specls)
+	  (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
+	      (specializer-applicable-using-type-p specl (pop types))
+	    (unless specl-applicable-p
+	      (setq applicable-p nil))
+	    (unless specl-possibly-applicable-p
+	      (setq possibly-applicable-p nil)
+	      (return nil))))
+	(when possibly-applicable-p
+	  (unless applicable-p (setq definite-p nil))
+	  (push method possibly-applicable-methods))))
+    (let ((precedence (arg-info-precedence (if (early-gf-p generic-function)
+					       (early-gf-arg-info generic-function)
+					       (gf-arg-info generic-function)))))
+      (values (sort-applicable-methods precedence
+				       (nreverse possibly-applicable-methods)
+				       types)
+	      definite-p))))
+
+(defun sort-applicable-methods (precedence methods types)
+  (sort-methods methods
+		precedence
+		#'(lambda (class1 class2 index)
+		    (let* ((class (type-class (nth index types)))
+			   (cpl (if (eq *boot-state* 'complete)
+				    (class-precedence-list class)
+				    (early-class-precedence-list class))))
+		      (if (memq class2 (memq class1 cpl))
+			  class1 class2)))))
+
+(defun sort-methods (methods precedence compare-classes-function)
+  (flet ((sorter (method1 method2)
+	   (dolist (index precedence)
+	     (let* ((specl1 (nth index (if (listp method1)
+					   (early-method-specializers method1 t)
+					   (method-specializers method1))))
+		    (specl2 (nth index (if (listp method2)
+					   (early-method-specializers method2 t)
+					   (method-specializers method2))))
+		    (order (order-specializers
+			     specl1 specl2 index compare-classes-function)))
+	       (when order
+		 (return-from sorter (eq order specl1)))))))
+    (stable-sort methods #'sorter)))
+
+(defun order-specializers (specl1 specl2 index compare-classes-function)
+  (let ((type1 (if (eq *boot-state* 'complete)
+		   (specializer-type specl1)
+		   (bootstrap-get-slot 'specializer specl1 'type)))
+	(type2 (if (eq *boot-state* 'complete)
+		   (specializer-type specl2)
+		   (bootstrap-get-slot 'specializer specl2 'type))))
+    (cond ((eq specl1 specl2)
+	   nil)
+	  ((atom type1)
+	   specl2)
+	  ((atom type2)
+	   specl1)
+	  (t
+	   (case (car type1)
+	     (class    (case (car type2)
+			 (class (funcall compare-classes-function specl1 specl2 index))
+			 (t specl2)))
+	     (prototype (case (car type2)
+			 (class (funcall compare-classes-function specl1 specl2 index))
+			 (t specl2)))
+	     (class-eq (case (car type2)
+			 (eql specl2)
+			 (class-eq nil)
+			 (class type1)))
+	     (eql      (case (car type2)
+			 (eql nil)
+			 (t specl1))))))))
+
+(defun map-all-orders (methods precedence function)
+  (let ((choices nil))
+    (flet ((compare-classes-function (class1 class2 index)
+	     (declare (ignore index))
+	     (let ((choice nil))
+	       (dolist (c choices nil)
+		 (when (or (and (eq (first c) class1)
+				(eq (second c) class2))
+			   (and (eq (first c) class2)
+				(eq (second c) class1)))
+		   (return (setq choice c))))
+	       (unless choice
+		 (setq choice
+		       (if (class-might-precede-p class1 class2)
+			   (if (class-might-precede-p class2 class1)
+			       (list class1 class2 nil t)
+			       (list class1 class2 t))
+			   (if (class-might-precede-p class2 class1)
+			       (list class2 class1 t)
+			       (let ((name1 (class-name class1))
+				     (name2 (class-name class2)))
+				 (if (and name1 name2 (symbolp name1) (symbolp name2)
+					  (string< (symbol-name name1)
+						   (symbol-name name2)))
+				     (list class1 class2 t)
+				     (list class2 class1 t))))))
+		 (push choice choices))
+	       (car choice))))
+      (loop (funcall function
+		     (sort-methods methods precedence #'compare-classes-function))
+	    (unless (dolist (c choices nil)
+		      (unless (third c)
+			(rotatef (car c) (cadr c))
+			(return (setf (third c) t))))
+	      (return nil))))))
+
+(defvar *in-precompute-effective-methods-p* nil)
+
+;used only in map-all-orders
+(defun class-might-precede-p (class1 class2)
+  (if (not *in-precompute-effective-methods-p*)
+      (not (member class1 (cdr (class-precedence-list class2))))
+      (class-can-precede-p class1 class2)))
+
+(defun compute-precedence (lambda-list nreq argument-precedence-order)
+  (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)))
+
+(defun saut-and (specl type)
+  (let ((applicable nil)
+	(possibly-applicable t))
+    (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)
+  (let ((ntype (cadr type)))
+    (values nil
+	    (case (car ntype)
+	      (class      (saut-not-class specl ntype))
+	      (class-eq   (saut-not-class-eq specl ntype))
+	      (prototype  (saut-not-prototype 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-prototype (specl ntype)
+  (let* ((class (case (car specl)
+		  (eql       (class-of (cadr specl)))
+		  (class-eq  (cadr specl))
+		  (prototype (cadr specl))
+		  (class     (cadr specl))))
+	 (cpl (class-precedence-list class)))
+     (not (memq (cadr ntype) cpl))))
+
+(defun saut-not-class-eq (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)
+  (case (car specl)
+    (eql (not (eql (cadr specl) (cadr ntype))))
+    (t   t)))
+
+(defun class-applicable-using-class-p (specl type)
+  (let ((pred (memq specl (if (eq *boot-state* 'complete)
+			      (class-precedence-list type)
+			      (early-class-precedence-list type)))))
+    (values pred
+	    (or pred
+		(if (not *in-precompute-effective-methods-p*)
+		    ;; classes might get common subclass
+		    (superclasses-compatible-p specl type)
+		    ;; worry only about existing classes
+		    (classes-have-common-subclass-p specl type))))))
+
+(defun classes-have-common-subclass-p (class1 class2)
+  (or (eq class1 class2)
+      (let ((class1-subs (class-direct-subclasses class1)))
+	(or (memq class2 class1-subs)
+	    (dolist (class1-sub class1-subs nil)
+	      (when (classes-have-common-subclass-p class1-sub class2)
+		(return t)))))))
+
+(defun saut-class (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)))))))
+
+(defun saut-class-eq (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)
+			       (if (eq *boot-state* 'complete)
+				   (class-precedence-list (cadr type))
+				   (early-class-precedence-list (cadr type)))))))))
+	(values pred pred))))
+
+(defun saut-prototype (specl type)
+  (declare (ignore specl type))
+  (values nil nil)) ; fix this someday
+
+(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)
+				  (let ((class (class-of (cadr type))))
+				    (if (eq *boot-state* 'complete)
+					(class-precedence-list class)
+					(early-class-precedence-list class))))))))
+    (values pred pred)))
+
+(defun specializer-applicable-using-type-p (specl type)
+  (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 (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))
+	(prototype  (saut-prototype 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)))))
+
+(defun map-all-classes (function &optional (root 't))
+  (let ((braid-p (or (eq *boot-state* 'braid)
+		     (eq *boot-state* 'complete))))
+    (labels ((do-class (class)
+	       (mapc #'do-class 
+		     (if braid-p
+			 (class-direct-subclasses class)
+			 (early-class-direct-subclasses class)))
+	       (funcall function class)))
+      (do-class (if (symbolp root)
+		    (find-class root)
+		    root)))))
+
+;;;
+;;; NOTE: We are assuming a restriction on user code that the method
+;;;       combination must not change once it is connected to the
+;;;       generic function.
+;;;
+;;;       This has to be legal, because otherwise any kind of method
+;;;       lookup caching couldn't work.  See this by saying that this
+;;;       cache, is just a backing cache for the fast cache.  If that
+;;;       cache is legal, this one must be too.
+;;;
+;;; 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 
+		     gf methods types
+		     (not (null method-alist))
+		     (not (null wrappers))
+		     (not (methods-contain-eql-specializer-p methods)))
+		    method-alist wrappers))
+
+(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p
+					    &optional all-applicable-p
+					    (all-sorted-p t) function-p)
+  (if (null methods)
+      #'(lambda (method-alist wrappers)
+	  (declare (ignore method-alist wrappers))
+	  #'(lambda (&rest args)
+	      (apply #'no-applicable-method gf args)))
+      (let* ((key (car methods))
+	     (ht-value (or (gethash key *effective-method-table*)
+			   (setf (gethash key *effective-method-table*)
+				 (cons nil nil)))))
+	(if (and (null (cdr methods)) all-applicable-p ; the most common case
+		 (null method-alist-p) wrappers-p (not function-p))
+	    (or (car ht-value)
+		(setf (car ht-value)
+		      (get-secondary-dispatch-function2 
+		       gf methods types method-alist-p wrappers-p
+		       all-applicable-p all-sorted-p function-p)))
+	    (let ((akey (list methods
+			      (if all-applicable-p 'all-applicable types)
+			      method-alist-p wrappers-p function-p)))
+	      (or (cdr (assoc akey (cdr ht-value) :test #'equal))
+		  (let ((value (get-secondary-dispatch-function2 
+				gf methods types method-alist-p wrappers-p
+				all-applicable-p all-sorted-p function-p)))
+		    (push (cons akey value) (cdr ht-value))
+		    value)))))))
+
+(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p
+					    all-applicable-p all-sorted-p function-p)
+  (if (and all-applicable-p all-sorted-p (not function-p))
+      (if (eq *boot-state* 'complete)
+	  (let* ((combin (generic-function-method-combination gf))
+		 (effective (compute-effective-method gf combin methods)))
+	    (make-effective-method-function1 gf effective method-alist-p wrappers-p))
+	  (let ((effective (standard-compute-effective-method gf nil methods)))
+	    (make-effective-method-function1 gf effective method-alist-p wrappers-p)))
+      (let ((net (generate-discrimination-net 
+		  gf methods types all-sorted-p)))
+	(compute-secondary-dispatch-function1 gf net function-p))))
+
+(defun get-effective-method-function (gf methods &optional method-alist wrappers)
+  (function-funcall (get-secondary-dispatch-function1 gf methods nil 
+						      (not (null method-alist))
+						      (not (null wrappers))
+						      t)
+		    method-alist wrappers))
+
+(defun get-effective-method-function1 (gf methods &optional (sorted-p t))
+  (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
+
+(defun methods-contain-eql-specializer-p (methods)
+  (and (eq *boot-state* 'complete)
+       (dolist (method methods nil)
+	 (when (dolist (spec (method-specializers method) nil)
+		 (when (eql-specializer-p spec) (return t)))
+	   (return t)))))
+
+(defun update-dfun (generic-function &optional dfun cache info)
+  (let* ((early-p (early-gf-p generic-function))
+	 (gf-name (if early-p
+		      (early-gf-name generic-function)
+		      (generic-function-name generic-function)))
+	 (ocache (gf-dfun-cache generic-function)))
+    (set-dfun generic-function dfun cache info)
+    (let* ((dfun (if early-p
+		     (or dfun (make-initial-dfun generic-function))
+		     (compute-discriminating-function generic-function)))
+	   (info (gf-dfun-info generic-function)))
+      (unless (eq 'default-method-only (type-of info))
+	(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))
+      dfun)))
 
+
 (defvar dfun-count nil)
 (defvar dfun-list nil)
 (defvar *minimum-cache-size-to-list*)
@@ -846,8 +1470,7 @@ And so, we are saved.
 	 (cache (gf-dfun-cache gf)))
     (when cache
       (let ((size (cache-size cache)))
-        (declare (type index size))
-	(when (>= size (the index *minimum-cache-size-to-list*))
+	(when (>= size *minimum-cache-size-to-list*)
 	  (let ((a (assoc size dfun-list)))
 	    (unless a
 	      (push (setq a (list size)) dfun-list))
@@ -869,13 +1492,13 @@ And so, we are saved.
 	 (a (assq sym dfun-count)))
     (unless a
       (push (setq a (list sym 0 nil)) dfun-count))
-    (setf (cadr a) (the index (1+ (the index (cadr a)))))
+    (incf (cadr a))
     (when cache
       (let* ((size (cache-size cache))
 	     (b (assoc size (third a))))
 	(unless b 
 	  (push (setq b (cons size 0)) (third a)))
-        (setf (cdr b) (the index (1+ (the index (cdr b)))))))))
+	(incf (cdr b))))))
 
 (defun count-all-dfuns ()
   (setq dfun-count (mapcar #'(lambda (type) (list type 0 nil))
diff --git a/pcl/dlap.lisp b/pcl/dlap.lisp
index 2627efef8..adb1f4abe 100644
--- a/pcl/dlap.lisp
+++ b/pcl/dlap.lisp
@@ -29,22 +29,26 @@
 
 
 
-(defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p))
-(defun emit-one-class-writer (class-slot-p) (emit-reader/writer :writer 1 class-slot-p))
+(defun emit-one-class-reader (class-slot-p)
+  (emit-reader/writer :reader 1 class-slot-p))
 
-(defun emit-two-class-reader (class-slot-p) (emit-reader/writer :reader 2 class-slot-p))
-(defun emit-two-class-writer (class-slot-p) (emit-reader/writer :writer 2 class-slot-p))
+(defun emit-one-class-writer (class-slot-p)
+  (emit-reader/writer :writer 1 class-slot-p))
+
+(defun emit-two-class-reader (class-slot-p)
+  (emit-reader/writer :reader 2 class-slot-p))
+
+(defun emit-two-class-writer (class-slot-p)
+  (emit-reader/writer :writer 2 class-slot-p))
 
 
 
 (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 ())
-	(field (first-wrapper-cache-number-index)))			   ;we need some field to do
-								   ;the fast obsolete check
+	(field (first-wrapper-cache-number-index))) 
+    ;;we need some field to do the fast obsolete check
     (ecase reader/writer
       (:reader (setq instance (dfun-arg-symbol 0)
 		     arglist  (list instance)))
@@ -64,27 +68,16 @@
 								   ;for different values at
 								   ;different times.
 		(slots (and (null class-slot-p)
-			    (allocate-register 'vector)))
+			    (allocate-register #-new-kcl-wrapper 'vector
+					       #+new-kcl-wrapper t)))
 		(csv   (and class-slot-p
 			    (allocate-register t))))
 	    (prog1 (flatten-lap
 		     (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
@@ -129,11 +122,10 @@
 
 
 (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
-      (with-lap-registers ((slots vector))
+      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t))
 	(emit-dlap  arglist
 		    '(standard-instance)
 		    'trap
@@ -150,11 +142,10 @@
 		    (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
-      (with-lap-registers ((slots vector))
+      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t))
 	(emit-dlap arglist
 		   '(t standard-instance)
 		   'trap
@@ -176,7 +167,7 @@
   (let ((arglist (list (dfun-arg-symbol 0))))
     (generating-lap '(field cache-vector mask size miss-fn)
 		    arglist
-      (with-lap-registers ((slots vector)
+      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)
 			   (index index))
 	(emit-dlap arglist
 		   '(standard-instance)
@@ -192,7 +183,7 @@
   (let ((arglist (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))))
     (generating-lap '(field cache-vector mask size miss-fn)
 		    arglist
-      (with-lap-registers ((slots vector)
+      (with-lap-registers ((slots #-new-kcl-wrapper vector #+new-kcl-wrapper t)
 			   (index index))
 	(flatten-lap
 	  (emit-dlap arglist
@@ -209,15 +200,21 @@
 
 (defun emit-checking (metatypes applyp)
   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
-    (generating-lap '(field cache-vector mask size function miss-fn)
+    (generating-lap '(field cache-vector mask size 
+		      #-excl-sun4 emf #+excl-sun4 function 
+		      miss-fn)
 		    dlap-lambda-list
       (emit-dlap (remove '&rest dlap-lambda-list)
 		 metatypes		 
 		 'trap
-		 (with-lap-registers ((function t))
+		 (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t))
 		   (flatten-lap
-		     (opcode :move (operand :cvar 'function) function)
-		     (opcode :jmp function)))
+		     (opcode :move (operand :cvar 
+					    #-excl-sun4 'emf #+excl-sun4 'function)
+			     #-excl-sun4 emf 
+			     #+excl-sun4 function)
+		     #-excl-sun4 (opcode :emf-call emf)
+		     #+excl-sun4 (opcode :jmp function)))
 		 (with-lap-registers ((miss-function t))
 		   (flatten-lap
 		     (opcode :label 'trap)
@@ -229,17 +226,19 @@
   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
     (generating-lap '(field cache-vector mask size miss-fn)
 		    dlap-lambda-list
-      (with-lap-registers ((function t))
+      (with-lap-registers ((#-excl-sun4 emf #+excl-sun4 function t))
 	(emit-dlap (remove '&rest dlap-lambda-list)
 		   metatypes
 		   'trap
-		   (flatten-lap (opcode :jmp function))
+		   (flatten-lap
+		    #-excl-sun4 (opcode :emf-call emf)
+		    #+excl-sun4 (opcode :jmp function))
 		   (with-lap-registers ((miss-function t))
 		     (flatten-lap
 		       (opcode :label 'trap)
 		       (opcode :move (operand :cvar 'miss-fn) miss-function)
 		       (opcode :jmp miss-function)))
-		   function)))))
+		   #-excl-sun4 emf #+excl-sun4 function)))))
 
 (defun emit-constant-value (metatypes)
   (let ((dlap-lambda-list (make-dlap-lambda-list metatypes nil)))
@@ -249,7 +248,7 @@
 	(emit-dlap dlap-lambda-list
 		   metatypes
 		   'trap
-		   (flatten-lap 
+		   (flatten-lap
 		     (opcode :return value))
 		   (with-lap-registers ((miss-function t))
 		     (flatten-lap
@@ -281,7 +280,7 @@
   (let ((slot-unbound (operand :constant *slot-unbound*)))
     (with-lap-registers ((val t :reuse temp))
       (flatten-lap
-	(opcode :move (operand :iref slots index) val)		;get slot value
+	(opcode :move (operand :instance-ref slots index) val)  ;get slot value
 	(opcode :eq val slot-unbound trap-label)		;is the slot unbound?
 	(opcode :return val)))))				;return the slot value
 
@@ -289,7 +288,7 @@
   (with-lap-registers ((new-val t :reuse temp))
     (flatten-lap
       (opcode :move (operand :arg new-value-arg) new-val)	;get new value into a reg
-      (opcode :move new-val (operand :iref slots index))	;set slot value
+      (opcode :move new-val (operand :instance-ref slots index));set slot value
       (opcode :return new-val))))
 
 (defun emit-get-class-slot (index trap-label &optional temp)
@@ -430,12 +429,7 @@
       hit)))
 
 (defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
-  (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))
+  (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
     (with-lap-registers ((location index)
 			 (primary index)
 			 (cache-vector vector)
@@ -530,6 +524,116 @@
     (opcode :move (operand :constant (index-value->index 1)) location)
     (opcode :go cont-label)))
      
+
+;; From cache.lisp
+(defun emit-cache-vector-ref (cache-vector-operand location-operand)
+  (operand :iref cache-vector-operand location-operand))
+
+(defun emit-wrapper-ref (wrapper-operand field-operand)
+  (operand :iref wrapper-operand field-operand))
 
+(defun emit-wrapper-cache-number-vector (wrapper-operand)
+  (operand :wrapper-cache-number-vector wrapper-operand))
 
+(defun emit-cache-number-vector-ref (cnv-operand field-operand)
+  (operand :iref cnv-operand field-operand))
+
+(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no)
+  (with-lap-registers ((mask index) 
+		       #+structure-wrapper (cnv fixnum-vector))
+    (let ((field wrapper-cache-no))
+      (flatten-lap
+        (opcode :move (operand :cvar 'mask) mask)
+        (opcode :move (operand :cvar 'field) field)
+	#-structure-wrapper
+        (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+	#+structure-wrapper
+	(opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
+	#+structure-wrapper
+	(opcode :move (emit-cache-number-vector-ref cnv field) wrapper-cache-no)
+        (opcode :move (operand :ilogand wrapper-cache-no mask) primary)))))
+
+(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label)
+  (with-lap-registers ((field index)
+		       (mask index))
+    (let ((add-wrapper-cache-numbers
+	   (flatten-lap
+	    (gathering1 (flattening-lap)
+	       (iterate ((wrapper (list-elements wrappers))
+			 (i (interval :from 1)))
+		 (gather1
+		  (with-lap-registers ((wrapper-cache-no index)
+				       #+structure-wrapper (cnv fixnum-vector))
+		    (flatten-lap
+		     #-structure-wrapper
+		     (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no)
+		     #+structure-wrapper
+		     (opcode :move (emit-wrapper-cache-number-vector wrapper) cnv)
+		     #+structure-wrapper
+		     (opcode :move (emit-cache-number-vector-ref cnv field)
+			     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))
+		       (opcode :move (operand :ilogand primary mask) primary))))))))))
+      (flatten-lap
+       (opcode :move (operand :constant 0) primary)
+       (opcode :move (operand :cvar 'field) field)
+       (opcode :move (operand :cvar 'mask) mask)
+       add-wrapper-cache-numbers
+       (opcode :move (operand :ilogand primary mask) primary)
+       (opcode :move (operand :i1+ primary) primary)))))
+
+(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot)
+  (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper")))
+    (with-lap-registers ((arg t))
+      (ecase metatype
+	((standard-instance #+new-kcl-wrapper structure-instance)
+	  (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper"))
+		(get-fsc-inst-wrapper (make-symbol "get-fsc-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?
+	      (opcode :go miss-label)
+	      (opcode :label get-fsc-inst-wrapper)
+	      (opcode :move (operand :fsc-wrapper arg) dest)	   ;get fsc wrapper
+	      (and slot
+		   (opcode :move (operand :fsc-slots arg) slot))
+	      (opcode :go exit-emit-fetch-wrapper)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)	   ;get std wrapper
+	      (and slot
+		   (opcode :move (operand :std-slots arg) slot))
+	      (opcode :label exit-emit-fetch-wrapper))))
+	(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")))
+	    (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)
+	      #-new-kcl-wrapper
+	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
+	      #+new-kcl-wrapper
+	      (opcode :move (operand :built-in-wrapper arg) dest)
+	      (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)
+	      (opcode :label get-std-inst-wrapper)
+	      (opcode :move (operand :std-wrapper arg) dest)
+	      (opcode :label exit-emit-fetch-wrapper))))
+	((built-in-instance #-new-kcl-wrapper structure-instance)
+	  (when slot (error "Can't do a slot reg for this metatype."))
+	  (let ()
+	    (flatten-lap
+	      (opcode :move (operand :arg argument) arg)
+	      (opcode :std-instance-p arg miss-label)
+	      (opcode :fsc-instance-p arg miss-label)
+	      #-new-kcl-wrapper
+	      (opcode :move (operand :built-in-or-structure-wrapper arg) dest)
+	      #+new-kcl-wrapper
+	      (opcode :move (operand :built-in-wrapper arg) dest))))))))
 
diff --git a/pcl/env.lisp b/pcl/env.lisp
index 336fd6893..524055f73 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,176 +68,157 @@
 
 (defmethod describe-object (object stream)
   (let ((*standard-output* stream))
-    (funcall-compiled (original-definition 'describe) object)))
+    (cond ((or #+kcl (packagep object))
+	   (describe-package object stream))
+	  (t
+	   (funcall (original-definition 'describe) object)))))
 
 (redefine-function 'describe 'pcl-describe)
 
 )
 
 (defmethod describe-object ((object slot-object) stream)
-  (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))
+  (let* ((class (class-of object))
+	 (slotds (slots-to-inspect class object))
+	 (max-slot-name-length 0)
+	 (instance-slotds ())
+	 (class-slotds ())
+	 (other-slotds ()))
     (flet ((adjust-slot-name-length (name)
-             (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)))
-
+	     (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))))
       ;; Figure out a good width for the slot-name column.
-      (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)))
+      (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)
 
       (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)
+(defvar *describe-metaobjects-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))
-  (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)))))
+  (format stream "Its methods are:")
+  (dolist (meth (generic-function-methods fun))
+    (format stream "~2%    ~{~S ~}~:S =>~%"
+            (method-qualifiers meth)
+            (unparse-specializers meth))
+    (describe-object (or (method-fast-function meth)
+			 (method-function meth))
+		     stream))
+  (when *describe-metaobjects-as-objects-p*
+    (call-next-method)))
 
 ;;;
 ;;;
 ;;;
-(defvar *describe-classes-as-objects-p* nil)
-
 (defmethod describe-object ((class class) stream)
   (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.  "
-          (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*
-    (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))))))
+           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)))))
+  (when *describe-metaobjects-as-objects-p*
+    (call-next-method)))
+
+(defun describe-package (object stream)
+  (unless (packagep object) (setq object (find-package object)))
+  (format stream "~&~S is a ~S.~%" object (type-of object))
+  (let ((nick (package-nicknames object)))
+    (when nick
+      (format stream "You can also call it~@[ ~{~S~^, ~} or~] ~S.~%"
+	      (butlast nick) (first (last nick)))))  
+  (let* (#+cmu (internal (lisp::package-internal-symbols object))
+	 (internal-count #+cmu (- (lisp::package-hashtable-size internal)
+				  (lisp::package-hashtable-free internal))
+			 #-cmu 0)
+	 #+cmu (external (lisp::package-external-symbols object))
+	 (external-count #+cmu (- (lisp::package-hashtable-size external)
+				  (lisp::package-hashtable-free external))
+			 #-cmu 0))
+    #-cmu (do-external-symbols (sym object)
+	    (declare (ignore sym))
+	    (incf external-count))
+    #-cmu (do-symbols (sym object)
+	    (declare (ignore sym))
+	    (incf internal-count))
+    #-cmu (decf internal-count external-count)
+    (format stream "It has ~D internal and ~D external symbols (~D total).~%"
+	    internal-count external-count (+ internal-count external-count)))
+  (let ((used (package-use-list object)))
+    (when used
+      (format stream "It uses the packages ~{~S~^, ~}.~%"
+	      (mapcar #'package-name used))))
+  (let ((users (package-use-list object)))
+    (when users
+      (format stream "It is used by the packages ~{~S~^, ~}.~%"
+	      (mapcar #'package-name users)))))
+
+#+cmu
+(defmethod describe-object ((object package) stream)
+  (describe-package object stream))
 
+#+cmu
+(defmethod describe-object ((object hash-table) stream)
+  (format stream "~&~S is an ~a hash table." object (lisp::hash-table-kind object))
+  (format stream "~&Its size is ~d buckets." (lisp::hash-table-size object))
+  (format stream "~&Its rehash-size is ~d." (lisp::hash-table-rehash-size object))
+  (format stream "~&Its rehash-threshold is ~d."
+	  (lisp::hash-table-rehash-threshold object))
+  (format stream "~&It currently holds ~d entries."
+	  (lisp::hash-table-number-entries object)))
+
+
+
 ;;;
 ;;; trace-method and untrace-method accept method specs as arguments.  A
 ;;; method-spec should be a list like:
@@ -259,119 +240,63 @@
 ;;; 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)))
 
-(defclass traced-method (standard-method)
-     ((method :initarg :method)))
+(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 accessor-method-slot-name ((m traced-method))
+  (with-slots (method) m (accessor-method-slot-name method)))
 
 (defvar *traced-methods* ())
 
-(defmethod trace-method ((spec cons) &rest options)
-  (multiple-value-bind (gf method name)
+(defun trace-method (spec &rest options)
+  (multiple-value-bind (gf omethod name)
       (parse-method-or-spec spec)
-    (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))
+    (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)))
 
 (defun untrace-method (&optional spec)  
-  (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)
+  (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)
   (eval `(untrace ,name))
-  (setf (symbol-function name) function)
+  (setf (symbol-function name) ofunction)
   (eval `(trace ,name ,@options))
-  name)
-
-(defun untrace-method-function-names (names)
-  (dolist (name names)
-    (setf (symbol-function name) NIL))
-  (eval `(untrace ,@names)))
+  (symbol-function name))
 
-(defun trace-methods (gf)
-  (let ((methods (generic-function-methods gf)))
-    (dolist (method methods)
-      (trace-method method))
-    methods))
 
 
 
@@ -398,9 +323,3 @@
 (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 a0361c485..54c734b4d 100644
--- a/pcl/excl-low.lisp
+++ b/pcl/excl-low.lisp
@@ -43,10 +43,6 @@
 		  '(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)
@@ -67,12 +63,6 @@
 		  (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
@@ -86,6 +76,13 @@
 	    (declare #.*optimize-speed*)
 	    (eq (svref ,x 0) 'std-instance)))))
 
+(excl::defcmacro fast-method-call-p (x)
+  (once-only (x)
+    `(and (excl::structurep ,x)
+	  (locally
+	    (declare #.*optimize-speed*)
+	    (eq (svref ,x 0) 'fast-method-call)))))
+
 (defmacro %std-instance-wrapper (x)
   `(svref ,x 1))
 
@@ -124,32 +121,16 @@
 
 ;;; Define inspector hooks for PCL object instances.
 
-;;; Due to metacircularity certain slots of metaclasses do not have normal
-;;; accessors, and for now we just make them uninspectable.  They could be
-;;; special cased some day.
-
 (defun (:property pcl::std-instance :inspector-function) (object)
-  (do* ((class (class-of object))
-	(components (class-precedence-list class))
-	(desc (list (inspect::make-field-def "class" #'class-of :lisp)))
-	(slots (slots-to-inspect class object) (cdr slots)))
-       ((null slots) (nreverse desc))
-    (let ((name (slot-definition-name (car slots)))
-	  res)
-      (push (inspect::make-field-def
-	     (string name)
-	     (or (block foo
-		   (dolist (comp components)
-		     (dolist (slot (class-direct-slots comp))
-		       (and (eq (slot-definition-name slot) name)
-			    (setq res (first (slot-definition-readers slot)))
-			    (return-from foo res)))))
-		 #'(lambda (x) 
-		     (declare (ignore x))
-		     :|Uninspectable Metaclass Slot|))
-	     :lisp)
-	    desc))))
+  (let ((class (class-of object)))
+    (cons (inspect::make-field-def "class" #'class-of :lisp)
+	  (mapcar #'(lambda (slot)
+		      (inspect::make-field-def
+		       (string (slot-definition-name slot))
+		       #'(lambda (x)
+			   (slot-value-using-class class x slot))
+		       :lisp))
+		  (slots-to-inspect class object)))))
 
 (defun (:property pcl::std-instance :inspector-type-function) (x)
   (class-name (class-of x)))
-
diff --git a/pcl/fin.lisp b/pcl/fin.lisp
index 645ad85e5..05539d32e 100644
--- a/pcl/fin.lisp
+++ b/pcl/fin.lisp
@@ -129,8 +129,6 @@ 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
@@ -160,7 +158,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)(compilation-speed 0)(space 0)))
+  (declare (optimize (speed 3) (safety 0)))
   #'(lambda (&rest args)
       (apply function args)))
 
@@ -170,17 +168,16 @@ 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 (type index ncodes))
+    (declare (fixnum ncodes))
     (do ((l codes (cdr l))
-	 (i 0 (the index (1+ i))))
+	 (i 0 (1+ i)))
 	((null l) nil)
-      (declare (type index i))
+      (declare (fixnum i))
       (setf (lucid::code-ref code-vec i) (car l)))
     code-vec))
 
@@ -224,10 +221,8 @@ 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 (the index
-                         (expt 2 (the index
-                                      procedure-is-funcallable-instance-bit-position)))
-		    (the index
+	    (logior (expt 2 procedure-is-funcallable-instance-bit-position)
+		    (the fixnum
 			 (lucid::procedure-ref x lucid::procedure-flags))))))
 
 
@@ -238,13 +233,13 @@ explicitly marked saying who wrote it.
                                                 ;incorrectly
   (let ((new-fin (lucid::new-procedure fin-size))
 	(fin-index fin-size))
-    (declare (type index fin-index)
+    (declare (fixnum fin-index)
 	     (type lucid::procedure new-fin))
-    (dotimes (i (length (the list funcallable-instance-data)) )
+    (dotimes (i (length 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.
-      (setf fin-index (the index (1- fin-index)))
+      (decf fin-index)
       (setf (lucid::procedure-ref new-fin fin-index) nil))
     ;;
     ;; "Assemble" the initial function by installing a fast "trampoline" code;
@@ -257,7 +252,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) 
-		   (the index call-arguments-limit)))
+		   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)
@@ -283,10 +278,10 @@ explicitly marked saying who wrote it.
 (defmacro funcallable-instance-data-1 (instance data)
   `(lucid::procedure-ref 
 	   ,instance
-	   (the index
-		(- (the index (- (the index fin-size) 1))
-		   (the index (funcallable-instance-data-position ,data))))))
-
+	   (the fixnum
+		(- (- fin-size 1)
+		   (the fixnum (funcallable-instance-data-position ,data))))))
+  
 );end of #+Lucid
 
 
@@ -362,7 +357,7 @@ explicitly marked saying who wrote it.
                                             (make-trampoline new-value)))))
 
 (defun make-trampoline (function)
-  (declare #.*optimize-speed*)
+  (declare (optimize (speed 3) (safety 0)))
   #'(lambda (&rest args)
       #+Genera (declare (dbg:invisible-frame :pcl-internals))
       (apply function args)))
@@ -886,7 +881,7 @@ dbg:
 ;; This function is never linked in and never appears on the stack.
 
 (defun funcallable-instance-mattress-pad ()
-  (declare #.*optimize-speed*)
+  (declare (optimize (speed 3) (safety 0)))
   'nil)
 
 (eval-when (eval)
@@ -1077,7 +1072,7 @@ dbg:
 ;; This function is never linked in and never appears on the stack.
 
 (defun funcallable-instance-mattress-pad ()
-  (declare #.*optimize-speed*)
+  (declare (optimize (speed 3) (safety 0)))
   'nil)
 
 (eval-when (eval)
@@ -1166,19 +1161,17 @@ 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 (the simple-vector cvec))) (t 0)))
+  (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
          (ndata (length funcallable-instance-data))
-         (old-cvec-length (if old-cvec (length (the simple-vector old-cvec)) 0))
+         (old-cvec-length (if old-cvec (length old-cvec) 0))
          (new-cvec nil))
-    (declare (fixnum nconstants ndate old-cvec-length))
-    (cond ((<= (the fixnum (+ nconstants ndata))  old-cvec-length)
+    (cond ((<= (+ nconstants ndata)  old-cvec-length)
            (setq new-cvec old-cvec))
           (t
-           (setq new-cvec (make-array (the fixnum (+ nconstants ndata))))
+           (setq new-cvec (make-array (+ nconstants ndata)))
            (when old-cvec
              (dotimes (i ndata)
-               (declare (fixnum i))
-               (setf (svref new-cvec (- (the fixnum (+ nconstants ndata)) i 1))
+               (setf (svref new-cvec (- (+ nconstants ndata) i 1))
                      (svref old-cvec (- old-cvec-length i 1)))))))
     
     (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))
@@ -1187,11 +1180,8 @@ dbg:
 
 (defun funcallable-instance-data-1 (instance data)
   (let ((constant (excl::fn_constant instance)))
-    (declare (simple-vector constant))
-    (svref constant (- (the fixnum (length constant))
-                       (the fixnum
-                            (1+ (the fixnum
-                                     (funcallable-instance-data-position data))))))))
+    (svref constant (- (length constant)
+                       (1+ (funcallable-instance-data-position data))))))
 
 (defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)
 
@@ -1367,9 +1357,9 @@ dbg:
 (defmacro funcallable-instance-data-1 (fin slot)
   (if (constantp slot)
       `(sys:%primitive c:closure-ref ,fin
-                       (+ (or (position ,slot funcallable-instance-data)
-                              (error "Unknown slot: ~S." ,slot))
-                          fin-data-offset))
+                       ,(+ (or (position (eval slot) funcallable-instance-data)
+                               (error "Unknown slot: ~S." (eval slot)))
+                           fin-data-offset))
       (ext:once-only ((n-slot slot))
         `(kernel:%closure-index-ref
           ,fin
@@ -1384,9 +1374,13 @@ dbg:
     `(progn
        (kernel:%set-funcallable-instance-info
         ,n-fin
-        (+ (or (position ,n-slot funcallable-instance-data)
-               (error "Unknown slot: ~S." ,n-slot))
-           fin-data-offset)
+	,(if (constantp slot)
+	     (+ (or (position (eval slot) funcallable-instance-data)
+		    (error "Unknown slot: ~S." (eval slot)))
+		fin-data-offset)
+	     `(+ (or (position ,n-slot funcallable-instance-data)
+		     (error "Unknown slot: ~S." ,n-slot))
+		 fin-data-offset))
         ,n-val)
        ,n-val)))
 ;;;
@@ -1452,8 +1446,8 @@ dbg:
         ((not (functionp new-value))
          (error "~S is not a function." new-value))
         ((and (cclosurep new-value)
-              (<= (the index (length (the list (%cclosure-env new-value))))
-                  (the index funcallable-instance-available-size)))
+              (<= (length (%cclosure-env new-value))
+                  funcallable-instance-available-size))
          (%set-cclosure fin new-value funcallable-instance-available-size))
         (t
          (set-funcallable-instance-function
@@ -1466,14 +1460,12 @@ dbg:
   (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
                                 env))
          (index-form (if (constantp pos-form)
-                         (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)))))
+                         (- funcallable-instance-closure-size
+                            (eval pos-form)
+                            2)
+                         `(- funcallable-instance-closure-size
+                             (funcallable-instance-data-position ,data)
+                             2))))
     `(car (%cclosure-env-nthcdr ,index-form ,fin))))
 
 
@@ -1966,13 +1958,5 @@ make_turbo_trampoline_internal(base0)
 (defmacro fsc-instance-slots (fin)
   `(funcallable-instance-data-1 ,fin '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
-            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 2ca36d380..aecddc5b3 100644
--- a/pcl/fixup.lisp
+++ b/pcl/fixup.lisp
@@ -38,4 +38,3 @@
   (declare (ignore depth))
   (print-object instance stream))
 
-
diff --git a/pcl/fngen.lisp b/pcl/fngen.lisp
index d5e97c8a5..e54dad9b3 100644
--- a/pcl/fngen.lisp
+++ b/pcl/fngen.lisp
@@ -28,11 +28,26 @@
 (in-package 'pcl)
 
 ;;;
-;;; GET-FUNCTION is the main user interface to this code.  If it is called
-;;; with a lambda expression only, it will return a corresponding function.
-;;; The optional constant-converter argument, can be a function which will
-;;; be called to convert each constant appearing in the lambda to whatever
-;;; value should appear in the function.
+;;; GET-FUNCTION is the main user interface to this code. It is like
+;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by 
+;;; reducing the number of times that the compiler needs to be called.  
+;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants 
+;;; can use the same piece of compiled code.  (For example, dispatch dfuns and 
+;;; combined method functions can often be shared, if they differ only 
+;;; by referring to different methods.)
+;;;
+;;; If GET-FUNCTION is called with a lambda expression only, it will return 
+;;; a corresponding function. The optional constant-converter argument
+;;; can be a function which will be called to convert each constant appearing
+;;; in the lambda to whatever value should appear in the function.
+;;;
+;;; There are three internal functions which operate on the lambda argument 
+;;; to GET-FUNCTION:
+;;;   compute-test converts the lambda into a key to be used for lookup,
+;;;   compute-code is used by get-new-function-generator-internal to
+;;;                generate the actual lambda to be compiled, and
+;;;   compute-constants is used to generate the argument list that is
+;;;                to be passed to the compiled function.
 ;;;
 ;;; Whether the returned function is actually compiled depends on whether
 ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
@@ -42,33 +57,29 @@
 		      &optional (test-converter     #'default-test-converter)
 		                (code-converter     #'default-code-converter)
 				(constant-converter #'default-constant-converter))
-  (apply-function (get-function-generator lambda test-converter code-converter)
+  (function-apply (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)
   (and (constantp form)
-       (not (symbolp (eval form)))))
+       (not (typep (eval form) '(or symbol fixnum)))))
 
 (defun default-test-converter (form)
   (if (default-constantp form)
       '.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)))
-      (values form nil)))
+      form))
 
 (defun default-constant-converter (form)
   (if (default-constantp form)
@@ -84,7 +95,12 @@
 (defvar *fgens* ())
 
 (defun store-fgen (fgen)
-  (setq *fgens* (nconc *fgens* (list fgen))))
+  (let ((old (lookup-fgen (fgen-test fgen))))
+    (if old
+	(setf (svref old 2) (fgen-generator fgen)
+	      (svref old 4) (or (svref old 4)
+				(fgen-system fgen)))
+	(setq *fgens* (nconc *fgens* (list fgen))))))
 
 (defun lookup-fgen (test)
   (find test (the list *fgens*) :key #'fgen-test :test #'equal))
@@ -113,10 +129,6 @@
 	(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)
@@ -180,20 +192,22 @@
 ;;;
 ;;;
 (defmacro precompile-function-generators (&optional system)
-  (make-top-level-form `(precompile-function-generators ,system)
-		       '(load)
+  (let ((index -1))
     `(progn ,@(gathering1 (collecting)
 		(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)
-		       ',(fgen-gensyms fgen)
-		       (function ,(fgen-generator-lambda fgen))
-		       ',(fgen-generator-lambda fgen)
-		       ',system))))))))
+		     (make-top-level-form
+		      `(precompile-function-generators ,system ,(incf index))
+		      '(load)
+		      `(load-function-generator
+			',(fgen-test fgen)
+			',(fgen-gensyms fgen)
+			(function ,(fgen-generator-lambda fgen))
+			',(fgen-generator-lambda fgen)
+			',system)))))))))
 
 (defun load-function-generator (test gensyms generator generator-lambda system)
   (store-fgen (make-fgen test gensyms generator generator-lambda system)))
diff --git a/pcl/fsc.lisp b/pcl/fsc.lisp
index d2f3ab7ec..1a68a86d5 100644
--- a/pcl/fsc.lisp
+++ b/pcl/fsc.lisp
@@ -47,7 +47,7 @@
   'fsc-instance-slots)
 
 (defmethod raw-instance-allocator ((class funcallable-standard-class))
-  'allocate-funcallable-instance-1)
+  'allocate-funcallable-instance)
 
 ;;;
 ;;;
@@ -63,48 +63,15 @@
 	   ((class funcallable-standard-class) &rest initargs)
   (declare (ignore initargs))
   (unless (class-finalized-p class) (finalize-inheritance class))
-  (let ((class-wrapper (class-wrapper class)))
-    (allocate-funcallable-instance
-      class-wrapper (wrapper-allocate-static-slot-storage-copy class-wrapper))))
+  (allocate-funcallable-instance (class-wrapper class)))
 
-(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-reader-method-function ((class funcallable-standard-class)
+					slot-name)
+  (make-std-reader-method-function (class-name class) 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)))
+(defmethod make-writer-method-function ((class funcallable-standard-class)
+					slot-name)
+  (make-std-writer-method-function (class-name class) slot-name))
 
 ;;;;
 ;;;; See the comment about reader-function--std and writer-function--sdt.
diff --git a/pcl/genera-low.lisp b/pcl/genera-low.lisp
index 90f94b0de..71c939d13 100644
--- a/pcl/genera-low.lisp
+++ b/pcl/genera-low.lisp
@@ -274,7 +274,7 @@ compiler::
 		    specializers
 		    lambda-list
 		    doc
-		    (getf plist :isl-cache-symbol)
+		    (getf plist :pv-table-cache-symbol)
 		    plist
 		    fn)))
 ||#
diff --git a/pcl/generic-functions.lisp b/pcl/generic-functions.lisp
index 74b2b47b7..8b02e13b1 100644
--- a/pcl/generic-functions.lisp
+++ b/pcl/generic-functions.lisp
@@ -2,314 +2,776 @@
 
 (in-package :pcl)
 
-;;; 1 arguments 
-(defgeneric accessor-method-slot-definition (method))
-(defgeneric accessor-method-slot-name (standard-accessor-method))
-(defgeneric |BUILT-IN-CLASS class predicate| (object))
-(defgeneric class-cached-in-generic-functions (pcl-class))
+;;; class predicates
+(defgeneric class-eq-specializer-p (object))
+;          (t)
+;          (class-eq-specializer)
+
+(defgeneric classp (object))
+;          (t)
+;          (class)
+
+(defgeneric eql-specializer-p (object))
+;          (t)
+;          (eql-specializer)
+
+(defgeneric exact-class-specializer-p (object))
+;          (t)
+;          (exact-class-specializer)
+
+(defgeneric forward-referenced-class-p (object))
+;          (t)
+;          (forward-referenced-class)
+
+(defgeneric funcallable-standard-class-p (object))
+;          (t)
+;          (funcallable-standard-class)
+
+(defgeneric generic-function-p (object))
+;          (t)
+;          (generic-function)
+
+(defgeneric legal-lambda-list-p (object x))
+;          (standard-method t)
+
+(defgeneric method-combination-p (object))
+;          (t)
+;          (method-combination)
+
+(defgeneric method-p (object))
+;          (t)
+;          (method)
+
+(defgeneric short-method-combination-p (object))
+;          (short-method-combination)
+;          (t)
+
+(defgeneric slot-class-p (object))
+;          (t)
+;          (slot-class)
+
+(defgeneric specializerp (object))
+;          (t)
+;          (specializer)
+
+(defgeneric standard-accessor-method-p (object))
+;          (t)
+;          (standard-accessor-method)
+
+(defgeneric standard-boundp-method-p (object))
+;          (t)
+;          (standard-boundp-method)
+
+(defgeneric standard-class-p (object))
+;          (t)
+;          (standard-class)
+
+(defgeneric standard-generic-function-p (object))
+;          (t)
+;          (standard-generic-function)
+
+(defgeneric standard-method-p (object))
+;          (t)
+;          (standard-method)
+
+(defgeneric standard-reader-method-p (object))
+;          (t)
+;          (standard-reader-method)
+
+(defgeneric standard-writer-method-p (object))
+;          (t)
+;          (standard-writer-method)
+
+(defgeneric structure-class-p (object))
+;          (t)
+;          (structure-class)
+
+
+;;; readers
+(defgeneric accessor-method-slot-definition (standard-accessor-method))
+;          (standard-accessor-method)
+
 (defgeneric class-can-precede-list (pcl-class))
-(defgeneric class-constructors (class))
-(defgeneric class-default-initargs (class))
-(defgeneric class-defstruct-conc-name (structure-class))
+;          (pcl-class)
+
 (defgeneric class-defstruct-constructor (structure-class))
-(defgeneric class-direct-default-initargs (class))
-(defgeneric class-direct-slots (class))
+;          (structure-class)
+
+(defgeneric class-defstruct-form (structure-class))
+;          (structure-class)
+
 (defgeneric class-direct-subclasses (class))
+;          (class)
+
 (defgeneric class-direct-superclasses (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))
+;          (class)
+
+(defgeneric class-eq-specializer (class))
+;          (class)
+
 (defgeneric class-incompatible-superclass-list (pcl-class))
-(defgeneric class-internal-slotds (pcl-class))
+;          (pcl-class)
+
+(defgeneric class-initialize-info (slot-class))
+;          (slot-class)
+
 (defgeneric class-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))
+;          (class)
+
+(defgeneric class-precedence-list (pcl-class))
+;          (pcl-class)
+
+(defgeneric class-predicate-name (class))
+;          (class)
+
 (defgeneric class-wrapper (pcl-class))
-(defgeneric classp (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 constructor-class (constructor))
-(defgeneric constructor-code-generators (constructor))
-(defgeneric constructor-code-type (constructor))
-(defgeneric constructor-name (constructor))
-(defgeneric constructor-supplied-initarg-names (constructor))
+;          (pcl-class)
+
 (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))
-(defgeneric |EFFECTIVE-SLOT-DEFINITION class predicate| (object))
+;          (definition-source-mixin)
+
 (defgeneric eql-specializer-object (eql-specializer))
-(defgeneric eql-specializer-p (object))
-(defgeneric exact-class-specializer-p (object))
-(defgeneric finalize-inheritance (class))
-(defgeneric forward-referenced-class-p (object))
-(defgeneric funcallable-standard-class-p (object))
-(defgeneric function-keywords (method))
-(defgeneric generic-function-argument-precedence-order (standard-generic-function))
-(defgeneric generic-function-declarations (standard-generic-function))
-(defgeneric generic-function-lambda-list (standard-generic-function))
+;          (eql-specializer)
+
 (defgeneric generic-function-method-class (standard-generic-function))
+;          (standard-generic-function)
+
 (defgeneric generic-function-method-combination (standard-generic-function))
+;          (standard-generic-function)
+
 (defgeneric generic-function-methods (standard-generic-function))
+;          (standard-generic-function)
+
 (defgeneric generic-function-name (standard-generic-function))
-(defgeneric generic-function-p (object))
-(defgeneric generic-function-pretty-arglist (generic-function))
+;          (standard-generic-function)
+
 (defgeneric gf-arg-info (standard-generic-function))
+;          (standard-generic-function)
+
 (defgeneric gf-dfun-state (standard-generic-function))
+;          (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))
+;          (standard-generic-function)
+
 (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))
+;          (long-method-combination)
+
+(defgeneric method-combination-documentation (standard-method-combination))
+;          (standard-method-combination)
+
 (defgeneric method-combination-options (standard-method-combination))
-(defgeneric method-combination-p (object))
+;          (standard-method-combination)
+
 (defgeneric method-combination-type (standard-method-combination))
-(defgeneric method-constant-value (method))
-(defgeneric method-function (standard-method))
-(defgeneric method-function-for-caching-p (method))
-(defgeneric method-function-name (standard-method))
+;          (standard-method-combination)
+
+(defgeneric method-fast-function (standard-method))
+;          (standard-method)
+
 (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 (method))
-(defgeneric method-specializers (standard-method))
+;          (traced-method)
+;          (standard-method)
+
 (defgeneric object-plist (plist-mixin))
-(defgeneric |PCL-CLASS class predicate| (object))
-(defgeneric |PLIST-MIXIN class predicate| (object))
-(defgeneric raw-instance-allocator (class))
+;          (plist-mixin)
+
 (defgeneric short-combination-identity-with-one-argument (short-method-combination))
+;          (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 (standard-slot-definition))
+;          (short-method-combination)
+
 (defgeneric slot-definition-boundp-function (effective-slot-definition))
+;          (effective-slot-definition)
+
 (defgeneric slot-definition-class (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-defstruct-accessor-symbol (structure-slot-definition))
+;          (structure-slot-definition)
+
 (defgeneric slot-definition-initargs (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-initform (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-initfunction (slot-definition))
-(defgeneric slot-definition-initfunction-side-effect-free-p (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-internal-reader-function (structure-slot-definition))
-(defgeneric slot-definition-internal-slotd (effective-slot-definition))
+;          (structure-slot-definition)
+
 (defgeneric slot-definition-internal-writer-function (structure-slot-definition))
-(defgeneric slot-definition-location (effective-slot-definition))
+;          (structure-slot-definition)
+
+(defgeneric slot-definition-location (standard-effective-slot-definition))
+;          (standard-effective-slot-definition)
+
 (defgeneric slot-definition-name (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-reader-function (effective-slot-definition))
+;          (effective-slot-definition)
+
 (defgeneric slot-definition-readers (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-type (slot-definition))
+;          (slot-definition)
+
 (defgeneric slot-definition-writer-function (effective-slot-definition))
+;          (effective-slot-definition)
+
 (defgeneric slot-definition-writers (slot-definition))
-(defgeneric |SLOT-OBJECT class predicate| (object))
+;          (slot-definition)
+
+(defgeneric specializer-object (class-eq-specializer))
+;          (eql-specializer)
+;          (class-prototype-specializer)
+;          (class-eq-specializer)
+
+(defgeneric specializer-type (specializer))
+;          (specializer)
+
+
+;;; writers
+(defgeneric (setf class-defstruct-constructor) (new-value structure-class))
+;          (t structure-class)
+
+(defgeneric (setf class-defstruct-form) (new-value structure-class))
+;          (t structure-class)
+
+(defgeneric (setf class-direct-slots) (new-value slot-class))
+;          (t slot-class)
+
+(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
+;          (t pcl-class)
+
+(defgeneric (setf class-initialize-info) (new-value slot-class))
+;          (t slot-class)
+
+(defgeneric (setf class-name) (new-value class))
+;          (t class)
+
+(defgeneric (setf class-slots) (new-value slot-class))
+;          (t slot-class)
+
+(defgeneric (setf generic-function-method-class) (new-value standard-generic-function))
+;          (t standard-generic-function)
+
+(defgeneric (setf generic-function-method-combination) (new-value standard-generic-function))
+;          (t standard-generic-function)
+
+(defgeneric (setf generic-function-methods) (new-value standard-generic-function))
+;          (t standard-generic-function)
+
+(defgeneric (setf generic-function-name) (new-value standard-generic-function))
+;          (t standard-generic-function)
+
+(defgeneric (setf gf-dfun-state) (new-value standard-generic-function))
+;          (t standard-generic-function)
+
+(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function))
+;          (t standard-generic-function)
+
+(defgeneric (setf method-generic-function) (new-value standard-method))
+;          (t traced-method)
+;          (t standard-method)
+
+(defgeneric (setf object-plist) (new-value plist-mixin))
+;          (t plist-mixin)
+
+(defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition))
+;          (t standard-slot-definition)
+
+(defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition))
+;          (t effective-slot-definition)
+
+(defgeneric (setf slot-definition-class) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition))
+;          (t structure-slot-definition)
+
+(defgeneric (setf slot-definition-initargs) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-initform) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-initfunction) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-internal-reader-function) (new-value structure-slot-definition))
+;          (t structure-slot-definition)
+
+(defgeneric (setf slot-definition-internal-writer-function) (new-value structure-slot-definition))
+;          (t structure-slot-definition)
+
+(defgeneric (setf slot-definition-location) (new-value standard-effective-slot-definition))
+;          (t standard-effective-slot-definition)
+
+(defgeneric (setf slot-definition-name) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-reader-function) (new-value effective-slot-definition))
+;          (t effective-slot-definition)
+
+(defgeneric (setf slot-definition-readers) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-type) (new-value slot-definition))
+;          (t slot-definition)
+
+(defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition))
+;          (t effective-slot-definition)
+
+(defgeneric (setf slot-definition-writers) (new-value slot-definition))
+;          (t slot-definition)
+
+
+;;; 1 argument 
+(defgeneric accessor-method-class (method))
+;          (standard-accessor-method)
+;          (standard-writer-method)
+
+(defgeneric accessor-method-slot-name (m))
+;          (traced-method)
+;          (standard-accessor-method)
+
+(defgeneric class-constructors (class))
+;          (slot-class)
+
+(defgeneric class-default-initargs (class))
+;          (slot-class)
+;          (built-in-class)
+
+(defgeneric class-direct-default-initargs (class))
+;          (slot-class)
+;          (built-in-class)
+
+(defgeneric class-direct-slots (class))
+;          (slot-class)
+;          (built-in-class)
+
+(defgeneric class-finalized-p (class))
+;          (pcl-class)
+
+(defgeneric class-prototype (class))
+;          (pcl-class)
+;          (std-class)
+;          (structure-class)
+
+(defgeneric class-slot-cells (class))
+;          (std-class)
+
+(defgeneric class-slots (class))
+;          (slot-class)
+;          (built-in-class)
+
+(defgeneric compute-class-precedence-list (root))
+;          (slot-class)
+
+(defgeneric compute-default-initargs (class))
+;          (slot-class)
+
+(defgeneric compute-discriminating-function (gf))
+;          (standard-generic-function)
+
+(defgeneric compute-discriminating-function-arglist-info (generic-function))
+;          (standard-generic-function)
+
+(defgeneric compute-slots (class))
+;          (std-class)
+;  :around (std-class)
+;          (structure-class)
+;  :around (structure-class)
+
+(defgeneric finalize-inheritance (class))
+;          (structure-class)
+;          (std-class)
+
+(defgeneric function-keywords (method))
+;          (standard-method)
+
+(defgeneric generic-function-lambda-list (gf))
+;          (generic-function)
+
+(defgeneric generic-function-pretty-arglist (generic-function))
+;          (standard-generic-function)
+
+(defgeneric gf-fast-method-function-p (gf))
+;          (standard-generic-function)
+
+(defgeneric initialize-internal-slot-functions (slotd))
+;          (effective-slot-definition)
+
+(defgeneric make-instances-obsolete (class))
+;          (std-class)
+;          (symbol)
+
+(defgeneric method-function (method))
+;          (traced-method)
+;          (standard-method)
+
+(defgeneric method-lambda-list (m))
+;          (traced-method)
+;          (standard-method)
+
+(defgeneric method-pretty-arglist (method))
+;          (standard-method)
+
+(defgeneric method-qualifiers (m))
+;          (traced-method)
+;          (standard-method)
+
+(defgeneric method-specializers (m))
+;          (traced-method)
+;          (standard-method)
+
+(defgeneric raw-instance-allocator (class))
+;          (standard-class)
+;          (funcallable-standard-class)
+
+(defgeneric slot-definition-allocation (slotd))
+;          (standard-slot-definition)
+;          (structure-slot-definition)
+
 (defgeneric slots-fetcher (class))
+;          (standard-class)
+;          (funcallable-standard-class)
+
 (defgeneric specializer-class (specializer))
+;          (class-prototype-specializer)
+;          (class-eq-specializer)
+;          (class)
+;          (eql-specializer)
+
 (defgeneric specializer-direct-generic-functions (specializer))
+;          (class)
+;          (specializer-with-object)
+
 (defgeneric specializer-direct-methods (specializer))
+;          (class)
+;          (specializer-with-object)
+
 (defgeneric specializer-method-table (specializer))
-(defgeneric specializer-object (class-eq-specializer))
-(defgeneric specializer-type (specializer))
-(defgeneric |SPECIALIZER-WITH-OBJECT class predicate| (object))
-(defgeneric specializerp (object))
-(defgeneric standard-accessor-method-p (object))
-(defgeneric standard-boundp-method-p (object))
-(defgeneric standard-class-p (object))
-(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-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 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))
+;          (eql-specializer)
+;          (class-eq-specializer)
+
 (defgeneric update-constructors (class))
+;          (slot-class)
+;          (class)
+
 (defgeneric wrapper-fetcher (class))
+;          (standard-class)
+;          (funcallable-standard-class)
+
 
 ;;; 2 arguments 
-(defgeneric add-constructor (class constructor))
 (defgeneric add-dependent (metaobject dependent))
+;          (dependent-update-mixin t)
+
 (defgeneric add-direct-method (specializer method))
+;          (class method)
+;          (specializer-with-object method)
+
 (defgeneric add-direct-subclass (class subclass))
+;          (class class)
+
 (defgeneric add-method (generic-function method))
-(defgeneric cached-slot-locations-and-fetchers-from-wrappers (method wrappers))
+;          (standard-generic-function method)
+
 (defgeneric change-class (instance new-class-name))
-(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
-(defgeneric (setf class-name) (new-value class))
+;          (standard-object standard-class)
+;          (standard-object funcallable-standard-class)
+;          (t symbol)
+
 (defgeneric class-slot-value (class slot-name))
+;          (std-class t)
+
 (defgeneric compatible-meta-class-change-p (class proto-new-class))
+;          (t t)
+
 (defgeneric compute-applicable-methods (generic-function arguments))
+;          (generic-function t)
+
 (defgeneric compute-applicable-methods-using-classes (generic-function classes))
-(defgeneric compute-class-slots (class eslotds))
-(defgeneric compute-constructor-code (class constructor))
+;          (generic-function t)
+
+(defgeneric compute-effective-slot-definition (class dslotds))
+;          (slot-class t)
+
 (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 describe-object (class stream))
+;          (slot-class t)
+;  :around (structure-class t)
+
+(defgeneric default-initargs (class supplied-initargs))
+;          (slot-class t)
+
+(defgeneric describe-object (object stream))
+;          (class t)
+;          (standard-generic-function t)
+;          (slot-object t)
+;          (t t)
+
 (defgeneric direct-slot-definition-class (class initargs))
+;          (structure-class t)
+;          (std-class t)
+
 (defgeneric effective-slot-definition-class (class initargs))
-(defgeneric (setf generic-function-method-class) (new-value standard-generic-function))
-(defgeneric (setf generic-function-method-combination) (new-value standard-generic-function))
-(defgeneric (setf generic-function-methods) (new-value standard-generic-function))
-(defgeneric (setf generic-function-name) (new-value standard-generic-function))
-(defgeneric (setf gf-dfun-state) (new-value standard-generic-function))
-(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function))
-(defgeneric (setf gf-valid-p) (new-value standard-generic-function))
+;          (std-class t)
+;          (structure-class t)
+
 (defgeneric inform-type-system-about-class (class name))
-(defgeneric legal-declarations-p (object x))
+;          (std-class t)
+;          (structure-class t)
+
 (defgeneric legal-documentation-p (object x))
-(defgeneric legal-lambda-list-p (object x))
+;          (standard-method t)
+
 (defgeneric legal-method-function-p (object x))
+;          (standard-method t)
+
 (defgeneric legal-qualifier-p (object x))
+;          (standard-method t)
+
 (defgeneric legal-qualifiers-p (object x))
+;          (standard-method t)
+
 (defgeneric legal-slot-name-p (object x))
+;          (standard-method t)
+
 (defgeneric legal-specializer-p (object x))
+;          (standard-method t)
+
 (defgeneric legal-specializers-p (object x))
-(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))
+;          (standard-method t)
+
+(defgeneric make-boundp-method-function (class slot-name))
+;          (slot-class t)
+
+(defgeneric make-reader-method-function (class slot-name))
+;          (slot-class t)
+;          (funcallable-standard-class t)
+
+(defgeneric make-writer-method-function (class slot-name))
+;          (slot-class t)
+;          (funcallable-standard-class t)
+
 (defgeneric map-dependents (metaobject function))
+;          (dependent-update-mixin t)
+
 (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 standard-method))
-(defgeneric (setf method-optimized-function) (new-value standard-method))
-(defgeneric (setf object-plist) (new-value plist-mixin))
-(defgeneric print-object (constructor stream))
+;          (generic-function method)
+
+(defgeneric print-object (mc stream))
+;          (t t)
+;          (class t)
+;          (slot-definition t)
+;          (standard-method t)
+;          (standard-accessor-method t)
+;          (generic-function t)
+;          (standard-method-combination t)
+
 (defgeneric remove-boundp-method (class generic-function))
-(defgeneric remove-constructor (class constructor))
+;          (slot-class t)
+
 (defgeneric remove-dependent (metaobject dependent))
+;          (dependent-update-mixin t)
+
 (defgeneric remove-direct-method (specializer method))
+;          (class method)
+;          (specializer-with-object method)
+
 (defgeneric remove-direct-subclass (class subclass))
+;          (class class)
+
 (defgeneric remove-method (generic-function method))
+;          (standard-generic-function method)
+
 (defgeneric remove-reader-method (class generic-function))
+;          (slot-class t)
+
 (defgeneric remove-writer-method (class generic-function))
+;          (slot-class t)
+
 (defgeneric same-specializer-p (specl1 specl2))
+;          (specializer specializer)
+;          (class class)
+;          (class-eq-specializer class-eq-specializer)
+;          (eql-specializer eql-specializer)
+
 (defgeneric slot-accessor-function (slotd type))
+;          (effective-slot-definition t)
+
 (defgeneric slot-accessor-std-p (slotd type))
-(defgeneric (setf slot-definition-allocation) (new-value standard-slot-definition))
-(defgeneric (setf slot-definition-boundp-function) (new-value effective-slot-definition))
-(defgeneric (setf slot-definition-class) (new-value slot-definition))
-(defgeneric (setf slot-definition-defstruct-accessor-symbol) (new-value structure-slot-definition))
-(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) (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))
-(defgeneric (setf slot-definition-type) (new-value slot-definition))
-(defgeneric (setf slot-definition-writer-function) (new-value effective-slot-definition))
-(defgeneric (setf slot-definition-writers) (new-value slot-definition))
+;          (effective-slot-definition t)
+
 (defgeneric slots-to-inspect (class object))
+;          (slot-class slot-object)
+
 (defgeneric update-gf-dfun (class gf))
+;          (std-class t)
+
 (defgeneric validate-superclass (fsc class))
+;          (class class)
+;          (class built-in-class)
+;          (slot-class forward-referenced-class)
+;          (funcallable-standard-class standard-class)
+
 
 ;;; 3 arguments 
+(defgeneric add-boundp-method (class generic-function slot-name))
+;          (slot-class t t)
+
+(defgeneric add-reader-method (class generic-function slot-name))
+;          (slot-class t t)
+
+(defgeneric add-writer-method (class generic-function slot-name))
+;          (slot-class t t)
+
 (defgeneric (setf class-slot-value) (nv class slot-name))
+;          (t std-class t)
+
 (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))
+;          (generic-function long-method-combination t)
+;          (generic-function short-method-combination t)
+;          (generic-function standard-method-combination t)
+
+(defgeneric compute-slot-accessor-info (slotd type gf))
+;          (effective-slot-definition t t)
+
 (defgeneric find-method-combination (generic-function type options))
+;          (generic-function (eql progn) t)
+;          (generic-function (eql or) t)
+;          (generic-function (eql nconc) t)
+;          (generic-function (eql min) t)
+;          (generic-function (eql max) t)
+;          (generic-function (eql list) t)
+;          (generic-function (eql append) t)
+;          (generic-function (eql and) t)
+;          (generic-function (eql +) t)
+;          (generic-function (eql standard) t)
+
+(defgeneric (setf slot-accessor-function) (function slotd type))
+;          (t effective-slot-definition t)
+
 (defgeneric (setf slot-accessor-std-p) (value slotd type))
+;          (t effective-slot-definition t)
+
 (defgeneric slot-boundp-using-class (class object slotd))
-(defgeneric slot-exists-p-using-class (class object slotd))
+;          (std-class standard-object standard-effective-slot-definition)
+;          (structure-class structure-object structure-effective-slot-definition)
+
 (defgeneric slot-makunbound-using-class (class object slotd))
-(defgeneric slot-unbound (class class-instance slot-name))
+;          (std-class standard-object standard-effective-slot-definition)
+;          (structure-class structure-object structure-effective-slot-definition)
+
+(defgeneric slot-unbound (class instance slot-name))
+;          (t t t)
+
 (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))
+;          (std-class standard-object standard-effective-slot-definition)
+;          (structure-class structure-object structure-effective-slot-definition)
+
 
 ;;; 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 make-method-lambda (proto-generic-function proto-method lambda-expression environment))
+;          (standard-generic-function standard-method t t)
+
 (defgeneric (setf slot-value-using-class) (new-value class object slotd))
+;          (t std-class standard-object standard-effective-slot-definition)
+;          (t structure-class structure-object structure-effective-slot-definition)
 
-;;; 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))
+;;; 5 arguments 
+(defgeneric make-method-initargs-form (proto-generic-function proto-method lambda-expression lambda-list environment))
+;          (standard-generic-function standard-method t t t)
 
-;;; 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-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 (setf documentation) (new-value slotd &optional doc-type))
+;          (t t)
+;          (t documentation-mixin)
+;          (t standard-slot-definition)
+
+(defgeneric documentation (slotd &optional doc-type))
+;          (t)
+;          (documentation-mixin)
+;          (standard-slot-definition)
+
+(defgeneric get-method (generic-function qualifiers specializers &optional (errorp t)))
+;          (standard-generic-function t t)
+
 (defgeneric remove-named-method (generic-function-name argument-specifiers &optional extra))
+;          (t t)
+
 (defgeneric slot-missing (class instance slot-name operation &optional new-value))
-(defgeneric update-slot-accessor-function (slotd type function &optional update-accessors-p))
+;          (t t t t)
+
 
 ;;; keyword arguments  
 (defgeneric allocate-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))
+;          (standard-class)
+;          (structure-class)
+;          (funcallable-standard-class)
+
+(defgeneric ensure-class-using-class (name class &rest args &key &allow-other-keys))
+;          (t null)
+;          (t pcl-class)
+
+(defgeneric ensure-generic-function-using-class (generic-function function-specifier &key &allow-other-keys))
+;          (null t)
+;          (generic-function t)
+
+(defgeneric initialize-instance (gf &key &allow-other-keys))
+;          (slot-object)
+;  :after  (standard-generic-function)
+
+(defgeneric make-instance (class &rest initargs))
+;          (symbol)
+;          (class)
+
 (defgeneric no-applicable-method (generic-function &rest args))
-(defgeneric no-next-method (generic-function method &rest args))
+;          (t)
+
 (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))
+;          (slot-class t)
+
+(defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys))
+;          (slot-object)
+;  :before (slot-class)
+;  :after  (slot-class)
+;          (standard-method)
+;  :after  (standard-generic-function)
+
+(defgeneric shared-initialize (generic-function slot-names &key &allow-other-keys))
+;          (slot-object t)
+;  :after  (documentation-mixin t)
+;  :after  (class-eq-specializer t)
+;  :after  (eql-specializer t)
+;  :after  (std-class t)
+;  :before (class t)
+;  :after  (structure-class t)
+;  :before (built-in-class t)
+;  :after  (standard-slot-definition t)
+;  :after  (structure-slot-definition t)
+;  :before (standard-method t)
+;  :before (standard-accessor-method t)
+;  :after  (standard-method t)
+;  :after  (standard-accessor-method t)
+;  :before (standard-generic-function t)
+
 (defgeneric update-instance-for-different-class (previous current &rest initargs))
+;          (standard-object standard-object)
+
 (defgeneric update-instance-for-redefined-class (instance added-slots discarded-slots property-list &rest initargs))
+;          (standard-object t t t)
+
 (defgeneric writer-method-class (class direct-slot &rest initargs))
+;          (slot-class t)
+
 
diff --git a/pcl/ibcl-low.lisp b/pcl/ibcl-low.lisp
index 33a5bc782..2ab3f77ba 100644
--- a/pcl/ibcl-low.lisp
+++ b/pcl/ibcl-low.lisp
@@ -73,11 +73,6 @@
     `(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 3d57b1671..9518c1286 100644
--- a/pcl/init.lisp
+++ b/pcl/init.lisp
@@ -30,47 +30,40 @@
 
 (in-package 'pcl)
 
-(declaim (type boolean *check-initargs-p*))
-(defvar *check-initargs-p* nil)
+(defmethod make-instance ((class symbol) &rest initargs)
+  (apply #'make-instance (find-class class) initargs))
 
-(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))
+(defmethod make-instance ((class class) &rest initargs)
   (unless (class-finalized-p class) (finalize-inheritance class))
-  (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)))
-        (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))
+  (setq initargs (default-initargs class initargs))
+  #||
+  (check-initargs-1
+   class initargs
+   (list (list* 'allocate-instance class initargs)
+	 (list* 'initialize-instance (class-prototype class) initargs)
+	 (list* 'shared-initialize (class-prototype class) t initargs)))
+  ||#
+  (let* ((info (initialize-info class initargs))
+	 (valid-p (initialize-info-valid-p info)))
+    (when (and (consp valid-p) (eq (car valid-p) :invalid))
+      (error "Invalid initialization argument ~S for class ~S"
+	     (cdr valid-p) (class-name class))))
+  (let ((instance (apply #'allocate-instance class initargs)))
+    (apply #'initialize-instance instance initargs)
+    instance))
 
 (defvar *default-initargs-flag* (list nil))
 
-(defmethod default-initargs ((class slot-class) supplied-initargs all-default)
+(defmethod default-initargs ((class slot-class) supplied-initargs)
+  (call-initialize-function
+   (initialize-info-default-initargs-function
+    (initialize-info class supplied-initargs))
+   nil supplied-initargs)
+  #||
   ;; This implementation of default initargs is critically dependent
   ;; on all-default-initargs not having any duplicate initargs in it.
-  (let ((miss *default-initargs-flag*))
+  (let ((all-default (class-default-initargs class))
+	(miss *default-initargs-flag*))
     (flet ((getf* (plist key)
 	     (do ()
 		 ((null plist) miss)
@@ -82,48 +75,31 @@
 		     nil
 		     (if (eq (getf* supplied-initargs (caar tail)) miss)
 			 (list* (caar tail)
-				(funcall-function (cadar tail))
+				(funcall (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)))))
+	(append supplied-initargs (default-1 all-default)))))
+  ||#)
 
 (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)
-	       (not (getf initargs :allow-other-keys)))
-      (check-initargs-1
-       (class-of instance) initargs
-       (append (compute-applicable-methods 
-		#'reinitialize-instance (list* instance initargs))
-	       (compute-applicable-methods 
-		#'shared-initialize (list* instance nil initargs))))))
+  #||  
+  (check-initargs-1
+   (class-of instance) initargs
+   (list (list* 'reinitialize-instance instance initargs)
+	 (list* 'shared-initialize instance nil initargs)))
+  ||#
+  (let* ((class (class-of instance))
+	 (info (initialize-info class initargs))
+	 (valid-p (initialize-info-ri-valid-p info)))
+    (when (and (consp valid-p) (eq (car valid-p) :invalid))
+      (error "Invalid initialization argument ~S for class ~S"
+	     (cdr valid-p) (class-name class))))
   (apply #'shared-initialize instance nil initargs)
   instance)
 
-
 (defmethod update-instance-for-different-class ((previous standard-object)
 						(current standard-object)
 						&rest initargs)
@@ -138,15 +114,10 @@
       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
 	       (eq (slot-definition-allocation slotd) ':instance))
 	  (push (slot-definition-name slotd) added-slots)))
-    (checking-initargs
-      (when (and initargs (not (getf initargs :allow-other-keys)))
-	(check-initargs-1
-	 (class-of current) initargs
-	 (append (compute-applicable-methods 
-		  #'update-instance-for-different-class 
-		  (list* previous current initargs))
-		 (compute-applicable-methods 
-		  #'shared-initialize (list* current added-slots initargs))))))
+    (check-initargs-1
+     (class-of current) initargs
+     (list (list* 'update-instance-for-different-class previous current initargs)
+	   (list* 'shared-initialize current added-slots initargs)))
     (apply #'shared-initialize current added-slots initargs)))
 
 (defmethod update-instance-for-redefined-class ((instance standard-object)
@@ -154,31 +125,37 @@
 						discarded-slots
 						property-list
 						&rest initargs)
-  (checking-initargs
-    (when (and initargs (not (getf initargs :allow-other-keys)))
-      (check-initargs-1
-       (class-of instance) initargs
-       (append (compute-applicable-methods 
-		#'update-instance-for-redefined-class 
-		(list* instance added-slots discarded-slots property-list initargs))
-	       (compute-applicable-methods 
-		#'shared-initialize (list instance added-slots initargs))))))
+  (check-initargs-1
+   (class-of instance) initargs
+   (list (list* 'update-instance-for-redefined-class
+		instance added-slots discarded-slots property-list initargs)
+	 (list* 'shared-initialize instance added-slots initargs)))
   (apply #'shared-initialize instance added-slots initargs))
 
 (defmethod shared-initialize
-	   ((instance slot-object) slot-names &rest initargs)
-  (declare (list initargs))
-  (declare #.*optimize-speed*)
+    ((instance slot-object) slot-names &rest initargs)
+  (when (eq slot-names 't)
+    (return-from shared-initialize
+      (call-initialize-function
+       (initialize-info-shared-initialize-t-function
+	(initialize-info (class-of instance) initargs))
+       instance initargs)))
+  (when (eq slot-names 'nil)
+    (return-from shared-initialize
+      (call-initialize-function
+       (initialize-info-shared-initialize-nil-function
+	(initialize-info (class-of instance) initargs))
+       instance initargs)))
   ;;
   ;; initialize the instance's slots in a two step process
-  ;;   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.
+  ;;   (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
-  ;;      by step 2.  Only those slots specified by the slot-names
-  ;;      argument are set.  If slot-names is:
+  ;;   (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
   ;;            any slot not set in step 1 is set from its
   ;;            initform
@@ -189,136 +166,93 @@
   ;;       ()
   ;;            no slots are set from initforms
   ;;
-  (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))))
+  (let* ((class (class-of instance))
+	 (slotds (class-slots class))
+	 #-new-kcl-wrapper
+	 (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 #-new-kcl-wrapper (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))
 
-
 
 ;;; 
 ;;; if initargs are valid return nil, otherwise signal an error
 ;;;
+(defun check-initargs-1 (class initargs call-list &optional (plist-p t) (error-p t))
+  (multiple-value-bind (legal allow-other-keys)
+      (check-initargs-values class call-list)
+    (unless allow-other-keys
+      (if plist-p
+	  (check-initargs-2-plist initargs class legal error-p)
+	  (check-initargs-2-list initargs class legal error-p)))))
+
+(defun check-initargs-values (class call-list)
+  (let ((methods (mapcan #'(lambda (call)
+			     (if (consp call)
+				 (copy-list (compute-applicable-methods
+					     (gdefinition (car call))
+					     (cdr call)))
+				 (list call)))
+			 call-list))
+	(legal (apply #'append (mapcar #'slot-definition-initargs
+				       (class-slots class)))))
+    ;; Add to the set of slot-filling initargs the set of
+    ;; initargs that are accepted by the methods.  If at
+    ;; any point we come across &allow-other-keys, we can
+    ;; just quit.
+    (dolist (method methods)
+      (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
+	  (analyze-lambda-list (if (consp method)
+				   (early-method-lambda-list method)
+				   (method-lambda-list method)))
+	(declare (ignore nreq nopt keysp restp))
+	(when allow-other-keys
+	  (return-from check-initargs-values (values nil t)))
+	(setq legal (append keys legal))))
+    (values legal nil)))
 
-(declaim (ftype (function (T) (values list boolean)) function-keywords))
+(defun check-initargs-2-plist (initargs class legal &optional (error-p t))
+  (unless (getf initargs :allow-other-keys)
+    ;; Now check the supplied-initarg-names and the default initargs
+    ;; against the total set that we know are legal.
+    (doplist (key val) initargs
+       (unless (memq key legal)
+	 (if error-p
+	     (error "Invalid initialization argument ~S for class ~S"
+		    key
+		    (class-name class))
+	     (return-from check-initargs-2-plist nil)))))
+  t)
 
-(defun check-initargs-1 (class initargs methods)
-  (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
-      ;; any point we come across &allow-other-keys, we can
-      ;; just quit.
-      (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))))
-      ;; Now check the supplied-initarg-names and the default initargs
-      ;; against the total set that we know are legal.
-      (doplist (key val) initargs
-	(unless (memq key legal)
-	  (error "Invalid initialization argument ~S for class ~S"
-		 key
-		 (class-name class)))))))
+(defun check-initargs-2-list (initkeys class legal &optional (error-p t))
+  (unless (memq :allow-other-keys initkeys)
+    ;; Now check the supplied-initarg-names and the default initargs
+    ;; against the total set that we know are legal.
+    (dolist (key initkeys)
+      (unless (memq key legal)
+	(if error-p
+	    (error "Invalid initialization argument ~S for class ~S"
+		   key
+		   (class-name class))
+	    (return-from check-initargs-2-list nil)))))
+  t)
 
diff --git a/pcl/iterate.lisp b/pcl/iterate.lisp
index 57041e31e..d690a9537 100644
--- a/pcl/iterate.lisp
+++ b/pcl/iterate.lisp
@@ -307,7 +307,6 @@ 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
@@ -368,13 +367,12 @@ 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
-                                                        :test #'eq)
+                                                (member x lambda-list-keywords)
                                                 )
                                      (setq let-bindings (second binding-type)))
                               )
-                         (eql (length (the list (second expansion)))
-                              (length (the list let-bindings)))
+                         (eql (length (second expansion))
+                              (length let-bindings))
                          (null (cddr expansion)))
                                                ; A simple LAMBDA form can be
                                                ; treated as LET
@@ -481,13 +479,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 :test #'eq)
+                                         ((and (member form bound-vars)
                                                (variable-same-p form env 
                                                       iterate-env))
                                                ; FORM is a var that is bound
@@ -592,7 +590,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 (the list args))
+                     (eql (length args)
                           nargs))
                  form)))
 
@@ -665,7 +663,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 :test #'eq))
+                                        (setq pair (assoc form alist))
                                         (variable-same-p form subenv env))
                                    (cdr pair))
                                   (t form))))))
@@ -1070,11 +1068,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 :test #'eq))
+                                       ((setq pair (assoc form alist))
                                                ; One to rename
                                         (cdr pair))
                                        (t      ; var is free
-                                          (pushnew form closed :test #'eq)
+                                          (pushnew form closed)
                                           form)))))
                   closed)))
 
diff --git a/pcl/kcl-low.lisp b/pcl/kcl-low.lisp
index 281ff6b6e..77cb4f569 100644
--- a/pcl/kcl-low.lisp
+++ b/pcl/kcl-low.lisp
@@ -28,9 +28,10 @@
 (in-package "SI")
 (export '(%structure-name
           %compiled-function-name
-          %set-compiled-function-name))
+          %set-compiled-function-name
+	  %instance-ref
+	  %set-instance-ref))
 (in-package 'pcl)
-(import 'si:structurep)
 
 (shadow 'lisp:dotimes)
 
@@ -83,31 +84,7 @@
            (incf ,index))))))
 
 (defun printing-random-thing-internal (thing stream)
-  (format stream "~O" (si:address thing)))
-
-
-#+akcl
-(eval-when (load compile eval)
-
-;compiler::*compile-ordinaries* is set to t in kcl-patches
-
-(if (and (boundp 'si::*akcl-version*)
-	 (>= si::*akcl-version* 604))
-    (progn
-      (pushnew :turbo-closure *features*)
-      (pushnew :turbo-closure-env-size *features*))
-    (when (fboundp 'si::allocate-growth) 
-      (pushnew :turbo-closure *features*)))
-
-;; patch around compiler bug.
-(when (<= si::*akcl-version* 609)
-  (let ((vcs "static int Vcs;
-"))
-    (unless (search vcs compiler::*cmpinclude-string*)
-      (setq compiler::*cmpinclude-string*
-	    (concatenate 'string vcs compiler::*cmpinclude-string*)))))
-
-)
+  (format stream "~X" (si:address thing)))
 
 (defmacro %svref (vector index)
   `(svref (the simple-vector ,vector) (the fixnum ,index)))
@@ -129,25 +106,26 @@
 #+akcl
 (progn
 
+#-new-kcl-wrapper
 ;; declare that std-instance-p may be computed simply, and will not change.
 (si::freeze-defstruct 'std-instance)
 
+(si::freeze-defstruct 'method-call)
+(si::freeze-defstruct 'fast-method-call)
 
-(defvar *pcl-funcall*  '(lambda (loc)
-          (compiler::wt-nl
-           "{object _funobj = " loc ";"
-           "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo))
-                   (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo);
-               else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))();
-               else super_funcall_no_event(_funobj);}")))
-(setq compiler::*super-funcall* *pcl-funcall*)
+(defvar *pcl-funcall* 
+  `(lambda (loc)
+     (compiler::wt-nl
+      "{object _funobj = " loc ";"
+      "if(Rset&&type_of(_funobj)!=t_symbol)funcall_no_event(_funobj);
+       else super_funcall(_funobj);}")))
 
-)
+(setq compiler::*super-funcall* *pcl-funcall*)
 
-(defun function-ftype-declaimed-p (name)
-  "Returns whether the function given by name already has its ftype declaimed."
-  (get name 'compiler::proclaimed-function))
+(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
+  `(funcall ,fn ,pv-cell ,next-method-call ,@args))
 
+)
 
 ;;;
 ;;; turbo-closure patch.  See the file kcl-mods.text for details.
@@ -192,21 +170,43 @@ int n; object cc;
 ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
 (eval-when (compile load eval)
 
+#+new-kcl-wrapper
+(progn
+
+(defun instance-ref (slots index)
+  (si:structure-ref1 slots index))
+
+(defun set-instance-ref (slots index value)
+  (si:structure-set1 slots index value))
+
+(defsetf instance-ref set-instance-ref)
+(defsetf %instance-ref %set-instance-ref)
+)
+
+(defsetf structure-def set-structure-def)
+
 ;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
 (defparameter *kcl-function-inlines*
-  '(#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
+  '((%fboundp (t) compiler::boolean nil nil "(#0)->s.s_gfdef!=OBJNULL")
+    (%symbol-function (t) t nil nil "(#0)->s.s_gfdef")
+    #-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
     #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
     #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
+    #+new-kcl-wrapper
+    (si:%instance-ref (t t) t nil nil "(#0)->str.str_self[fix(#1)]")
+    #+new-kcl-wrapper
+    (si:%set-instance-ref (t t t) t t nil "(#0)->str.str_self[fix(#1)]=(#2)")
     (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
     (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
     (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
+    #+akcl (sfun-p (t) compiler::boolean nil nil "type_of(#0)==t_sfun")
     (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
     (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
     #+turbo-closure
     (%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)
@@ -223,11 +223,12 @@ int n; object cc;
 (defmacro define-inlines ()
   `(progn
     ,@(mapcan #'(lambda (inline)
-                  (let ((name (intern (format nil "~S inline" (car inline))))
-                        (vars (mapcar #'(lambda (type)
-                                          (declare (ignore type))
-                                          (gensym))
-                                      (cadr inline))))
+                  (let* ((*package* *the-pcl-package*)
+			 (name (intern (format nil "~S inline" (car inline))))
+			 (vars (mapcar #'(lambda (type)
+					   (declare (ignore type))
+					   (gensym))
+				       (cadr inline))))
                     `((make-function-inline ',(cons name (cdr inline)))
                       ,@(when (or (every #'(lambda (type) (eq type 't))
                                          (cadr inline))
@@ -251,7 +252,7 @@ int n; object cc;
   (declare (ignore ignore))
   (cond ((compiled-function-p fn)
 	 (si::turbo-closure fn)
-	 (when (symbolp new-name) (proclaim-closure new-name))
+	 ;;(when (symbolp new-name) (proclaim-defgeneric new-name nil))
          (setf (si:%compiled-function-name fn) new-name))
         ((and (listp fn)
               (eq (car fn) 'lambda-block))
@@ -263,13 +264,6 @@ 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 "
@@ -304,12 +298,24 @@ object set_cclosure (result_cc,value_cc,available_size)
 (defentry %set-cclosure (object object int) (object set_cclosure))
 
 
-(pushnew :structure-functions *features*)
+(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)))
 
-(defmacro structure-type (x)
-  `(si:%structure-name (the structure ,x)))
+(si:define-compiler-macro structure-type (x)
+  (once-only (x)
+    `(and (si:structurep ,x)
+          (si:%structure-name ,x))))
 
-(defun known-structure-type-p (type)
+(defun structure-type-p (type)
   (or (not (null (gethash type *structure-table*)))
       (let (#+akcl(s-data nil))
         (and (symbolp type)
@@ -332,6 +338,7 @@ object set_cclosure (result_cc,value_cc,available_size)
 (defun structure-type-slot-description-list (type)
   (or (cdr (gethash type *structure-table*))
       (mapcan #'(lambda (slotd)
+		  #-new-kcl-wrapper
                   (when (and slotd (car slotd))
                     (let ((offset (fifth slotd)))
                       (let ((reader #'(lambda (x)
@@ -353,7 +360,9 @@ object set_cclosure (result_cc,value_cc,available_size)
                           (list (list slot-name
                                       reader-sym
 				      reader
-                                      (and (not read-only-p) writer))))))))
+                                      (and (not read-only-p) writer)))))))
+		  #+new-kcl-wrapper
+		  (list slotd))
               (let ((slotds (structure-type-internal-slotds type))
                     (inc (structure-type-included-type-name type)))
                 (if inc
@@ -361,19 +370,32 @@ object set_cclosure (result_cc,value_cc,available_size)
                             slotds)
                     slotds)))))
             
-
-(defun structure-slotd-name (slotd)
-  (first slotd))
-
-(defun structure-slotd-accessor-symbol (slotd)
-  (second slotd))
-
-(defun structure-slotd-reader-function (slotd)
-  (third slotd))
-
-(defun structure-slotd-writer-function (slotd)
-  (fourth slotd))
-
+#+new-kcl-wrapper
+(defun si::slot-reader-function (slot)
+  (let ((offset (si::slot-offset slot)))
+    (si:turbo-closure #'(lambda (x)
+			  (si::structure-ref1 x offset)))))				
+
+#+new-kcl-wrapper
+(defun si::slot-writer-function (slot)
+  (let ((offset (si::slot-offset slot)))
+    (si:turbo-closure #'(lambda (x)
+			  (si::structure-set1 x offset)))))
+
+(mapcar #'(lambda (fname value)
+	    (setf (symbol-function fname) (symbol-function value)))
+	'(structure-slotd-name
+	  structure-slotd-accessor-symbol
+	  structure-slotd-reader-function
+	  structure-slotd-writer-function
+	  structure-slotd-type
+	  structure-slotd-init-form)
+	#-new-kcl-wrapper
+	'(first second third fourth function-returning-nil function-returning-nil)
+	#+new-kcl-wrapper
+	'(si::slot-name si::slot-accessor-name 
+	  si::slot-reader-function si::slot-writer-function
+	  si::slot-type si::slot-default-init))
 
 
 ;; Construct files sys-proclaim.lisp and sys-package.lisp
@@ -397,10 +419,11 @@ object set_cclosure (result_cc,value_cc,available_size)
 
   ;; proclaims
   (compiler::make-all-proclaims "*.fn")
+  (let ((*package* (find-package 'user)))
   (with-open-file (st "sys-proclaim.lisp"
 		      :direction :output
 		      :if-exists :append)
-    (format st "~%(IN-PACKAGE \"PCL\")~%")
+    ;;(format st "~%(IN-PACKAGE \"PCL\")~%")
     (print
      `(dolist (v ',
      
@@ -410,6 +433,6 @@ object set_cclosure (result_cc,value_cc,available_size)
 	(setf (get v 'compiler::proclaimed-closure) t))
      st)
     (format st "~%")
-    ))
-
+    )))
 
+	
diff --git a/pcl/kcl-patches.lisp b/pcl/kcl-patches.lisp
index 3d94b9420..c051d9be3 100644
--- a/pcl/kcl-patches.lisp
+++ b/pcl/kcl-patches.lisp
@@ -30,13 +30,52 @@
 
 #+akcl
 (eval-when (compile load eval)
+
 (when (<= system::*akcl-version* 609)
   (pushnew :pre_akcl_610 *features*))
+
+(if (and (boundp 'si::*akcl-version*)
+	 (>= si::*akcl-version* 604))
+    (progn
+      (pushnew :turbo-closure *features*)
+      (pushnew :turbo-closure-env-size *features*))
+    (when (fboundp 'si::allocate-growth) 
+      (pushnew :turbo-closure *features*)))
+
+;; patch around compiler bug.
+(when (<= si::*akcl-version* 609)
+  (let ((vcs "static int Vcs;
+"))
+    (unless (search vcs compiler::*cmpinclude-string*)
+      (setq compiler::*cmpinclude-string*
+	    (concatenate 'string vcs compiler::*cmpinclude-string*)))))
+
+(let ((rset "int Rset;
+"))
+  (unless (search rset compiler::*cmpinclude-string*)
+      (setq compiler::*cmpinclude-string*
+	    (concatenate 'string rset compiler::*cmpinclude-string*))))
+
+(when (get 'si::basic-wrapper 'si::s-data)
+  (pushnew :new-kcl-wrapper *features*)
+  (pushnew :structure-wrapper *features*))
+  
 )
 
+
 #+akcl
 (progn
 
+(unless (fboundp 'real-c2lambda-expr-with-key)
+  (setf (symbol-function 'real-c2lambda-expr-with-key)
+	(symbol-function 'c2lambda-expr-with-key)))
+
+(defun c2lambda-expr-with-key (lambda-list body)
+  (declare (special *sup-used*))
+  (setq *sup-used* t)
+  (real-c2lambda-expr-with-key lambda-list body))
+
+
 ;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:
@@ -94,34 +133,45 @@
 (defentry objnull-p (object) (object "objnull_p"))
 
 (defun can-use-print-circle-p (x)
+  (catch 'can-use-print-circle-p
+    (can-use-print-circle-p1 x nil)))
+
+(defun can-use-print-circle-p1 (x so-far)
   (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))))))))))
+       (if (member x so-far)
+	   (throw 'can-use-print-circle-p t)
+	   (let ((so-far (cons x so-far)))
+	     (flet ((can-use-print-circle-p (x)
+		      (can-use-print-circle-p1 x so-far)))
+	       (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*)
diff --git a/pcl/lap.lisp b/pcl/lap.lisp
index d41313a59..3e250fa5a 100644
--- a/pcl/lap.lisp
+++ b/pcl/lap.lisp
@@ -49,15 +49,14 @@
 
 (defun 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))
+  (funcall *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-function *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))
 
 (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
   (declare (ignore cvars args))
@@ -132,7 +131,7 @@
 		   (cadr *generating-lap*) (cons entry allocated))
 	     (cdr entry))
 	    (t
-	     (let ((new `(,type . (:reg ,(incf (the fixnum (caddr *generating-lap*)))))))
+	     (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*))))))
 	       (setf (cadr *generating-lap*) (cons new allocated))
 	       (cdr new)))))))
 
@@ -160,8 +159,9 @@
 	   `(lap-in-lisp ,closure-variables ,arguments ,iregs 
 	                 ,vregs ,fvregs ,tregs ,lap-code))
 	  (*precompiling-lap*
-	   (values closure-variables arguments iregs 
-		   vregs fvregs tregs lap-code))
+	   `(precompile-lap-closure-generator 
+	     ,closure-variables ,arguments ,iregs
+	     ,vregs ,fvregs ,tregs ,lap))
 	  (t
 	   (make-lap-closure-generator
 	     closure-variables arguments iregs 
@@ -202,13 +202,13 @@
 (defun opcode (name &rest args)
   (let ((emitter (gethash name *lap-emitters*)))
     (if emitter
-	(apply-function (symbol-function emitter) args)
+	(apply emitter args)
 	(error "No opcode named ~S." name))))
 
 (defun operand (name &rest args)
   (let ((emitter (gethash name *lap-emitters*)))
     (if emitter
-	(apply-function (symbol-function emitter) args)
+	(apply emitter args)
 	(error "No operand named ~S." name))))
 
 (defmacro defopcode (name types)
@@ -260,7 +260,8 @@
 	     (and (consp arg) (eq (car arg) x)))
 	   (check (x)
 	     (ecase x	       
-	       ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
+	       ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable)
+		(usual x))
 	       (:label (symbolp arg))
 	       (:operand (and (consp arg) (memq (car arg) *lap-operands*))))))
     (unless (if (consp type)
@@ -274,7 +275,7 @@
   (flet ((check (x)
 	   (ecase x
 	     (:symbol           (symbolp arg))
-	     (:register-number  (and (integerp arg) (>= (the fixnum arg) 0)))
+	     (:register-number  (and (integerp arg) (>= arg 0)))
 	     (:t                t)
 	     (:reg              (and (consp arg) (eq (car arg) :reg)))
 	     (:fixnum           (typep arg 'fixnum)))))
@@ -295,7 +296,7 @@
 (defopcode :print (:reg))			;implement this.
 
 
-(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
+(defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable)))
 
 (defopcode :eq     ((or :reg :constant) (or :reg :constant) :label))
 (defopcode :neq    ((or :reg :constant) (or :reg :constant) :label))
@@ -306,10 +307,9 @@
 (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)))
+(defopcode :emf-call ((or :reg :constant)))
 
 (defopcode :label  (:label))
 (defopcode :go     (:label))
@@ -335,13 +335,9 @@
 (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))
 
@@ -350,6 +346,9 @@
 (defoperand :iref (:reg :reg))
 (defoperand :iset (:reg :reg :reg))
 
+(defoperand :instance-ref (:reg :reg))
+(defoperand :instance-set (:reg :reg :reg))
+
 (defoperand :i1+     (:reg))
 (defoperand :i+      (:reg :reg))
 (defoperand :i-      (:reg :reg))
diff --git a/pcl/list-functions.lisp b/pcl/list-functions.lisp
index 83b8fc50d..a272131a2 100644
--- a/pcl/list-functions.lisp
+++ b/pcl/list-functions.lisp
@@ -5,26 +5,19 @@
 (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
-          *proclaim-list* nil)
+	  *defmacro-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)) 
@@ -51,14 +44,14 @@
 	    (length *defmacro-list*)
 	    (length *defgeneric-list*))))
 
-(defun list-all-gfs (&optional all-p)
+(defun list-all-gfs (&key all-p (show-methods-p t) san-p (name "generic-functions"))
   (let ((keys nil) (opt nil)
 	(gf-vector (make-array 10 :initial-element nil))
+	(readers nil) (writers nil) (cv nil)
 	(*package* *the-pcl-package*)
 	(*print-pretty* nil)
 	(s-a-n (find-package "SLOT-ACCESSOR-NAME"))
-	(lisp-sans (list (slot-reader-symbol 'function)
-                         (slot-reader-symbol 'type))))
+	(lisp-sans (mapcar #'slot-reader-symbol '(function type))))
     (map-all-generic-functions 
      #'(lambda (gf)
 	 (when (or all-p
@@ -66,23 +59,38 @@
 		     (when (consp name) (setq name (cadr name)))
 		     (and (not (find #\: (symbol-name name)))
 			  (or (eq (symbol-package name) *the-pcl-package*)
-			      (memq name lisp-sans)
-			      (and (eq (symbol-package name) s-a-n)
-				   (string= "PCL " (symbol-name name) :end2 4))))))
+			      (and san-p
+				   (memq name lisp-sans)
+				   (and (eq (symbol-package name) s-a-n)
+					(string= "PCL " (symbol-name name)
+						 :end2 4)))))))
 	   (let ((ll (generic-function-lambda-list gf)))
 	     (multiple-value-bind (nrequired noptional 
 					     keysp restp allow-other-keys-p keywords)
 		 (analyze-lambda-list ll)
-	       (if (or keysp restp allow-other-keys-p keywords)
-		   (push gf keys)
-		   (if (plusp noptional)
-		       (push gf opt)
-		       (push gf (aref gf-vector nrequired)))))))))
+	       (cond ((use-constant-value-dfun-p gf t)
+		      (push gf cv))
+		     ((or keysp restp allow-other-keys-p keywords)
+		      (push gf keys))
+		     ((plusp noptional)
+		      (push gf opt))
+		     ((and (= nrequired 1)
+			   (let ((m (generic-function-methods gf)))
+			     (and m
+				  (every #'standard-reader-method-p m))))
+		      (push gf readers))
+		     ((and (= nrequired 2)
+			   (let ((m (generic-function-methods gf)))
+			     (and m
+				  (every #'standard-writer-method-p m))))
+		      (push gf writers))
+		     (t
+		      (push gf (aref gf-vector nrequired)))))))))
     (with-open-file (out (let* ((system (get-system 'pcl))
 				(*system-directory* (funcall (car system))))
 			   (make-pathname :defaults
 					  (truename (make-source-pathname "defsys"))
-					  :name "generic-functions"))
+					  :name name))
 			 :direction :output)
       (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%")
       (format out "(in-package :pcl)~%")
@@ -98,13 +106,31 @@
 				     (string< (symbol-name s1) (symbol-name s2))
 				     (string< (package-name p1) (package-name p2)))))))
 	       (dolist (sym list)
-		 (let ((*print-case* :downcase))
-		   (format out "~&~S~%"
-			   `(defgeneric ,sym ,(generic-function-lambda-list
-					       (gdefinition sym))))))))
+		 (let* ((*print-case* :downcase)
+			(gf (gdefinition sym))
+			(lambda-list (generic-function-lambda-list gf)))
+		   (format out "~&~S~%" `(defgeneric ,sym ,lambda-list))
+		   (when show-methods-p
+		     (dolist (m (generic-function-methods gf))
+		       (let* ((q (method-qualifiers m))
+			      (qs (if (null q) 
+				      ""
+				      (format nil "~{~S~^ ~}" q)))
+			      (s (unparse-specializers m)))
+			 (format out "~&;  ~7A ~S~%" qs s)))
+		     (terpri out))))))
+	(when cv
+	  (format out "~%;;; class predicates~%")
+	  (print-gf-list cv))
+	(when readers
+	  (format out "~%;;; readers~%")
+	  (print-gf-list readers))
+	(when writers
+	  (format out "~%;;; writers~%")
+	  (print-gf-list writers))
 	(dotimes (i 10)
 	  (when (aref gf-vector i)
-	    (format out "~%;;; ~D arguments ~%" i)
+	    (format out "~%;;; ~D argument~:P ~%" i)
 	    (print-gf-list (aref gf-vector i))))
 	(format out "~%;;; optional arguments  ~%")
 	(print-gf-list opt)
diff --git a/pcl/low.lisp b/pcl/low.lisp
index 30a7dc26f..324e45858 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -65,292 +65,21 @@
 (in-package 'pcl)
 
 (eval-when (compile load eval)
-(defconstant *optimize-speed*
-  #+kcl
-  '(optimize)
-  #-kcl
-  '(optimize (speed 3) (safety 0) (compilation-speed 0) (space 0))
-  "List of declarations for locally-optimized internal code.")
+(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
 )
 
-
-;;; 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 index ,index))))
+		     (inline svref))
+	    (svref (the simple-vector ,vector) (the fixnum ,index))))
 
-(defsetf %svref (vector index) (new-value)
+(defsetf %svref %set-svref)
+
+(defmacro %set-svref (vector index new-value)
   `(locally (declare #.*optimize-speed*
-                     (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)))
+		     (inline svref))
+     (setf (svref (the simple-vector ,vector) (the fixnum ,index))
+	   ,new-value)))
 
 
 ;;;
@@ -373,127 +102,84 @@
 ;;;
 (defmacro without-interrupts (&body body)
   `(macrolet ((interrupts-on () ())
-              (interrupts-off () ()))
+	      (interrupts-off () ()))
      (progn ,.body)))
 
-(defmacro without-interrupts-simple (&body body)
-  `(without-interrupts ,.body))
-  
+
+;;;
+;;;  Very Low-Level representation of instances with meta-class standard-class.
+;;;
+#-new-kcl-wrapper
+(progn
+(defstruct (std-instance (:predicate std-instance-p)
+			 (:conc-name %std-instance-)
+			 (:constructor %%allocate-instance--class ())
+			 (:print-function print-std-instance))
+  (wrapper nil)
+  (slots nil))
+
+(defmacro %instance-ref (slots index)
+  `(%svref ,slots ,index))
 
-;;; We have to redefine lisp's DEFSTRUCT macro so that pcl knows about
-;;; all the structure-classes.
+(defmacro instance-ref (slots index)
+  `(svref ,slots ,index))
+)
 
-(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))))
+#+new-kcl-wrapper
+(progn
+(defvar *init-vector* (make-array 40 :fill-pointer 1 :adjustable t 
+				  :initial-element nil))
 
-(redefine-macro 'defstruct 'pcl-defstruct)
-(setf (macro-function 'original-defstruct) (original-definition 'defstruct))
+(defun get-init-list (i)
+  (declare (fixnum i)(special *slot-unbound*))
+  (loop (when (< i (fill-pointer *init-vector*))
+	  (return (aref *init-vector* i)))
+	(vector-push-extend 
+	 (cons *slot-unbound*
+	       (aref *init-vector* (1- (fill-pointer *init-vector*))))
+	 *init-vector*)))
 
+(defmacro %std-instance-wrapper (instance)
+  `(structure-def ,instance))
 
-(defvar *structure-table* (make-hash-table :test 'eq))
+(defmacro %std-instance-slots (instance)
+  instance)
 
-(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 std-instance-p (x)
+  `(structurep ,x))
+)
 
-(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))))))
+(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x))
+(defmacro std-instance-slots   (x) `(%std-instance-slots ,x))
 
-(defun structure-type-included-type-name (symbol)
-  (let ((defstruct-source (gethash symbol *structure-table*)))
-    (cadr (assq :include (cdar defstruct-source)))))
+(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-instance-wrapper-or-nil (inst)
+  `(cond ((std-instance-p ,inst) (std-instance-wrapper ,inst))
+	 ((fsc-instance-p ,inst) (fsc-instance-wrapper ,inst))))
 
-;;;
-;;;  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))
-  (wrapper nil)
-  (slots nil))
+(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?"))))
 
-(defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x))
-(defmacro std-instance-slots   (x) `(%std-instance-slots ,x))
+(defmacro get-slots-or-nil (inst)
+  `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
+	 ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))))
 
 (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 (static-slot-storage-copy)
-  `(let ((instance (%%allocate-instance--class)))
-     (%allocate-instance--class-1 ,static-slot-storage-copy instance)
-     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 ,static-slot-storage-copy)))))
+    (let ((class (class-of instance)))
+      (if (or (eq class (find-class 'standard-class nil))
+	      (eq class (find-class 'funcallable-standard-class nil))
+	      (eq class (find-class 'built-in-class nil)))
+	  (format stream "~a ~a" (early-class-name class)
+		  (early-class-name instance))
+	  (format stream "~a" (early-class-name class))))))
 
 ;;;
 ;;; This is the value that we stick into a slot to tell us that it is unbound.
@@ -504,27 +190,18 @@
 ;;; code which actually use ..slot-unbound.. rather than this variable.  So
 ;;; much for modularity
 ;;; 
-(defconstant *slot-unbound* '..slot-unbound..)
+(defvar *slot-unbound* '..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 %allocate-static-slot-storage--class (no-of-slots)
+  #+new-kcl-wrapper (declare (ignore no-of-slots))
+  #-new-kcl-wrapper
+  `(make-array ,no-of-slots :initial-element *slot-unbound*)
+  #+new-kcl-wrapper
+  (error "don't call this"))
 
 (defmacro std-instance-class (instance)
-  `(wrapper-class (std-instance-wrapper ,instance)))
-
-
+  `(wrapper-class* (std-instance-wrapper ,instance)))
+
 
   ;;   
 ;;;;;; FUNCTION-ARGLIST
@@ -566,8 +243,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))
@@ -575,15 +252,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
 ;;;
@@ -610,100 +287,67 @@
 ;;;                             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 CMU) :slow
+	#-(or KCL IBCL GCLisp CMU) :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-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.")))
+(defvar *compile-lambda-break-p* nil)
 
-(defun compile-lambda (lambda &optional (desirability :fast) name)
+(defun compile-lambda (lambda &optional (desirability :fast))
+  (when *compile-lambda-break-p* (break))
   (cond ((null *compiler-present-p*)
-         (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)))
+	 (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)
+  #'(lambda (&rest args) (apply (coerce uncompiled '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)))))))
 
 (defmacro precompile-random-code-segments (&optional system)
   `(progn
-     (eval-when (compile) (before-precompile-random-code-segments))
+     (eval-when (compile)
+       (update-dispatch-dfuns)
+       (compile-iis-functions nil))
      (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))))
-
+     (precompile-dfun-constructors ,system)
+     (precompile-iis-functions ,system)
+     (eval-when (load)
+       (compile-iis-functions t))))
 
+
 
 (defun record-definition (type spec &rest args)
   (declare (ignore type spec args))
@@ -711,10 +355,90 @@
 
 (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
 
+;; From braid.lisp
+#-new-kcl-wrapper
+(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))
+
+(defun structure-slotd-type (structure-slot-description)
+  (fourth structure-slot-description))
 
+(defun structure-slotd-init-form (structure-slot-description)
+  (fifth structure-slot-description))
diff --git a/pcl/lucid-low.lisp b/pcl/lucid-low.lisp
index 20107328a..ec473574e 100644
--- a/pcl/lucid-low.lisp
+++ b/pcl/lucid-low.lisp
@@ -106,7 +106,7 @@
 
 
 
-#+lcl4.0
+#+lcl3.0
 (progn
 
 (defvar *saved-compilation-speed* 3)
@@ -191,7 +191,12 @@
 ;;; The following should override the definitions provided by lucid-low.
 ;;;
 #+(or LCL3.0 (and APOLLO DOMAIN/OS))
-(defstruct-simple-predicate  std-instance std-instance-p)
+(progn
+(defstruct-simple-predicate std-instance std-instance-p)
+(defstruct-simple-predicate fast-method-call fast-method-call-p)
+(defstruct-simple-predicate method-call method-call-p)
+)
+
 
 
 (defun set-function-name-1 (fn new-name ignore)
@@ -307,12 +312,18 @@
 (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 'std-instance (structure-type x)))))
 
 (defvar *structure-type* nil)
 (defvar *structure-length* nil)
 
-(defun known-structure-type-p (type)
+(defun structure-type-p (type)
   (declare (special lucid::*defstructs*))
   (let ((s-data (gethash type lucid::*defstructs*)))
     (or (and s-data 
@@ -328,30 +339,29 @@
   (declare (special lucid::*defstructs*))
   (let ((s-data (gethash type lucid::*defstructs*)))
     (if s-data
-	(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*))))
+	(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*)))
 	  (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 1bc49ba5b..5ae83f4d6 100644
--- a/pcl/macros.lisp
+++ b/pcl/macros.lisp
@@ -46,7 +46,8 @@
 	     class
 	     variable-rebinding
 	     pcl-fast-call
-	     specializer-names
+	     method-name
+	     method-lambda-list
 	     ))
 
 ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
@@ -69,23 +70,19 @@
 
 
 (defun make-caxr (n form)
-  (declare (type fixnum n))
   (if (< n 4)
       `(,(nth n '(car cadr caddr cadddr)) ,form)
-      (make-caxr (the fixnum (- n 4)) `(cddddr ,form))))
+      (make-caxr (- 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 (the fixnum (- n 4)) `(cddddr ,form)))))
+	(t (make-cdxr (- 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)
@@ -101,168 +98,34 @@
 ;;; 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-VARS"))
-        (run-time-vals (gensym "RUN-TIME-VALS"))
+        (run-time-vars (gensym))
+        (run-time-vals (gensym))
         (expand-time-val-forms ()))
     (dolist (var vars)
-      (push `(if (simple-eval-access-p ,var)
+      (push `(if (or (symbolp ,var)
+                     (numberp ,var)
+                     (and (listp ,var)
+			  (member (car ,var) '(quote function))))
                  ,var
-                 (let ((,gensym-var (gensym ,(symbol-name var))))
+                 (let ((,gensym-var (gensym)))
                    (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)))
-       (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))
+       `(let ,(mapcar #'list (reverse ,run-time-vars)
+			     (reverse ,run-time-vals))
+	  ,wrapped-body))))
 
 (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))
@@ -290,9 +153,18 @@
 	    body)))
 )
 
-;#+Lucid
-;(eval-when (compile load eval)
-;  (eval `(defstruct (,(intern "FASLESCAPE" (find-package 'lucid))))))
+(defun get-declaration (name declarations &optional default)
+  (dolist (d declarations default)
+    (dolist (form (cdr d))
+      (when (and (consp form) (eq (car form) name))
+	(return-from get-declaration (cdr form))))))
+
+
+#+Lucid
+(eval-when (compile load eval)
+  (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
+
+(defvar *keyword-package* (find-package 'keyword))
 
 (defun make-keyword (symbol)
   (intern (symbol-name symbol) *keyword-package*))
@@ -347,7 +219,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*))
@@ -368,7 +240,6 @@
 	(pending-pops 0)
 	(var nil)
 	(setqs ()))
-    (declare (type fixnum pending-pops))
     (labels
         ((make-pop (var form pop-into)
 	   (prog1 
@@ -485,7 +356,6 @@
 	  (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
@@ -498,39 +368,26 @@
 	     (unless dashes-p (setf (elt string i) #\space)))
 	    (t (setq flag nil))))))
 
-#-(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)
+(eval-when (compile load eval)
+;(warn "****** Things will go faster if you fix define-compiler-macro")
 )
 
-#+(or lucid kcl excl cmu)
 (defmacro define-compiler-macro (name arglist &body body)
-  `(#+lucid lcl:def-compiler-macro
-    #+kcl   si::define-compiler-macro
-    #+excl  excl::defcmacro
-    #+cmu   c:def-source-transform
+  #+(or lucid kcl)
+  `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro
         ,name ,arglist
-     ,@body))
+     ,@body)
+  #-(or kcl lucid)
+  nil)
 
-#-(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))
+
+;;;
+;;; FIND-CLASS
+;;;
+;;; This is documented in the CLOS specification.
+;;;
+(defvar *find-class* (make-hash-table :test #'eq))
 
 (defun make-constant-function (value)
   #'(lambda (object)
@@ -541,18 +398,80 @@ your lisp")
   (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)
 
-(defun documented-function-returning-t (args next-methods)
-  (declare (ignore args next-methods))
-  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 find-wrapper (symbol)
+  (class-wrapper (find-class symbol)))
 
 #|| ; Anything that used this should use eval instead.
 (defun reduce-constant (old)
@@ -576,13 +495,12 @@ your lisp")
   `(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)
-		       (setf index (the fixnum (1+ index)))
+		       (incf index)
 		       value)))
 	     #'(lambda () result))))
 
@@ -607,62 +525,13 @@ your lisp")
 		     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)
-  `(funcall-function ,form ,@args))
+  #-cmu `(funcall ,form ,@args)
+  #+cmu `(funcall (the function ,form) ,@args))
 
 (defmacro function-apply (form &rest 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))))
-
-
+  #-cmu `(apply ,form ,@args)
+  #+cmu `(apply (the function ,form) ,@args))
 
 
 ;;;
@@ -796,8 +665,6 @@ your lisp")
       )))
 
 (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))))
@@ -844,7 +711,6 @@ your lisp")
 (defsetf slot-value set-slot-value)
 
 (defvar *redefined-functions* nil)
-(defvar *redefined-macros* nil)
 
 (defmacro original-definition (name)
   `(get ,name ':definition-before-pcl))
@@ -857,29 +723,24 @@ your lisp")
   (setf (symbol-function name)
 	(symbol-function new)))
 
-(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*))
+(defun reset-pcl-package ()		; Try to do this safely
+  (let* ((vars '(*pcl-directory* 
+		 *default-pathname-extensions* 
+		 *pathname-extensions*
+		 *redefined-functions*))
 	 (names (mapcar #'symbol-name vars))
 	 (values (mapcar #'symbol-value vars)))
+    (declare (special *redefined-functions*))
     (let ((pkg (find-package "PCL")))
       (do-symbols (sym pkg)
 	(when (eq pkg (symbol-package sym))
-	  (if (constantp sym)
+	  (if (or (constantp sym)
+		  (eq sym 'wrapper)
+		  (eq sym 'arg-info))
 	      (unintern sym pkg)
 	      (progn
 		(makunbound sym)
-		(unless (eq sym 'pcl::reset-pcl-package)
+		(unless (eq sym 'reset-pcl-package)
 		  (fmakunbound sym))
 		#+cmu (fmakunbound `(setf ,sym))
 		(setf (symbol-plist sym) nil))))))
@@ -895,7 +756,7 @@ your lisp")
 		    (proclaim `(special ,var))
 		    (set var value)))
 	      names values))      
-    (dolist (sym pcl::*redefined-functions*)
+    (dolist (sym *redefined-functions*)
       (setf (symbol-function sym) (get sym ':definition-before-pcl)))
     nil))
 
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index 577e28001..89cc24de5 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -27,6 +27,57 @@
 
 (in-package 'pcl)
 
+(defmethod print-object (instance stream)
+  (printing-random-thing (instance stream)
+    (let ((name (class-name (class-of instance))))
+      (if name
+	  (format stream "~S" name)
+	  (format stream "Instance")))))
+
+(defmethod print-object ((class class) stream)
+  (named-object-print-function class stream))
+
+(defmethod print-object ((slotd slot-definition) stream)
+  (named-object-print-function slotd stream))
+
+(defun named-object-print-function (instance stream
+				    &optional (extra nil extra-p))
+  (printing-random-thing (instance stream)
+    (if extra-p					
+	(format stream "~A ~S ~:S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)
+		extra)
+	(format stream "~A ~S"
+		(capitalize-words (class-name (class-of instance)))
+		(slot-value-or-default instance 'name)))))
+
+(defmethod print-object ((mc standard-method-combination) stream)
+  (printing-random-thing (mc stream)
+    (format stream
+	    "Method-Combination ~S ~S"
+	    (slot-value-or-default mc 'type)
+	    (slot-value-or-default mc 'options))))
+
+
+;;;
+;;;
+;;;
+(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))))
+
+(defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names 
+				     &key (allocation :instance))
+  (declare (ignore slot-names))
+  (unless (eq allocation :instance)
+    (error "structure slots must have :instance allocation")))
+
+(defmethod inform-type-system-about-class ((class structure-class) (name t))
+  nil)
+
 ;;;
 ;;; METHODS
 ;;;
@@ -38,346 +89,43 @@
 ;;;   
 ;;;
 
-(defclass method (metaobject) ()
-  (:predicate-name method-p))
-
-(defclass standard-method (definition-source-mixin documentation-mixin plist-mixin method)
-     ((generic-function
-	:initform nil	
-	:accessor method-generic-function)
-;     (qualifiers
-;	:initform ()
-;	:initarg  :qualifiers
-;	:reader method-qualifiers)
-      (specializers
-	:initform ()
-	:initarg  :specializers
-	:reader method-specializers)
-      (lambda-list
-	:initform ()
-	:initarg  :lambda-list
-	:reader method-lambda-list)
-      (function
-	:initform nil
-	: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)
-      (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))
-
-(defclass standard-accessor-method (standard-method)
-     ((slot-name :initform nil
-		 :initarg :slot-name
-		 :reader accessor-method-slot-name))
-  (:predicate-name standard-accessor-method-p))
-
-(defclass standard-reader-method (standard-accessor-method) ()
-  (:predicate-name standard-reader-method-p))
-
-(defclass standard-writer-method (standard-accessor-method) ()
-  (:predicate-name standard-writer-method-p))
-
-(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 method-function ((method standard-method))
+  (or (slot-value method 'function)
+      (let ((fmf (slot-value method 'fast-function)))
+	(unless fmf ; the :before shared-initialize method prevents this
+	  (error "~S doesn't seem to have a method-function" method))
+	(setf (slot-value method 'function)
+	      (method-function-from-fast-function fmf)))))
+
+(defmethod accessor-method-class ((method standard-accessor-method))
+  (car (slot-value method 'specializers)))
+
+(defmethod accessor-method-class ((method standard-writer-method))
+  (cadr (slot-value method 'specializers)))
 
 (defmethod print-object ((method standard-method) stream)
   (printing-random-thing (method stream)
-    (let ((generic-function (method-generic-function method))
-	  (class-name (capitalize-words (class-name (class-of method)))))
-      (format stream "~A ~S ~{~S ~}~:S"
-	      class-name
-	      (and generic-function (generic-function-name generic-function))
-	      (method-qualifiers method)
-	      (unparse-specializers method)))))
+    (if (slot-boundp method 'generic-function)
+	(let ((generic-function (method-generic-function method))
+	      (class-name (capitalize-words (class-name (class-of method)))))
+	  (format stream "~A ~S ~{~S ~}~:S"
+		  class-name
+		  (and generic-function (generic-function-name generic-function))
+		  (method-qualifiers method)
+		  (unparse-specializers method)))
+	(call-next-method))))
 
 (defmethod print-object ((method standard-accessor-method) stream)
   (printing-random-thing (method stream)
-    (let ((generic-function (method-generic-function method))
-	  (class-name (capitalize-words (class-name (class-of method)))))
-      (format stream "~A ~S, slot:~S, ~:S"
-	      class-name
-	      (and generic-function (generic-function-name generic-function))
-	      (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-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)
-		     ((standard-writer-method-p method) 'writer)
-		     ((standard-boundp-method-p method) 'boundp)))
-	 (class (wrapper-class (if (eq type 'writer) (cadr wrappers) (car wrappers))))
-	 (slotd (find-slot-definition class slot-name)))
-    (if slotd
-	(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))))
+    (if (slot-boundp method 'generic-function)
+	(let ((generic-function (method-generic-function method))
+	      (class-name (capitalize-words (class-name (class-of method)))))
+	  (format stream "~A ~S, slot:~S, ~:S"
+		  class-name
+		  (and generic-function (generic-function-name generic-function))
+		  (accessor-method-slot-name method)
+		  (unparse-specializers method)))
+	(call-next-method))))
 
 ;;;
 ;;; INITIALIZATION
@@ -394,13 +142,19 @@
           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)
-  (lambda-list-legal-p x))
+  (declare (ignore x))
+  t)
 
 (defmethod legal-method-function-p ((object standard-method) x)
-  (if (or (null x) (functionp x))
+  (if (functionp x)
       t
-      "is not a function"))
+      "a function"))
 
 (defmethod legal-qualifiers-p ((object standard-method) x)
   (flet ((improper-list ()
@@ -421,6 +175,7 @@
   (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
 	((keywordp x)      "is a keyword and so cannot be bound")
 	((memq x '(t nil)) "cannot be bound")
+	((constantp x)     "is a constant and so cannot be bound")
 	(t t)))
 
 (defmethod legal-specializers-p ((object standard-method) x)
@@ -449,12 +204,9 @@
 					   lambda-list
 					   specializers
 					   function
-                                           optimized-function
-                                           closure-generator
-                                           optimized-slot-indices
-                                           documentation)
-  (declare (ignore slot-names closure-generator optimized-slot-indices
-                   documentation))
+				           fast-function
+					   documentation)
+  (declare (ignore slot-names))
   (flet ((lose (initarg value string)
 	   (error "When initializing the method ~S:~%~
                    The ~S initialization argument was: ~S.~%~
@@ -463,333 +215,84 @@
     (let ((check-qualifiers    (legal-qualifiers-p method qualifiers))
 	  (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-optimized-function
-             (legal-method-function-p method optimized-function)))
+	  (check-function      (legal-method-function-p method (or function
+								   fast-function)))
+	  (check-documentation (legal-documentation-p method documentation)))
       (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)))))
+	(lose :function function check-function))
+      (unless (eq check-documentation t)
+	(lose :documentation documentation check-documentation)))))
 
 (defmethod shared-initialize :before ((method standard-accessor-method)
 				      slot-names
-				      &key
-                                      (check-initargs-legality-p T)
-                                      slot-name
-                                      (slot-definition () slot-def-supplied-p))
+				      &key slot-name slot-definition)
   (declare (ignore slot-names))
-  (when check-initargs-legality-p
+  (unless slot-definition
     (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))
+	(error "The value of the :SLOT-NAME initarg ~A." legalp)))))
+
+(defmethod shared-initialize :after ((method standard-method) slot-names
+				     &rest initargs
+				     &key qualifiers method-spec plist)
+  (declare (ignore slot-names method-spec plist))
+  (initialize-method-function initargs nil method)
+  (setf (plist-value method 'qualifiers) qualifiers)
+  #+ignore
+  (setf (slot-value method 'closure-generator) 
+	(method-function-closure-generator (slot-value method 'function))))
+
+(defmethod shared-initialize :after ((method standard-accessor-method)
+				     slot-names
+				     &key)
   (declare (ignore slot-names))
-  (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)))
+  (with-slots (slot-name slot-definition)
+    method
+    (unless slot-definition
+      (let ((class (accessor-method-class method)))
+	(when (slot-class-p class)
+	  (setq slot-definition (find slot-name (class-direct-slots class)
+				      :key #'slot-definition-name)))))
+    (when (and slot-definition (null slot-name))
+      (setq slot-name (slot-definition-name slot-definition)))))
 
 (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
-			    definition-source-mixin
-			    documentation-mixin
-			    metaobject)
-     ()
-  (:metaclass funcallable-standard-class)
-  (:predicate-name generic-function-p))
-    
-(defclass standard-generic-function (generic-function)
-     ((name
-	:initform nil
-	:initarg :name
-	:accessor generic-function-name)
-      (methods
-	:initform ()
-	:accessor generic-function-methods)
-      (method-class
-	:initarg :method-class
-	:accessor generic-function-method-class)
-      (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)
-      (arg-info
-        :initform (make-arg-info)
-	:reader gf-arg-info)
-      (dfun-state
-	:initform ()
-	:accessor gf-dfun-state)
-      (valid-p
-	:initform nil
-	:accessor gf-valid-p)
-      (pretty-arglist
-	:initform ()
-	:accessor gf-pretty-arglist)
-      )
-  (:metaclass funcallable-standard-class)
-  (:predicate-name standard-generic-function-p)
-  (:default-initargs :method-class *the-class-standard-method*
-		     :method-combination *standard-method-combination*))
-
-
 (defvar *the-class-generic-function*          (find-class 'generic-function))
 (defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
 
 
 
-(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 (the list (generic-function-methods generic-function))))))
-
+    (if (slot-boundp generic-function 'methods)
+	(list (length (generic-function-methods generic-function)))
+	"?")))
 
 (defmethod shared-initialize :before
 	   ((generic-function standard-generic-function)
 	    slot-names
-	    &key (check-initargs-legality-p T)
-                 (name nil namep)
+	    &key (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 documentation))
+  (declare (ignore slot-names
+		   declarations argument-precedence-order documentation
+		   lambda-list lambda-list-p))
 
   (when namep
     (set-function-name generic-function name))
@@ -810,7 +313,7 @@
 			    "a subclass of the class METHOD"))
 	   (setf (slot-value generic-function 'method-class) method-class))
 	  ((slot-boundp generic-function 'method-class))
-	  (check-initargs-legality-p
+	  (t
 	   (initarg-error :method-class
 			  "not supplied"
 			  "a subclass of the class METHOD")))
@@ -820,49 +323,10 @@
 			    method-combination
 			    "a method combination object")))
 	  ((slot-boundp generic-function 'method-combination))
-	  (check-initargs-legality-p
+	  (t
 	   (initarg-error :method-combination
 			  "not supplied"
-			  "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)))
+			  "a method combination object")))))
 
 
 #||
@@ -919,43 +383,31 @@
 	  (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* ((*reinitialize-gf-updates-dfun-p* NIL)
-         (generic-function
+  (let* ((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))
-	 (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)))
+;	 (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
+				     other-initargs)))
+;   (when existing (remove-method generic-function existing))
     (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)
@@ -975,7 +427,6 @@
 	(generic-function (make-instance 'standard-generic-function
 					 :name function-name))
 	(nrequireds 0))
-    (declare (type index nrequireds))
     (if (generic-function-p original)
 	original
 	(progn
@@ -988,19 +439,14 @@
 	  (when arglistp
 	    (setf (gf-pretty-arglist generic-function) arglist))
 	  (when 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))
+	    (add-named-method function-name
+			      ()
+			      (make-list nrequireds :initial-element 't)
+			      arglist
+			      (list :function
+				    #'(lambda (args next-methods)
+					(declare (ignore next-methods))
+					(apply original args)))))
 	  generic-function))))
 
 
@@ -1036,32 +482,26 @@
 ;;;       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 (the index number-required) restp (sort specialized-positions #'<))))
+    (values 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 (type index requireds))
+    (declare (fixnum requireds))
     ;; Go through this methods arguments seeing how many are required,
     ;; and whether there is an &rest argument.
     (dolist (arg (method-lambda-list method))
@@ -1069,7 +509,7 @@
             ((memq arg '(&optional &rest &key))
              (return (setq restp t)))
 	    ((memq arg lambda-list-keywords))
-            (t (setf requireds (the index (1+ requireds))))))
+            (t (incf 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
@@ -1083,13 +523,9 @@
     ;; 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 (the index (if (and number-of-requireds
-                               (< (the index number-of-requireds) requireds))
-                           number-of-requireds
-                           requireds))
+    (values (min (or number-of-requireds requireds) requireds)
             (or restp
-		(and number-of-requireds
-                     (/= (the index number-of-requireds) requireds)))
+		(and number-of-requireds (/= number-of-requireds requireds)))
             specialized-argument-positions)))
 
 (defun make-discriminating-function-arglist (number-required-arguments restp)
@@ -1104,213 +540,54 @@
 ;;;
 ;;;
 ;;;
-(defstruct (arg-info
-	     (:conc-name nil)
-	     (:constructor make-arg-info ()))
-  arg-info-precedence
-  arg-info-metatypes
-  (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 :type boolean) ; set by set-arg-info
-
-  gf-info-static-c-a-m-emf
-  (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 (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 (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)
-    (setf (arg-info-number-optional arg-info) number-optional)
-    (setf (arg-info-key/rest-p arg-info) key/rest-p)
-    (setf (arg-info-keywords arg-info) keywords)
-    (when lambda-list-p
-      (setf (arg-info-lambda-list arg-info) lambda-list))
-    (setf (gf-precompute-dfun-and-emf-p arg-info)
-          (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 (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)))
-      (set-arg-info gf
-		    precedence
-		    metatypes
-		    nopt
-		    (or keysp restp)
-		    keywords
-		    lambda-list))))
-
-(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 
-			  (make-list nreq) (method-specializers method))
-		  nopt
-		  (or keysp restp)
-		  ())))
-
-(defun add-arg-info (generic-function method)
-  (let ((arg-info (gf-arg-info generic-function)))
-    (if (not (arg-info-valid-p arg-info))
-	(new-arg-info-from-method generic-function method)
-	(flet ((lose (string &rest args)
-		 (error "Attempt to add the method ~S to the generic function ~S.~%~
-                   But ~A"
-			method
-			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."
-		      (compare nreq gf-nreq)))
-	      (unless (= nopt gf-nopt)
-		(lose "the method has ~S optional arguments than the generic function."
-		      (compare nopt gf-nopt)))
-	      (unless (eq (or keysp restp) gf-key/rest-p)
-		(error "the method and generic function differ in whether they accept~%~
-                  rest or keyword arguments."))
-	      (when gf-keywords
-		(unless (or (and restp (not keysp))
-			    allow-other-keys-p
-			    (every #'(lambda (k) (memq k keywords)) gf-keywords))
-		  (error
-		   "the generic function requires each method to accept the keyword arguments~%~
-               ~S.  The method does not accept all of these."
-		   gf-keywords)))
-	      (set-arg-info generic-function
-			    (arg-info-precedence arg-info)
-			    (mapcar #'raise-metatype (arg-info-metatypes arg-info)
-				    (method-specializers method))
-			    gf-nopt
-			    gf-key/rest-p
-			    gf-keywords)))))))
-
-(defun remove-arg-info (generic-function method)
-  (let ((arg-info (gf-arg-info generic-function)))
-    (set-arg-info generic-function
-		  (arg-info-precedence arg-info)
-		  (let* ((nreq (arg-info-number-required arg-info))
-			 (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)
-		  (arg-info-number-optional arg-info)
-		  (arg-info-key/rest-p arg-info)
-		  (arg-info-keywords arg-info))))
+
+(defmethod generic-function-lambda-list ((gf generic-function))
+  (gf-lambda-list gf))
+
+(defmethod gf-fast-method-function-p ((gf standard-generic-function))
+  (gf-info-fast-mf-p (slot-value gf 'arg-info)))
 
 (defmethod initialize-instance :after ((gf standard-generic-function)
 				       &key (lambda-list nil lambda-list-p)
 				       argument-precedence-order)
-  (when lambda-list-p
-    (new-arg-info-from-generic-function gf lambda-list argument-precedence-order))
-  (when (arg-info-valid-p (gf-arg-info gf))
-    (update-dfun gf)))
+  (with-slots (arg-info)
+    gf
+    (if lambda-list-p
+	(set-arg-info gf 
+		      :lambda-list lambda-list
+		      :argument-precedence-order argument-precedence-order)
+	(set-arg-info gf))
+    (when (arg-info-valid-p arg-info)
+      (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))
-	 (valid-p (arg-info-valid-p arg-info)))
-    (when lambda-list-p
-      (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 (and *reinitialize-gf-updates-dfun-p*
-               valid-p args
-	       (or (not (eq (car args) 'lambda-list))
-		   (cddr args)))
+  (with-slots (arg-info)
+    gf
+    (if lambda-list-p
+	(set-arg-info gf 
+		      :lambda-list lambda-list
+		      :argument-precedence-order argument-precedence-order)
+	(set-arg-info gf))
+    (when (and (arg-info-valid-p arg-info)
+	       args
+	       (or lambda-list-p (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))))
-
-
-(defmethod no-applicable-method (generic-function &rest args)
-  (cerror "Retry call to ~S"
-	  "No matching method for the generic-function ~S,~@
-          when called with arguments ~S."
-	  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)
+(defun set-methods (gf methods)
+  (setf (generic-function-methods gf) nil)
+  (loop (when (null methods) (return gf))
+	(real-add-method gf (pop methods) methods)))
+
+(defun real-add-method (generic-function method &optional skip-dfun-update-p)
   (if (method-generic-function method)
       (error "The method ~S is already part of the generic~@
               function ~S.  It can't be added to another generic~@
@@ -1319,7 +596,6 @@
 
       (let* ((name (generic-function-name generic-function))
 	     (qualifiers   (method-qualifiers method))
-	     (lambda-list  (method-lambda-list method))
 	     (specializers (method-specializers method))
 	     (existing (get-method generic-function qualifiers specializers nil)))
 	;;
@@ -1331,240 +607,59 @@
 	(when existing (remove-method generic-function existing))
 	;;
 	(setf (method-generic-function method) generic-function)
-	(setf (method-function-name method)
-	      (intern-function-name
-	       (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)
 	  (add-direct-method specializer method))
-	(update-gf-info generic-function)
-	(update-dfun generic-function)
-	(maybe-update-constructors generic-function method)
+	(set-arg-info generic-function :new-method method)
+	(unless skip-dfun-update-p
+	  (when (member name 
+			'(make-instance default-initargs
+			  allocate-instance shared-initialize initialize-instance))
+	    (update-make-instance-function-table (type-class (car specializers))))
+	  (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~@
                ~S.  It can't be removed from the generic function~@
                to which it is not attached."
 	      method (method-generic-function method))
-       (let* ((methods      (generic-function-methods generic-function))
+       (let* ((name         (generic-function-name generic-function))
+	      (specializers (method-specializers method))
+	      (methods      (generic-function-methods generic-function))
 	      (new-methods  (remove method methods)))	      
 	 (setf (method-generic-function method) nil)
 	 (setf (generic-function-methods generic-function) new-methods)
 	 (dolist (specializer (method-specializers method))
 	   (remove-direct-method specializer method))
-	 (remove-arg-info generic-function method)
+	 (set-arg-info generic-function)
+	 (when (member name '(make-instance default-initargs
+			      allocate-instance shared-initialize initialize-instance))
+	   (update-make-instance-function-table (type-class (car specializers))))
 	 (update-dfun generic-function)
 	 (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
-	      (setq possibly-applicable-p nil)
-	      (return nil))))
-	(when possibly-applicable-p
-	  (unless applicable-p (setq definite-p nil))
-	  (push method possibly-applicable-methods))))
-    (values (sort-applicable-methods generic-function
-				     (nreverse possibly-applicable-methods)
-				     types)
-	    definite-p)))
-
-;This is used to speed up precompute-effective-methods.
-(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 (class-on-class-precedence-list-p specl type)))
-    (declare (type boolean pred))
-    (values pred
-	    (or pred
-		(if (not *in-precompute-effective-methods-p*)
-		    ;; classes might get common subclass
-		    (superclasses-compatible-p specl type)
-		    ;; worry only about existing classes
-		    (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 (or (eq class1 class2)
-               (class-on-class-precedence-list-p class1 class2)))
-      (class-can-precede-p class1 class2)))
-
-(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)
-        (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
-            (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)))))
-
-(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)))
-
-(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
-          (class-on-class-precedence-list-p (cadr type) (type-class specl))))))
-
-(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))
-                                  (class-on-class-precedence-list-p
-			            (cadr specl) (cadr type)))))))
-        (declare (type boolean pred))
-	(values pred pred))))
-
-(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-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)
 			    (if (symbolp class)
@@ -1576,10 +671,7 @@
       (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)
@@ -1593,11 +685,11 @@
    (built-in-class std-class structure-class) ; direct subclasses of pcl-class
    (standard-class funcallable-standard-class)
    ;; superclass metaobject
-   (class eql-specializer class-eq-specializer method ; method-combination
+   (class eql-specializer class-eq-specializer method method-combination
     generic-function slot-definition)
    ;; metaclass built-in-class
-   (number sequence character symbol	; direct subclasses of t, but not array
-    standard-object structure-object)
+   (number sequence character   	; direct subclasses of t, but not array
+    standard-object structure-object)   ;                         or symbol
    (number array character symbol	; direct subclasses of t, but not sequence
     standard-object structure-object)
    (complex float rational)		; direct subclasses of number
@@ -1607,96 +699,6 @@
    (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 (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)
-	   nil)
-	  ((atom type1)
-	   specl2)
-	  ((atom type2)
-	   specl1)
-	  (t
-	   (case (car type1)
-	     (class    (case (car type2)
-			 (class (funcall compare-classes-function specl1 specl2 index))
-			 (t specl2)))
-	     (class-eq (case (car type2)
-			 (eql specl2)
-			 (class-eq nil)
-			 (class type1)))
-	     (eql      (case (car type2)
-			 (eql nil)
-			 (t specl1))))))))
-
-(defun sort-applicable-methods (generic-function methods types)
-  (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))
-			  class1 class2)))))
-
-(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 
-			     specl1 specl2 index compare-classes-function)))
-	       (when order
-		 (return-from sorter (eq order specl1)))))))
-    (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))
-	     (let ((choice nil))
-	       (dolist (c choices nil)
-		 (when (or (and (eq (first c) class1)
-				(eq (second c) class2))
-			   (and (eq (first c) class2)
-				(eq (second c) class1)))
-		   (return (setq choice c))))
-	       (unless choice
-		 (setq choice
-		       (if (class-might-precede-p class1 class2)
-			   (if (class-might-precede-p class2 class1)
-			       (list class1 class2 nil t)
-			       (list class1 class2 t))
-			   (if (class-might-precede-p class2 class1)
-			       (list class2 class1 t)
-			       (let ((name1 (class-name class1))
-				     (name2 (class-name class2)))
-				 (if (and name1 name2 (symbolp name1) (symbolp name2)
-					  (string< (symbol-name name1)
-						   (symbol-name name2)))
-				     (list class1 class2 t)
-				     (list class2 class1 t))))))
-		 (push choice choices))
-	       (car choice))))
-      (loop (funcall function
-		     (sort-methods methods precedence #'compare-classes-function))
-	    (unless (dolist (c choices nil)
-		      (unless (third c)
-			(rotatef (car c) (cadr c))
-			(return (setf (third c) t))))
-	      (return nil))))))
 
 
 
@@ -1720,175 +722,63 @@
 (defmethod specializer-class ((specializer eql-specializer))
   (class-of (slot-value specializer 'object)))
 
-
-
-
 (defvar *in-gf-arg-info-p* nil)
-(defvar arg-info-reader (make-std-reader-method-function 'arg-info))
+(setf (symbol-function 'arg-info-reader)
+      (let ((mf (initialize-method-function
+		 (make-internal-reader-method-function
+		  'standard-generic-function 'arg-info)
+		 t)))
+	#'(lambda (&rest args) (funcall mf args nil))))
 
 (defun types-from-arguments (generic-function arguments &optional type-modifier)
-  (let* ((arg-info (if *in-gf-arg-info-p*
-		       (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"
-	       (generic-function-name generic-function)
-	       (length metatypes)))
-      (let ((arg (pop arguments)))
-	(push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
-    (values (nreverse types-rev) arg-info)))
+  (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+      (get-generic-function-info generic-function)
+    (declare (ignore applyp metatypes nkeys))
+    (let ((types-rev nil))
+      (dotimes (i nreq)
+	i
+	(unless arguments
+	  (error "The function ~S requires at least ~D arguments"
+		 (generic-function-name generic-function)
+		 nreq))
+	(let ((arg (pop arguments)))
+	  (push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
+      (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 (= nkeys 1)
+	  (unless c-w (return-from get-wrappers-from-classes nil))
+	  (if (eql 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.
-;;;
-;;;  <function>   The compiled effective method function for this set of
-;;;               arguments. 
-;;;
-;;;  <applicable> Sorted list of applicable methods. 
-;;;
-;;;  <wrappers>   Is a single wrapper if the generic function has only
-;;;               one key, that is arg-info-nkeys of the arg-info is 1.
-;;;               Otherwise a list of the wrappers of the specialized
-;;;               arguments to the generic function.
-;;;
-;;;               Note that all these wrappers are valid.  This function
-;;;               does invalid wrapper traps when it finds an invalid
-;;;               wrapper and then returns the new, valid wrapper.
-;;;
-;;;  <invalidp>   True if any of the specialized arguments had an invalid
-;;;               wrapper, false otherwise.
-;;;
-;;;  <type>       READER or WRITER when the only method that would be run
-;;;               is a standard reader or writer method.  To be specific,
-;;;               the value is READER when the method combination is eq to
-;;;               *standard-method-combination*; there are no applicable
-;;;               :before, :after or :around methods; and the most specific
-;;;               primary method is a standard reader method.
-;;;
-;;;  <index>      If <type> is READER or WRITER, and the slot accessed is
-;;;               an :instance slot, this is the index number of that slot
-;;;               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 (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)))
-	 (cam-std-p (gf-info-c-a-m-emf-std-p arg-info))
-	 (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"
-	       (generic-function-name gf) (length metatypes)))
-      (let ((arg (pop args-tail)))
-	(multiple-value-bind (wrapper class type)
-	    (if (eq mt 't)
-		(values nil *the-class-t* 't)
-		(let ((wrapper (wrapper-of arg)))
-		  (when (invalid-wrapper-p wrapper)
-		    (setq invalid-wrapper-p t)
-		    (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))))
-    (let* ((wrappers (nreverse wrappers-rev))
-	   (classes (nreverse classes-rev))
-	   (types (mapcar #'(lambda (class) `(class-eq ,class)) classes)))
-      (multiple-value-bind (methods all-applicable-and-sorted-p)
-	  (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)
-                         (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)
-              (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 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)
-      (method-function-funcall
-         (get-secondary-dispatch-function1 
-	   gf methods types all-applicable-and-sorted-p)
-	   nil (mapcar #'class-wrapper classes)))))
+      (function-funcall (get-secondary-dispatch-function1 
+			 gf methods types nil t 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))))
-    (method-constant-value (car methods))))
+    (method-function-get (or (method-fast-function (car methods))
+			     (method-function (car methods)))
+			 :constant-value)))
 
 (defun default-secondary-dispatch-function (generic-function)
   #'(lambda (&rest args)
       (let ((methods (compute-applicable-methods generic-function args)))
 	(if methods
-	    (method-function-apply
-              (get-effective-method-function generic-function methods)
-	      args)
+	    (let ((emf (get-effective-method-function generic-function methods)))
+	      (invoke-emf emf args))
 	    (apply #'no-applicable-method generic-function args)))))
 
 (defun list-eq (x y)
@@ -1899,8 +789,6 @@
 
 (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))
@@ -1914,7 +802,6 @@
 				    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)))
 
@@ -1922,23 +809,23 @@
 
 (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)
-		   (memq old-method methods))
-	       *old-c-a-m-gf-methods*)
+    (if (and *old-c-a-m-gf-methods*
+	     (every #'(lambda (old-method)
+			(member old-method methods))
+		    *old-c-a-m-gf-methods*))
 	(let ((gfs-to-do nil)
 	      (gf-classes-to-do nil))
 	  (dolist (method methods)
-	    (unless (memq method *old-c-a-m-gf-methods*)
+	    (unless (member 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 (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)))))
+	       (when (or (member gf gfs-to-do)
+			 (dolist (class gf-classes-to-do nil)
+			   (member class (class-precedence-list (class-of gf)))))
 		 (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)))
@@ -1948,25 +835,24 @@
   (update-gf-simple-accessor-type gf))
 
 (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))))
+  (unless (early-gf-p gf)
+    (multiple-value-bind (c-a-m-emf std-p)
+	(compute-applicable-methods-emf gf)
+      (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)))))
 
 (defun update-gf-simple-accessor-type (gf)
   (let ((arg-info (gf-arg-info gf)))
     (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)
@@ -1975,137 +861,51 @@
 			   *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* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
+  (let* ((std-method (standard-svuc-method type))
+	 (str-method (structure-svuc-method type))
+	 (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 (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
-                  methods type)))
-    (declare (type list methods) (type boolean std-p))
+	 (std-p (null (cdr methods))))
     (values
      (if std-p
 	 (get-optimized-std-accessor-method-function class slotd type)
-	 (let ((wrappers NIL))
+	 (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)))
 	   (unless (and (eq type 'writer)
 			(dolist (method methods t)
 			  (unless (eq (car (method-specializers method))
 				      *the-class-t*)
 			    (return nil))))
-             (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)))
+	     (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))
      std-p)))
 
-(defvar *new-class* nil)
-
 ;used by optimize-slot-value-by-class-p (vector.lisp)
 (defun update-slot-value-gf-info (gf type)
-  (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)))
-
-
+  (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))
+		 (compute-slot-accessor-info slotd type gf)))))
+      (if *new-class*
+	  (update-class *new-class*)
+	  (map-all-classes #'update-class 'slot-object)))))
 
 (defvar *standard-slot-value-using-class-method* nil)
 (defvar *standard-setf-slot-value-using-class-method* nil)
@@ -2159,78 +959,6 @@
 			'structure-effective-slot-definition))
 	       (set-structure-svuc-method type method)))))))
 
-(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
-
-(defmacro with-hash-table ((table test) &body forms)
-  `(let* ((.free. (assoc ',test *free-hash-tables*))
-	  (,table (if (cdr .free.)
-		      (pop (cdr .free.))
-		      (make-hash-table :test ',test))))
-     (multiple-value-prog1
-	 (progn ,@forms)
-       (clrhash ,table)
-       (push ,table (cdr .free.)))))
-
-(defmacro with-eq-hash-table ((table) &body forms)
-  `(with-hash-table (,table eq) ,@forms))
-
-(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 (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)))
-               (standard-object-p (class-standard-p specl))
-	       (slot-name (accessor-method-slot-name method)))
-          (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))
-          (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)
-                 (assure-finalized class)
-		 (dolist (sclass (class-precedence-list class)
-			  (error "This can't happen"))
-		   (let ((a (assq sclass specl+slotd-list)))
-		     (when a
-		       (let* ((slotd (cdr a))
-			      (index (slot-definition-location slotd)))
-			 (unless index (return-from make-accessor-table nil))
-			 (setf (gethash class table) index)
-			 (when (consp index) (setq no-class-slots-p nil))
-			 (setq all-index (if (or (null all-index)
-						 (eql all-index index))
-					     index t))
-			 (setf size (the index (1+ size)))
-			 (cond ((= size 1) (setq first class))
-			       ((= size 2) (setq second class)))
-			 (return nil))))))
-	     table)
-    (values table all-index first second size no-class-slots-p)))
-
 (defun mec-all-classes-internal (spec precompute-p)
   (cons (specializer-class spec)
 	(and (classp spec)
@@ -2276,14 +1004,12 @@
 	 (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)
@@ -2296,28 +1022,24 @@
 		  (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)
-	    (when (eql-specializer-p spec) (return t)))
-      (return t))))
-
 (defmacro class-test (arg class)
   (cond ((eq class *the-class-t*)
 	 't)
 	((eq class *the-class-slot-object*)
+	 #+new-kcl-wrapper
+	 `(or (std-instance-p ,arg)
+	      (fsc-instance-p ,arg))
+	 #-new-kcl-wrapper
 	 `(not (eq *the-class-built-in-class* 
-		(wrapper-class (std-instance-wrapper (class-of ,arg))))))
+		   (wrapper-class (std-instance-wrapper (class-of ,arg))))))
+	#-new-kcl-wrapper
 	((eq class *the-class-standard-object*)
-	 `(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)))
+	 `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
+	((eq class *the-class-structure-object*)
+	 `(memq ',class (class-precedence-list (class-of ,arg))))
+	;; TYPEP is now sometimes faster than doing memq of the cpl
 	(t
-	 `(memq ',class (class-precedence-list (class-of ,arg))))))
+	 `(typep ,arg ',(class-name class)))))
 
 (defmacro class-eq-test (arg class)
   `(eq (class-of ,arg) ',class))
@@ -2333,9 +1055,13 @@
 (defmacro scase (arg &rest clauses) ; This is case, but without gensyms
   `(let ((.case-arg. ,arg))
      (cond ,@(mapcar #'(lambda (clause)
-			 (list* (cond ((listp (car clause))
-				       `(memq .case-arg. ',(car clause)))
-				      ((memq (car clause) '(t otherwise))
+			 (list* (cond ((null (car clause))
+				       nil)
+				      ((consp (car clause))
+				       (if (null (cdar clause))
+					   `(eql .case-arg. ',(caar clause))
+					   `(member .case-arg. ',(car clause))))
+				      ((member (car clause) '(t otherwise))
 				       `t)
 				      (t
 				       `(eql .case-arg. ',(car clause))))
@@ -2379,9 +1105,7 @@
 					     (dnet-methods-p false-value)))
 				    'mcase
 				    'scase))
-		      (type-sym (if (memq (cadr type) '(t nil otherwise))
-				    `(,(cadr type))
-				    (cadr type))))
+		      (type-sym `(,(cadr type))))
 		 `(,case-sym ,arg
 		    (,type-sym ,true-value)
 		    ,@false-clauses))
@@ -2405,7 +1129,7 @@
         (class-eq (cadr type))
         (class (cadr type)))))
 
-(defun precompute-effective-methods (gf &optional classes-list-p)
+(defun precompute-effective-methods (gf caching-p &optional classes-list-p)
   (let* ((arg-info (gf-arg-info gf))
 	 (methods (generic-function-methods gf))
 	 (precedence (arg-info-precedence arg-info))
@@ -2417,10 +1141,13 @@
 	 (when methods
 	   (when classes-list-p
 	     (push (mapcar #'class-from-type known-types) classes-list))
-	   (map-all-orders 
+	   (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p methods))))
+	     (map-all-orders 
 	      methods precedence
 	      #'(lambda (methods)
-		  (get-secondary-dispatch-function gf methods known-types)))))
+		  (get-secondary-dispatch-function1 
+		   gf methods known-types
+		   nil caching-p no-eql-specls-p))))))
      #'(lambda (position type true-value false-value)
 	 (declare (ignore position type true-value false-value))
 	 nil)
@@ -2441,132 +1168,167 @@
 	(unless (eq (car new-type) 'not)
 	  (setq so-far
 		(mapcan #'(lambda (type)
-			    (unless (*subtypep type new-type)
+			    (unless (*subtypep new-type type)
 			      (list type)))
 			so-far)))
 	(if (null so-far)
 	    new-type
 	    `(and ,new-type ,@so-far)))))
 
-(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
+#+lcl3.0 (dont-use-production-compiler)
+
+(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)))
-    (declare (type index nreq))
-    (declare (special nreq metatypes))
-      (generate-discrimination-net-internal-do-column precedence methods ())))
+    (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)
 
 (defun compute-secondary-dispatch-function (generic-function net &optional 
 					    method-alist wrappers)
-  (funcall-function (compute-secondary-dispatch-function1 generic-function net)
+  (function-funcall (compute-secondary-dispatch-function1 generic-function net)
 		    method-alist wrappers))
 
+(defvar *eq-case-table-limit* 15)
 (defvar *case-table-limit* 10)
-(declaim (type index *case-table-limit*))
+
+(defun compute-mcase-parameters (case-list)
+  (unless (eq 't (caar (last case-list)))
+    (error "The key for the last case arg to mcase was not T"))
+  (let* ((eq-p (dolist (case case-list t)
+		 (unless (or (eq (car case) 't)
+			     (symbolp (caar case)))
+		   (return nil))))
+	 (len (1- (length case-list)))
+	 (type (cond ((= len 1)
+		      :simple)
+		     ((<= len
+			  (if eq-p
+			      *eq-case-table-limit*
+			      *case-table-limit*))
+		      :assoc)
+		     (t
+		      :hash-table))))
+    (list eq-p type)))
+
+(defmacro mlookup (key info default &optional eq-p type)
+  (unless (or (eq eq-p 't) (null eq-p))
+    (error "Invalid eq-p argument"))
+  (ecase type
+    (:simple
+     `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
+          (cdr ,info)
+          ,default))
+    (:assoc
+     `(dolist (e ,info ,default)
+        (when (,(if eq-p 'eq 'eql) (car e) ,key)
+	  (return (cdr e)))))
+    (:hash-table
+     `(gethash ,key ,info ,default))))
 
 (defun net-test-converter (form)
-  (cond ((and (consp form) (eq (car form) 'methods))
+  (if (atom form)
+      (default-test-converter form)
+      (case (car form)
+	((invoke-effective-method-function invoke-fast-method-call)
+	 '.call.)
+	(methods
 	 '.methods.)
-	((and (consp form) (eq (car form) 'unordered-methods))
+	(unordered-methods
 	 '.umethods.)
-	((and (consp form) (eq (car form) 'mcase)
-	      (< *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)))
+	(mcase
+	 `(mlookup ,(cadr form) nil nil ,@(compute-mcase-parameters (cddr form))))
+	(t (default-test-converter form)))))
+
+(defun net-code-converter (form)
+  (if (atom form)
+      (default-code-converter form)
+      (case (car form)
+	((methods unordered-methods)
 	 (let ((gensym (gensym)))
-	   (values (make-dfun-call metatypes applyp gensym)
+	   (values gensym
 		   (list gensym))))
-	((and (consp form) (eq (car form) 'mcase)
-	      (< *case-table-limit* (length (the list (cddr form)))))
-	 (let ((gensym (gensym)) (default (gensym)))
-	   (values (make-dfun-call metatypes applyp 
-				   `(gethash ,(cadr form) ,gensym ,default))
+	(mcase
+	 (let ((mp (compute-mcase-parameters (cddr form)))
+	       (gensym (gensym)) (default (gensym)))
+	   (values `(mlookup ,(cadr form) ,gensym ,default ,@mp)
 		   (list gensym default))))
-	(t (default-code-converter form))))
+	(t
+	 (default-code-converter form)))))
 
 (defun net-constant-converter (form generic-function)
   (or (let ((c (methods-converter form generic-function)))
 	(when c (list c)))
-      (cond ((and (consp form) (eq (car form) 'mcase)
-		  (< *case-table-limit* (length (the list (cddr form)))))
-	     (let* ((list (mapcar #'(lambda (clause)
+      (if (atom form)
+	  (default-constant-converter form)
+	  (case (car form)
+	    (mcase
+	     (let* ((mp (compute-mcase-parameters (cddr form)))
+		    (list (mapcar #'(lambda (clause)
 				      (let ((key (car clause))
 					    (meth (cadr clause)))
 					(cons (if (consp key) (car key) key)
-					      (methods-converter meth
-								 generic-function))))
+					      (methods-converter
+					       meth generic-function))))
 				  (cddr form)))
 		    (default (car (last list))))
-	       (list (list* '.table. (nbutlast list))
+	       (list (list* ':mcase mp (nbutlast list))
 		     (cdr default))))
-	    (t (default-constant-converter form)))))
+	    (t
+	     (default-constant-converter form))))))
 
 (defun methods-converter (form generic-function)
   (cond ((and (consp form) (eq (car form) 'methods))
@@ -2582,35 +1344,67 @@
       constant))
 
 (defun convert-table (constant method-alist wrappers)
-  (when (and (consp constant)
-	     (eq (car constant) '.table.))
-    (let ((table (make-hash-table :test 'eql)))
-      (dolist (k+v (cdr constant))
-	(setf (gethash (car k+v) table)
-	      (convert-methods (cdr k+v) method-alist wrappers)))
-      table)))
-
-(defun compute-secondary-dispatch-function1 (generic-function net)
+  (cond ((and (consp constant)
+	      (eq (car constant) ':mcase))
+	 (let ((alist (mapcar #'(lambda (k+m)
+				  (cons (car k+m)
+					(convert-methods (cdr k+m)
+							 method-alist wrappers)))
+			      (cddr constant)))
+	       (mp (cadr constant)))
+	   (ecase (cadr mp)
+	     (:simple
+	      (car alist))
+	     (:assoc
+	      alist)
+	     (:hash-table
+	      (let ((table (make-hash-table :test (if (car mp) 'eq 'eql))))
+		(dolist (k+m alist)
+		  (setf (gethash (car k+m) table) (cdr k+m)))
+		table)))))))
+
+(defun compute-secondary-dispatch-function1 (generic-function net &optional function-p)
   (if (eq (car net) 'methods)
       (get-effective-method-function1 generic-function (cadr net))
-      (multiple-value-bind (cfunction constants)
-	  (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)
+      (let* ((name (generic-function-name generic-function))
+	     (arg-info (gf-arg-info generic-function))
+	     (metatypes (arg-info-metatypes arg-info))
+	     (applyp (arg-info-applyp arg-info))
+	     (fmc-arg-info (cons (length metatypes) applyp))
+	     (arglist (if function-p
+			  (make-dfun-lambda-list metatypes applyp)
+			  (make-fast-method-call-lambda-list metatypes applyp))))
+	(multiple-value-bind (cfunction constants)
+	    (get-function1 `(lambda ,arglist
+			      ,(unless function-p
+				 `(declare (ignore .pv-cell. .next-method-call.)))
+			      (let ((emf ,net))
+			        ,(make-emf-call metatypes applyp 'emf)))
 			   #'net-test-converter
+			   #'net-code-converter
 			   #'(lambda (form)
-			       (net-code-converter form metatypes applyp))
-			   #'(lambda (form)
-			       (net-constant-converter form generic-function))))
-	#'(lambda (method-alist wrappers)
-	    (apply-function
-                   cfunction
-		   (mapcar #'(lambda (constant)
-			       (or (convert-table constant method-alist wrappers)
-				   (convert-methods constant method-alist wrappers)))
-			   constants))))))
+			       (net-constant-converter form generic-function)))
+	  #'(lambda (method-alist wrappers)
+	      (let* ((alist (list nil))
+		     (alist-tail alist))
+		(dolist (constant constants)
+		  (let* ((a (or (dolist (a alist nil)
+				  (when (eq (car a) constant)
+				    (return a)))
+				(cons constant
+				      (or (convert-table
+					   constant method-alist wrappers)
+					  (convert-methods
+					   constant method-alist wrappers)))))
+			 (new (list a)))
+		    (setf (cdr alist-tail) new)
+		    (setf alist-tail new)))
+		(let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
+		  (if function-p
+		      function
+		      (make-fast-method-call
+		       :function (set-function-name function `(sdfun-method ,name))
+		       :arg-info fmc-arg-info)))))))))
 
 (defvar *show-make-unordered-methods-emf-calls* nil)
 
@@ -2622,73 +1416,8 @@
       (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)))
-	(apply-function emf args))))
-
-;;;
-;;; NOTE: We are assuming a restriction on user code that the method
-;;;       combination must not change once it is connected to the
-;;;       generic function.
-;;;
-;;;       This has to be legal, because otherwise any kind of method
-;;;       lookup caching couldn't work.  See this by saying that this
-;;;       cache, is just a backing cache for the fast cache.  If that
-;;;       cache is legal, this one must be too.
-;;;
-;;; 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)
-  (funcall-function (get-secondary-dispatch-function1 
-		     gf methods types
-		     (not (methods-contain-eql-specializer-p methods)))
-		    method-alist wrappers))
-
-(defun get-secondary-dispatch-function1 (gf methods types 
-					    &optional all-applicable-p
-					    (all-sorted-p t))
-  (if (null methods)
-      #'(lambda (method-alist wrappers)
-	  (declare (ignore method-alist wrappers))
-	  #'(lambda (&rest args)
-	      (apply #'no-applicable-method gf args)))
-      (let* ((key (car methods))
-	     (ht-value (or (gethash key *effective-method-table*)
-			   (setf (gethash key *effective-method-table*)
-				 (cons nil nil)))))
-	(if (and (null (cdr methods)) all-applicable-p) ; the most common case
-	    (or (car ht-value)
-		(setf (car ht-value)
-		      (get-secondary-dispatch-function2 
-		       gf methods types all-applicable-p all-sorted-p)))
-	    (let ((akey (list methods (if all-applicable-p 'all-applicable types))))
-	      (or (cdr (assoc akey (cdr ht-value) :test #'equal))
-		  (let ((value (get-secondary-dispatch-function2 
-				gf methods types all-applicable-p all-sorted-p)))
-		    (push (cons akey value) (cdr ht-value))
-		    value)))))))
-
-(defun get-secondary-dispatch-function2 (gf methods types all-applicable-p all-sorted-p)
-  (if (and all-applicable-p all-sorted-p)
-      (let* ((combin (generic-function-method-combination gf))
-	     (effective (compute-effective-method gf combin methods)))
-	(make-effective-method-function1 gf effective))
-      (let ((net (generate-discrimination-net 
-		  gf methods types all-sorted-p)))
-	(compute-secondary-dispatch-function1 gf net))))
-
-(defun get-effective-method-function (gf methods &optional method-alist wrappers)
-  (funcall-function (get-secondary-dispatch-function1 gf methods nil t)
-		    method-alist wrappers))
+	(invoke-emf emf args))))
 
-(defun get-effective-method-function1 (gf methods &optional (sorted-p t))
-  (get-secondary-dispatch-function1 gf methods nil t sorted-p))
-
-(defun get-dispatch-function (gf)
-  (let ((methods (generic-function-methods gf)))
-    (funcall-function (get-secondary-dispatch-function1 gf methods nil nil nil)
-		      nil nil)))
 
 ;;;
 ;;; The value returned by compute-discriminating-function is a function
@@ -2772,29 +1501,17 @@
 ;;;
 ;;;
 ;;;
-(defun gf-dfun-cache (gf)
-  (let ((state (gf-dfun-state gf)))
-    (typecase state
-      (function nil)
-      (cons (cadr state)))))
-
-(defun gf-dfun-info (gf)
-  (let ((state (gf-dfun-state gf)))
-    (typecase state
-      (function nil)
-      (cons (cddr state)))))
-
 (defun slot-value-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (method-function-funcall (slot-definition-reader-function slotd) object))
+  (function-funcall (slot-definition-reader-function slotd) object))
 
 (defun setf-slot-value-using-class-dfun (new-value class object slotd)
   (declare (ignore class))
-  (method-function-funcall (slot-definition-writer-function slotd) new-value object))
+  (function-funcall (slot-definition-writer-function slotd) new-value object))
 
 (defun slot-boundp-using-class-dfun (class object slotd)
   (declare (ignore class))
-  (method-function-funcall (slot-definition-boundp-function slotd) object))
+  (function-funcall (slot-definition-boundp-function slotd) object))
 
 (defmethod compute-discriminating-function ((gf standard-generic-function))
   (with-slots (dfun-state arg-info) gf
@@ -2818,38 +1535,18 @@
       (function dfun-state)
       (cons (car dfun-state)))))
 
-(defun set-dfun (generic-function &optional dfun cache info)
-  (setf (gf-dfun-state generic-function) 
-	(if (and dfun (or cache info))
-	    (list* dfun cache info)
-	    dfun))
-  dfun)
-
-(defun update-dfun (generic-function &optional dfun cache info)
-  (let ((ocache (gf-dfun-cache generic-function)))
-    (set-dfun generic-function dfun cache info)
-    (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)
-	(name (generic-function-name gf))
+	#|| (name (generic-function-name gf)) ||#
 	(arg-info (gf-arg-info gf)))
-    (cond ((eq name 'slot-value-using-class)
+    (cond #||
+	  ((eq name 'slot-value-using-class)
 	   (update-slot-value-gf-info gf 'reader))
 	  ((equal name '(setf slot-value-using-class))
 	   (update-slot-value-gf-info gf 'writer))
 	  ((eq name 'slot-boundp-using-class)
 	   (update-slot-value-gf-info gf 'boundp))
+	  ||#
 	  ((gf-precompute-dfun-and-emf-p arg-info)
 	   (multiple-value-bind (dfun cache info)
 	       (make-final-dfun-internal gf)
@@ -2859,65 +1556,30 @@
 ;;;
 ;;;
 ;;;
-(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))
+      (analyze-lambda-list (if (consp method)
+			       (early-method-lambda-list method)
+			       (method-lambda-list method)))
     (declare (ignore nreq nopt keysp restp))
     (values keywords allow-other-keys-p)))
 
 (defun method-ll->generic-function-ll (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)))
-
+  (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)))
 
+
 ;;;
 ;;; 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))
@@ -2947,3 +1609,29 @@
 	(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 99f527877..fef7419e7 100644
--- a/pcl/notes.text
+++ b/pcl/notes.text
@@ -1,231 +1,280 @@
-
-These notes correspond to the "July 92 PCL" version of PCL.
+These notes correspond to the "August 5 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
-
-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).
+[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 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.
+  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
 
 -------------------------
-New gfs which obey AMOP ch 6, and some caveats:
-
-documentation
-  Stored in all classes, pcl::documentation works as defined.
 
-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:
+gfs which obey AMOP ch 6
+  accessor-method-slot-definition
+  add-dependent
+  add-direct-method
+  add-direct-subclass
+  add-method
+  allocate-instance
+  compute-class-precedence-list
+  compute-default-initargs
+  compute-discriminating-function  
+  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
+  make-method-lambda
+  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
 
 compute-applicable-methods
 compute-applicable-methods-using-classes
   Handles class-eq specializers without signalling an error.  
-  See march-92-notes.text
-
-compute-discriminating-function
-  [the resulting function works differently different because 
-   compute-effective-method is different, and because make-method-lambda 
-   does not exist.]
+  But see "Initialization of method metaobjects", below.
 
 compute-effective-method
-  Returns only one value.
-
--------------------------
-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.
+  Returns only one value. 
 
+generic-function-argument-precedence-order
+  Not yet defined.  Can get this information from the arg-info structure.
 
--------------------------
-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.
-
--------------------------
-Useful extensions to CLOS and AMOP:
-
-boundp-method-class
-finalize-all-classes
-
-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.
-
+generic-function-declarations
+  Not yet defined.
 
--------------------------
-Useful low-level extensions to PCL:
+reader-method-class
+  Not yet defined.  Some bootstrapping considerations are involved, 
+  but adding this will not be very hard.
 
-Class wrappers now have one unreserved field available for programmer use
-  (accessed by wrapper-unreserved-field).
+(setf class-name)
+  Currently just a writer method.  Does not call reinitialize-instance or
+  (setf find-class).
 
-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).
+(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:
+
+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.
+1.  In expand-defmethod-internal, optimize calls to generic-functions.
+  Add the support for this optimization.
+
+2.   [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 2ee226b4c..7bf4b476e 100644
--- a/pcl/pcl-env.lisp
+++ b/pcl/pcl-env.lisp
@@ -328,9 +328,7 @@ arg-types."
 (defun pcl-object-p (x)
   "Is the datum a PCL object?"
   (or (std-instance-p x)
-      (fsc-instance-p x)
-      #+pcl-user-instances
-      (user-instance-p x)))
+      (fsc-instance-p x)))
 
 (defun \\internal-inspect-object (x type where)
   (inspect-object x type where))
@@ -1332,8 +1330,8 @@ window"
 		  (found-method nil)
 		  ((eq (il:stkname current-pos) 'apply)
 		   (dolist (method methods)
-		     (when (memq (il:stkarg 1 current-pos)
-				 (method-cached-functions method))
+		     (when (eq (method-function method)
+			       (il:stkarg 1 current-pos))
 		       (setq method-pos current-pos)
 		       (setq found-method method)
 		       (return))))))))
@@ -1361,10 +1359,10 @@ window"
 	  (setq gf (generic-function-from-frame current-pos))
 	  (when gf
 	    (dolist (method (generic-function-methods gf))
-	      (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)))))
+	      (when (function-matches-frame-p (method-function method)
+					      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 9b5931e1c..b09f2f47a 100644
--- a/pcl/pkg.lisp
+++ b/pcl/pkg.lisp
@@ -36,6 +36,7 @@
 	  variable-globally-special-p
 	  *variable-declarations*
 	  variable-declaration
+	  macroexpand-all
 	  ))
 
 (in-package :iterate :use '(:lisp :walker))
@@ -73,12 +74,9 @@
 
 #+Lucid 
 (import '(#-LCL3.0 system:arglist #+LCL3.0 lcl:arglist
-	  system:structurep system:structure-type system:structure-length
-          #-*lisp-hardware lucid::boolean
-          #+*lisp-hardware *lisp:boolean)
+	  system:structurep system:structure-type system:structure-length)
 	*the-pcl-package*)
-
-
+  
 #+lucid
 (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
     #+LCL3.0 ((lcl:warning #'(lambda (condition)
@@ -139,7 +137,7 @@
 
 #+kcl
 (progn
-(import '(system:structurep))
+(import '(si:structurep si:structure-def si:structure-ref))
 (shadow 'lisp:dotimes)
 )
 #+kcl
@@ -147,23 +145,17 @@
 #+kcl
 (export '(%structure-name
           %compiled-function-name
-          %set-compiled-function-name))
+          %set-compiled-function-name
+	  %instance-ref
+	  %set-instance-ref))
 #+kcl
 (in-package 'pcl)
 
 #+cmu (shadow 'lisp:dotimes)
 
 #+cmu
-(import '(kernel:funcallable-instance-p ext:structurep c::boolean)
+(import '(kernel:funcallable-instance-p ext:structurep)
 	*the-pcl-package*)
-
-#+CMU
-(eval-when (compile)
-  (setq c:*suppress-values-declaration* T))
-
-#-(or cmu lucid)
-(deftype boolean () '(member t nil))
-
 
 
 (shadow 'documentation)
@@ -187,7 +179,6 @@
 		    defgeneric
 		    define-method-combination
 		    defmethod
-		    describe-object
 		    ensure-generic-function
 		    find-class
 		    find-method
@@ -332,7 +323,6 @@
           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
@@ -356,10 +346,21 @@
 
 #+(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))))
 
+#+kcl
+(when (get 'si::basic-wrapper 'si::s-data)
+  (import (mapcar #'(lambda (s) (intern (symbol-name s) "SI"))
+		  '(:copy-structure-header :swap-structure-contents :set-structure-def
+		    :%instance-ref :%set-instance-ref
+		    
+		    :cache-number-vector :cache-number-vector-length
+		    :wrapper-cache-number-adds-ok :wrapper-cache-number-length
+		    :wrapper-cache-number-mask :wrapper-cache-number-vector-length
+		    :wrapper-layout :wrapper-cache-number-vector
+		    :wrapper-state :wrapper-class :wrapper-length))))
diff --git a/pcl/plap.lisp b/pcl/plap.lisp
index e491a5d1f..622dd5c3c 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 index ,@(mapcar #'lap-reg *lap-i-regs*))
+	   (declare (type fixnum ,@(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,13 +127,15 @@
 
 (defvar *empty-vector* '#())
 (defvar *empty-fixnum-vector*
-  (make-array 8 :initial-element 0))
+  (make-array 8
+	      :element-type 'fixnum
+	      :initial-element 0))
  
 (defun lap-reg-initial-value-form (reg)
-  (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)
+  (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)
         (t
          (error "What kind of register is ~S?" reg))))
 
@@ -155,9 +157,6 @@
 
     (: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)
@@ -166,13 +165,16 @@
     (:structure-instance-p (from label)
      `(when ,(lap-operands 'RUNTIME\ STRUCTURE-INSTANCE-P from) (go ,label)))	;***
     
-    (:jmp (fn)
+    ((:jmp :emf-call) (fn)
      (if (eq *lap-args* 'lap-in-lisp)
 	 (error "Can't do a :JMP in LAP-IN-LISP.")
 	 `(return
-	    ,(if *lap-rest-p*
-		 `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
-		 `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*)))))
+	    ,(if (eq (car opcode) :jmp)
+		 (if *lap-rest-p*
+		     `(RUNTIME\ APPLY ,(lap-operand fn) ,@*lap-args* .lap-rest-arg.)
+		     `(RUNTIME\ FUNCALL ,(lap-operand fn) ,@*lap-args*))
+		 `(RUNTIME\ EMF-CALL ,(lap-operand fn) ,*lap-rest-p* ,@*lap-args*
+		                     ,@(when *lap-rest-p* `(.lap-rest-arg.)))))))
 
     (:return (value)
      `(return ,(lap-operand value)))
@@ -195,23 +197,17 @@
     (: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
-      #+pcl-user-instances :user-wrapper
-      #+pcl-user-instances :user-slots)
+      :wrapper-cache-number-vector)
      (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))
@@ -226,6 +222,11 @@
     (:iref    (vector index)       (lap-operands 'RUNTIME\ IREF vector index))
     (:iset    (vector index value) (lap-operands 'RUNTIME\ ISET vector index value))
 
+    (:instance-ref (vector index)
+		   (lap-operands 'RUNTIME\ INSTANCE-REF vector index))
+    (:instance-set (vector index value)
+		   (lap-operands 'RUNTIME\ INSTANCE-SET vector index value))
+
     (:cref   (vector i)       `(RUNTIME\ SVREF ,(lap-operand vector) ,i))
     (:lisp-variable (symbol) symbol)
     (:lisp          (form)   form)
@@ -248,10 +249,15 @@
 (proclaim '(declaration pcl-fast-call))
 
 (defmacro RUNTIME\ FUNCALL (fn &rest args)
-  `(method-function-funcall ,fn ,.args))
+  #+CMU `(funcall (the function ,fn) ,.args)
+  #-CMU `(funcall ,fn ,.args))
 
 (defmacro RUNTIME\ APPLY (fn &rest args)
-  `(method-function-apply ,fn ,.args))
+  #+CMU `(apply (the function ,fn) ,.args)
+  #-CMU `(apply ,fn ,.args))
+
+(defmacro RUNTIME\ EMF-CALL (emf restp &rest required-args+rest-arg)
+  `(invoke-effective-method-function ,emf ,restp ,@required-args+rest-arg))
 
 (defmacro RUNTIME\ STD-WRAPPER (x)
   `(std-instance-wrapper ,x))
@@ -259,10 +265,6 @@
 (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))
 
@@ -281,10 +283,6 @@
 (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))
 
@@ -294,15 +292,11 @@
 (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 index ,x)))
+  `(zerop (the fixnum ,x)))
 
 (defmacro RUNTIME\ FIX= (x y)
-  `(= (the index ,x) (the index ,y)))
+  `(= (the fixnum ,x) (the fixnum ,y)))
 
 ;;;
 ;;; These are the implementations of the index operands.  The portable
@@ -313,29 +307,47 @@
 ;;; Some compilers are so stupid...
 ;;;
 (defmacro RUNTIME\ IREF (vector index)
-  `(svref (the simple-vector ,vector) (the index ,index)))
+  #-structure-wrapper
+  `(svref (the simple-vector ,vector) (the fixnum ,index))
+  #+structure-wrapper
+  `(aref ,vector (the fixnum ,index)))
 
 (defmacro RUNTIME\ ISET (vector index value)
-  `(setf (svref (the simple-vector ,vector) (the index ,index)) ,value))
-
-(defmacro RUNTIME\ SVREF (vector index)
-  `(svref (the simple-vector ,vector) (the index ,index)))
+  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value))
+
+(defmacro RUNTIME\ INSTANCE-REF (vector index)
+  #-new-kcl-wrapper
+  `(svref (the simple-vector ,vector) (the fixnum ,index))
+  #+new-kcl-wrapper
+  `(%instance-ref ,vector (the fixnum ,index)))
+
+(defmacro RUNTIME\ INSTANCE-SET (vector index value)
+  #-new-kcl-wrapper
+  `(setf (svref (the simple-vector ,vector) (the fixnum ,index)) ,value)
+  #+new-kcl-wrapper
+  `(setf (%instance-ref ,vector (the fixnum ,index)) ,value))
+
+(defmacro RUNTIME\ SVREF (vector fixnum)
+  #-structure-wrapper
+  `(svref (the simple-vector ,vector) (the fixnum ,fixnum))
+  #+structure-wrapper
+  `(aref ,vector (the fixnum ,fixnum)))
 
 (defmacro RUNTIME\ I+ (index1 index2)
-  `(the index (+ (the index ,index1) (the index ,index2))))
+  `(the fixnum (+ (the fixnum ,index1) (the fixnum ,index2))))
 
 (defmacro RUNTIME\ I- (index1 index2)  
-  `(the index (- (the index ,index1) (the index ,index2))))
+  `(the fixnum (- (the fixnum ,index1) (the fixnum ,index2))))
 
 (defmacro RUNTIME\ I1+ (index)
-  `(the index (1+ (the index ,index))))
+  `(the fixnum (1+ (the fixnum ,index))))
 
 (defmacro RUNTIME\ ILOGAND (index1 index2)
-  #-Lucid `(the index (logand (the index ,index1) (the index ,index2)))
+  #-Lucid `(the fixnum (logand (the fixnum ,index1) (the fixnum ,index2)))
   #+Lucid `(%logand ,index1 ,index2))
 
 (defmacro RUNTIME\ ILOGXOR (index1 index2)
-  `(the index (logxor (the index ,index1) (the index ,index2))))
+  `(the fixnum (logxor (the fixnum ,index1) (the fixnum ,index2))))
 
 ;;;
 ;;; In the portable implementation, indexes are just fixnums.
@@ -347,15 +359,11 @@
 (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))
-    (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))))
+    (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)))
     mask))
 
 
diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp
index 8c7f43153..695222bd3 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.4 1992/08/01 15:29:51 ram Exp $
+;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.5 1992/11/09 15:21:37 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
@@ -360,7 +360,7 @@
 	   ; can be either simple (both args registers)
 	   ; or one arg can be complex and the other simple
 	   (case (car op2)
-	     (:iref
+	     ((:iref :instance-ref)
 	      ;; assume that this is a lisp store
 	      ;;(warn "assuming lisp store in ~s" lap)
 	      (let (op1-treg)
@@ -424,12 +424,9 @@
 				   (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-fun
+		(qe call :arg 'pcl::built-in-or-structure-wrapper
 		    :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)
@@ -451,7 +448,7 @@
 			       (get-treg-of (cadr op1)))
 		      :d (list (get-treg-of op2)))))
 		      
-	       ((:iref :cref)
+	       ((:iref :cref :instance-ref)
 		(let (op1-treg)
 		  (if* (not (vector-preg-p (cadr op1)))
 		     then ; must offset before store
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
index 159da0af6..2bbcab0b6 100644
--- a/pcl/slots.lisp
+++ b/pcl/slots.lisp
@@ -27,6 +27,15 @@
 
 (in-package 'pcl)
 
+(defmethod wrapper-fetcher ((class standard-class))
+  'std-instance-wrapper)
+
+(defmethod slots-fetcher ((class standard-class))
+  'std-instance-slots)
+
+(defmethod raw-instance-allocator ((class standard-class))
+  'allocate-standard-instance)
+
 ;;;
 ;;; These four functions work on std-instances and fsc-instances.  These are
 ;;; instances for which it is possible to change the wrapper and the slots.
@@ -36,832 +45,138 @@
 ;;; std-class.  Many of these methods call these four functions.
 ;;;
 
-(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)
-  `(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))
-        #+pcl-user-instances
-        ((user-instance-p inst)
-         (setf (user-instance-wrapper inst) new))
-        (t
-         (wrapper-error inst))))
-
+	 #+new-kcl-wrapper
+	 (set-structure-def inst new)
+	 #-new-kcl-wrapper
+	 (setf (std-instance-wrapper inst) new))
+	((fsc-instance-p inst)
+	 (setf (fsc-instance-wrapper inst) new))
+	(t
+	 (error "What kind of instance is this?"))))
+
+#+ignore ; can't do this when using #+new-kcl-wrapper
 (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))
-        #+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)
+	 (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 swap-wrappers-and-slots (i1 i2)
+  (without-interrupts
+   (cond ((std-instance-p i1)
+	  #+new-kcl-wrapper
+	  (swap-structure-contents i1 i2)
+	  #-new-kcl-wrapper
+	  (let ((w1 (std-instance-wrapper i1))
+		(s1 (std-instance-slots i1)))
+	    (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
+	    (setf (std-instance-slots i1) (std-instance-slots i2))
+	    (setf (std-instance-wrapper i2) w1)
+	    (setf (std-instance-slots i2) s1)))
+	 ((fsc-instance-p i1)
+	  (let ((w1 (fsc-instance-wrapper i1))
+		(s1 (fsc-instance-slots i1)))
+	    (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
+	    (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
+	    (setf (fsc-instance-wrapper i2) w1)
+	    (setf (fsc-instance-slots i2) s1)))
+	 (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))))
 
 (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)))
 
-
-;;;
-;;; 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 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))))
+  (dolist (slot (class-slots class) nil)
+    (when (eql slot-name (slot-definition-name slot))
+      (return slot))))
 
 (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 'setf)
-        (setf (slot-value-using-class class object slot-definition) new-value))))
+	(slot-missing class object slot-name 'slot-value)
+	(slot-value-using-class class object slot-definition))))
 
-(defsetf slow-slot-value slow-set-slot-value)
+(setf (symbol-function 'slot-value-normal) #'slot-value)
 
-(defmacro accessor-set-slot-value (object slot-name-form new-value)
+(define-compiler-macro slot-value (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))))
-      (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)
-
-
+	   (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)))
 
 (defun set-slot-value (object slot-name new-value)
-  (fast-set-slot-value object slot-name new-value))
-
-(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form)
-  `(fast-set-slot-value ,object-form ,slot-name-form ,new-value-form))
-
-(eval-when (compile load eval)
-(defconstant *optimize-slot-boundp* nil))
-
-(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))))
+	(slot-missing class object slot-name 'setf)
+	(setf (slot-value-using-class class object slot-definition) 
+	      new-value))))
 
-(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))))))))
+(setf (symbol-function 'set-slot-value-normal) #'set-slot-value)
 
-(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))))))
+(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)))
 
-(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))))
+(defconstant *optimize-slot-boundp* nil)
 
 (defun slot-boundp (object slot-name)
-  (fast-slot-boundp object slot-name))
+  (let* ((class (class-of object))
+	 (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))))
 
-(define-compiler-macro slot-boundp (object-form slot-name-form)
-  `(fast-slot-boundp ,object-form ,slot-name-form))
+(setf (symbol-function 'slot-boundp-normal) #'slot-boundp)
 
+(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)))
 
 (defun slot-makunbound (object slot-name)
   (let* ((class (class-of object))
@@ -871,10 +186,8 @@
         (slot-makunbound-using-class class object slot-definition))))
 
 (defun slot-exists-p (object slot-name)
-  (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))))
+  (let ((class (class-of object)))
+    (not (null (find-slot-definition class slot-name)))))
 
 ;;;
 ;;; This isn't documented, but is used within PCL in a number of print
@@ -885,435 +198,188 @@
       (slot-value object slot-name)
       default))
 
-
+
 ;;;
 ;;; 
 ;;; 
 (defun standard-instance-access (instance location)
-  (%svref (std-instance-slots instance) location))
+  (%instance-ref (std-instance-slots instance) location))
 
 (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)
+  (%instance-ref (fsc-instance-slots instance) location))
 
 (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))
-                         #+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, ~@
+	 (value (typecase location
+		  (fixnum 
+		   (cond ((std-instance-p object)
+			  (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+			    (check-wrapper-validity object))
+			  (%instance-ref (std-instance-slots object) location))
+			 ((fsc-instance-p object)
+			  (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+			    (check-wrapper-validity object))
+			  (%instance-ref (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, ~@
                            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))
-             #+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))))
+	      (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+		(check-wrapper-validity object))
+	      (setf (%instance-ref (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 (%instance-ref (fsc-instance-slots object) location) new-value))
+	     (t (error "What kind of instance is this?"))))
       (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))
-                         #+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, ~@
+	 (value (typecase location
+		  (fixnum 
+		   (cond ((std-instance-p object)
+			  (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+			    (check-wrapper-validity object))
+			  (%instance-ref (std-instance-slots object) location))
+			 ((fsc-instance-p object)
+			  (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+			    (check-wrapper-validity object))
+			  (%instance-ref (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, ~@
                            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*))
-             #+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))))
+	      (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+		(check-wrapper-validity object))
+	      (setf (%instance-ref (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 (%instance-ref (fsc-instance-slots object) location) *slot-unbound*))
+	     (t (error "What kind of instance is this?"))))
       (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))
-  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)))
-    (method-function-funcall function object)))
+  (let* ((function (slot-definition-internal-reader-function slotd))
+	 (value (funcall function object)))
+    #+cmu (declare (type function function))
+    (if (eq value *slot-unbound*)
+	(slot-unbound class object (slot-definition-name slotd))
+	value)))
 
 (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)))
-    (method-function-funcall function new-value object)))
+    #+cmu (declare (type function function))
+    (funcall function new-value object)))
 
 (defmethod slot-boundp-using-class
-           ((class structure-class) 
-            (object structure-object)
-            (slotd structure-effective-slot-definition))
-  t)
+	   ((class structure-class) 
+	    (object structure-object)
+	    (slotd structure-effective-slot-definition))
+  #-new-kcl-wrapper t
+  #+new-kcl-wrapper
+  (let* ((function (slot-definition-internal-reader-function slotd))
+	 (value (funcall function object)))
+    #+cmu (declare (type function function))
+    (not (eq value *slot-unbound*))))
 
 (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))
 
-
-(defun structure-slot-boundp (object)
-  (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)
-      (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 (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)))))
-   `(reader ,slot-name)))
-
-(defun make-optimized-std-writer-method-function (instance-type slot-name index)
-  (declare #.*optimize-speed*)
-  (set-function-name
-   (etypecase index
-     (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))))
-   `(writer ,slot-name)))
-
-(defun make-optimized-std-boundp-method-function (instance-type slot-name index)
-  (declare #.*optimize-speed*)
-  (set-function-name
-   (etypecase 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))))))
-   `(boundp ,slot-name)))
-
-#+pcl-user-instances
-(defun make-optimized-user-reader-method-function (slot-name index)
-  (declare #.*optimize-speed*)
-  (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*)
-  #'(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*)
-  #'(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)
-  (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)
-                 (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-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)
-      (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))))
+(defun slot-unbound-internal (instance position)
+  (slot-unbound (class-of instance) instance 
+		(etypecase position
+		  (fixnum 
+		   (nth position 
+			(wrapper-instance-slots-layout (wrapper-of instance))))
+		  (cons
+		   (car position)))))
+
+
+(defmethod allocate-instance ((class standard-class) &rest initargs)
+  (declare (ignore initargs))
+  (unless (class-finalized-p class) (finalize-inheritance class))
+  (allocate-standard-instance (class-wrapper class)))
+
+(defmethod allocate-instance ((class structure-class) &rest initargs)
+  (declare (ignore initargs))
+  #-new-kcl-wrapper
+  (let ((constructor (class-defstruct-constructor class)))
+    (if constructor
+	(funcall constructor)
+	(error "Can't allocate an instance of class ~S" (class-name class))))
+  #+new-kcl-wrapper
+  (allocate-standard-instance (class-wrapper class)))
 
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index cc73962d1..f41dd8668 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -33,39 +33,29 @@
     (writer (slot-definition-writer-function slotd))
     (boundp (slot-definition-boundp-function slotd))))
 
-(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))
+(defmethod (setf slot-accessor-function) (function 
+					  (slotd effective-slot-definition) type)
   (ecase type
-    (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*))))
+    (reader (setf (slot-definition-reader-function slotd) function))
+    (writer (setf (slot-definition-writer-function slotd) function))
     (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 index flags))
+    (declare (type fixnum flags))
     (if (eq type 'all)
-	(= *slotd-all-function-std-p* flags)
+	(eql *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 index mask))
-	  (not (zerop (the index (logand mask flags))))))))
+	  (declare (type fixnum mask))
+	  (not (zerop (the fixnum (logand mask flags))))))))
 
 (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
   (let ((mask (ecase type
@@ -73,73 +63,56 @@
 		(writer *slotd-writer-function-std-p*)
 		(boundp *slotd-boundp-function-std-p*)))
 	(flags (slot-value slotd 'accessor-flags)))
-    (declare (type index mask flags))
+    (declare (type fixnum mask flags))
     (setf (slot-value slotd 'accessor-flags)
 	  (if value
-	      (the index (logior mask flags))
-	      (the index (logand (the index (lognot mask)) flags)))))
+	      (the fixnum (logior mask flags))
+	      (the fixnum (logand (the fixnum (lognot mask)) flags)))))
   value)
 
-(defvar *name->class->slotd-table* (make-hash-table))
-
 (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
   (let* ((name (slot-value slotd 'name))
-	 (class (slot-value slotd 'class))
-	 (old-slotd (and (slot-boundp class 'slots)
-                         (find-slot-definition class name))))
+	 (class (slot-value slotd 'class)))
     (let ((table (or (gethash name *name->class->slotd-table*)
 		     (setf (gethash name *name->class->slotd-table*)
 			   (make-hash-table :test 'eq :size 5)))))
       (setf (gethash class table) slotd))
     (dolist (type '(reader writer boundp))
-      (multiple-value-bind (function std-p)
-	  (if (eq *boot-state* 'complete)
-	      (let* ((gf-name (ecase type
-				(reader 'slot-value-using-class)
-				(writer '(setf slot-value-using-class))
-				(boundp 'slot-boundp-using-class)))
-		     (gf (gdefinition gf-name)))
-		(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)
-        (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))
-  (setf (internal-slotd-location (slot-value slotd 'internal-slotd))
-        location)
-  (initialize-internal-slot-functions slotd))
-
+      (let* ((gf-name (ecase type
+			      (reader 'slot-value-using-class)
+			      (writer '(setf slot-value-using-class))
+			      (boundp 'slot-boundp-using-class)))
+	     (gf (gdefinition gf-name)))
+	(compute-slot-accessor-info slotd type gf)))
+    (initialize-internal-slot-gfs name)))
+
+(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf)
+  (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))))
+    (multiple-value-bind (function std-p)
+	(if (eq *boot-state* 'complete)
+	    (get-accessor-method-function gf type class slotd)
+	    (get-optimized-std-accessor-method-function class slotd type))
+      #+kcl (si:turbo-closure function)
+      (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) *pv-table-cache-update-info*))))
+
+(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))
 
@@ -148,57 +121,49 @@
   (error "Can't change the documentation of ~S." object))
 
 
-(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 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 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))
+  (with-slots (wrapper) class
+    (not (null wrapper))))
 
 (defmethod class-prototype ((class std-class))
   (with-slots (prototype) class
-    (or prototype
-        (if (memq class *classes-being-updated*)
-            (allocate-instance class)
-            (setq prototype (make-class-prototype class))))))
+    (or prototype (setq prototype (allocate-instance class)))))
+
+(defmethod class-prototype ((class structure-class))
+  (with-slots (prototype wrapper defstruct-constructor) class
+    (or prototype 
+	(setq prototype 
+	      (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil 
+		  (allocate-instance class)
+		  (allocate-standard-instance wrapper))))))
 
-(defmethod make-class-prototype ((class std-class))
-  (let ((proto (allocate-instance class)))
-    (shared-initialize proto T :check-initargs-legality-p NIL)
-    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 class-constructors ((class slot-class))
   (plist-value class 'constructors))
@@ -206,24 +171,6 @@
 (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
@@ -336,15 +283,7 @@
 		  (dolist (m (car entry))
 		    (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)))
@@ -359,7 +298,6 @@
   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))
@@ -387,7 +325,29 @@
 						  ,(load-truename))
 			     other))
 
-(declaim (ftype (function (T T) (values T list)) ensure-class-values))
+(setf (symbol-function 'load-defclass) #'real-load-defclass)
+
+(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))
+
 (defun ensure-class-values (class args)
   (let* ((initargs (copy-list args))
 	 (unsupplied (list 1))
@@ -422,42 +382,19 @@
 		     (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 (name nil name-p))
+				      &key direct-superclasses)
   (declare (ignore slot-names))
-  (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)))
-
+  ;; *** error checking
+  )
+||#
+  
 (defmethod shared-initialize :after
 	   ((class std-class)
 	    slot-names
@@ -480,12 +417,11 @@
   (setq direct-slots
 	(if direct-slots-p
 	    (setf (slot-value class 'direct-slots)
-		  (mapcar #'(lambda (pl) (apply #'make-direct-slotd class pl))
-                          direct-slots))
+		  (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
 	    (slot-value class 'direct-slots)))
   (if direct-default-initargs-p
-      (setf (slot-value class 'direct-default-initargs) direct-default-initargs)
-      (setq direct-default-initargs (class-direct-default-initargs class)))
+      (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
+      (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
   (setf (plist-value class 'class-slot-cells)
 	(gathering1 (collecting)
 	  (dolist (dslotd direct-slots)
@@ -493,24 +429,21 @@
 	      (let ((initfunction (slot-definition-initfunction dslotd)))
 		(gather1 (cons (slot-definition-name dslotd)
 			       (if initfunction 
-				   (slot-initfunction-funcall initfunction)
+				   (funcall initfunction)
 				   *slot-unbound*))))))))
-  (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)))
+  (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))))))
   (add-direct-subclasses class direct-superclasses)
-  (add-slot-accessors    class direct-slots))
+  (update-class class nil)
+  (make-class-predicate class predicate-name)
+  (add-slot-accessors class direct-slots))
 
-(defmethod shared-initialize :before ((class class) slot-names &key)
-  (declare (ignore slot-names))
+(defmethod shared-initialize :before ((class class) slot-names &key name)
+  (declare (ignore slot-names name))
   (setf (slot-value class 'type) `(class ,class))
   (setf (slot-value class 'class-eq-specializer)
 	(make-instance 'class-eq-specializer :class class)))
@@ -519,70 +452,127 @@
   (remove-direct-subclasses class (class-direct-superclasses class))
   (remove-slot-accessors    class (class-direct-slots class)))
 
-(defmethod reinitialize-instance :after ((class std-class)
+(defmethod reinitialize-instance :after ((class slot-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 #'(lambda (slot)
+					 `(,(slot-definition-name slot)
+					   *slot-unbound*))
+			             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))
+  #-new-kcl-wrapper
+  (unless (slot-value class 'wrapper) 
+    (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
+  #+new-kcl-wrapper
+  (let ((wrapper (get (class-name class) 'si::s-data)))
+    (setf (slot-value class 'wrapper) wrapper)
+    (setf (wrapper-class wrapper) class))
+  (update-pv-table-cache-info 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)
-  (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
-                (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
-              (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))
 
@@ -590,20 +580,19 @@
   (fix-slot-accessors class dslotds 'remove))
 
 (defun fix-slot-accessors (class dslotds add/remove)  
-  (flet ((fix (gfspec name dslot r/w)
+  (flet ((fix (gfspec name r/w)
 	   (let ((gf (ensure-generic-function gfspec)))
 	     (case r/w
 	       (r (if (eq add/remove 'add)
-		      (add-reader-method class gf name dslot)
+		      (add-reader-method class gf name)
 		      (remove-reader-method class gf)))
 	       (w (if (eq add/remove 'add)
-		      (add-writer-method class gf name dslot)
+		      (add-writer-method class gf name)
 		      (remove-writer-method class gf)))))))
     (dolist (dslotd dslotds)
-      (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))
+      (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))))))
 
 
 (defun add-direct-subclasses (class new)
@@ -620,34 +609,27 @@
 ;;;
 ;;;
 ;;;
-
-(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))
-    (push class *classes-being-updated*)
+  (when (or finalizep (class-finalized-p class)
+	    (not (class-has-a-forward-referenced-superclass-p class)))
     (update-cpl class (compute-class-precedence-list class))
-    (update-slots class)
+    (update-slots class (compute-slots class))
     (update-gfs-of-class class)
     (update-inits class (compute-default-initargs class))
-    (update-constructors class)
-    (setf *classes-being-updated* (delete class *classes-being-updated*)))
+    (update-constructors class))
   (unless finalizep
     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
 
@@ -655,141 +637,98 @@
   (when (class-finalized-p class)
     (unless (equal (class-precedence-list class) cpl)
       (force-cache-flushes class)))
-  (fast-set-slot-value class 'class-precedence-list cpl slow-slot-value)
+  (setf (slot-value class 'class-precedence-list) cpl)
   (update-class-can-precede-p cpl))
 
 (defun update-class-can-precede-p (cpl)
   (when cpl
-    (let* ((first (car cpl))
-           (orig-precede-list
-             (fast-slot-value first 'can-precede-list slow-slot-value))
-           (precede-list orig-precede-list))
+    (let ((first (car cpl)))
       (dolist (c (cdr cpl))
-        (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)))
+	(pushnew c (slot-value first 'can-precede-list))))
     (update-class-can-precede-p (cdr cpl))))
 
 (defun class-can-precede-p (class1 class2)
-  (memq class2 (class-can-precede-list class1)))
-
+  (member class2 (class-can-precede-list class1)))
 
-(declaim (ftype (function (T T) (values list list)) compute-storage-info))
-(defmethod compute-storage-info ((class std-class) eslotds)
+(defun update-slots (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)))))
-    (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)
+    ;;
+    ;; 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)))
+	   (nslots (length nlayout))
+	   (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 nslots 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 slots) class
+	#+new-kcl-wrapper
+	(setf (si::s-data-name nwrapper) (class-name class))
+	(setf slots eslotds
+	      (wrapper-instance-slots-layout nwrapper) nlayout
+	      (wrapper-class-slots nwrapper) nwrapper-class-slots
+	      (wrapper-no-of-instance-slots nwrapper) nslots
+	      wrapper nwrapper))
+      (unless (eq owrapper nwrapper)
+	(update-pv-table-cache-info class)))))
+
+(defun compute-class-slots (eslotds)
   (gathering1 (collecting)
     (dolist (eslotd eslotds)
       (gather1
-	(assq (slot-definition-name eslotd)
-	      (class-slot-cells (slot-definition-allocation eslotd)))))))
+	(assoc (slot-definition-name eslotd)
+	       (class-slot-cells (slot-definition-allocation eslotd)))))))
 
-(defmethod compute-layout ((class std-class) cpl instance-eslotds)
+(defun compute-layout (cpl instance-eslotds)
   (let* ((names
 	   (gathering1 (collecting)
 	     (dolist (eslotd instance-eslotds)
-	       (gather1 (slot-definition-name eslotd)))))
+	       (when (eq (slot-definition-allocation eslotd) :instance)
+		 (gather1 (slot-definition-name eslotd))))))
 	 (order ()))
     (labels ((rwalk (tail)
 	       (when tail
 		 (rwalk (cdr tail))
-		 (dolist (ss (class-direct-slots (car tail)))
+		 (dolist (ss (class-slots (car tail)))
 		   (let ((n (slot-definition-name ss)))
-		     (when (memq n names)
+		     (when (member n names)
 		       (setq order (cons n order)
 			     names (remove n names))))))))
-      (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))))
+      (rwalk (if (slot-boundp (car cpl) 'slots)
+		 cpl
+		 (cdr cpl)))
+      (reverse (append names order)))))
 
 (defun update-gfs-of-class (class)
-  (when (let ((cpl (class-precedence-list class)))
-	  (or (memq *the-class-slot-class* cpl)
-	      (memq *the-class-standard-effective-slot-definition* cpl)))
+  (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))))
     (let ((gf-table (make-hash-table :test 'eq)))
       (labels ((collect-gfs (class)
 		 (dolist (gf (specializer-direct-generic-functions class))
@@ -802,7 +741,7 @@
 		 gf-table)))))
 
 (defun update-inits (class inits)
-  (setf (slot-value class 'default-initargs) inits))
+  (setf (plist-value class 'default-initargs) inits))
 
 
 ;;;
@@ -833,6 +772,10 @@
   (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)))
+
 ;;;
 ;;;
 ;;;
@@ -844,7 +787,7 @@
   ;; The list is in most-specific-first order.
   ;;
   (let ((name-dslotds-alist ()))
-    (dolist (c (slot-value class 'class-precedence-list))
+    (dolist (c (class-precedence-list class))
       (let ((dslotds (class-direct-slots c)))
 	(dolist (d dslotds)
 	  (let* ((name (slot-definition-name d))
@@ -854,66 +797,54 @@
 		(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 (slot-value class 'class-precedence-list))
+	(cpl (class-precedence-list class))
 	(instance-slots ())
-	(class-slots    ())
-        (other-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))
-              (T                    (push eslotd other-slots)))))
-    (let ((nlayout (compute-layout class cpl instance-slots)))
-      (declare (type list nlayout))
+	      ((classp alloc)       (push eslotd class-slots)))))
+    (let ((nlayout (compute-layout cpl instance-slots)))
       (dolist (eslotd instance-slots)
 	(setf (slot-definition-location eslotd) 
-	      (posq (slot-definition-name eslotd) nlayout))))
+	      (position (slot-definition-name eslotd) nlayout))))
     (dolist (eslotd class-slots)
       (setf (slot-definition-location eslotd) 
-	    (assq (slot-definition-name eslotd)
-		  (class-slot-cells (slot-definition-allocation eslotd)))))
-    (dolist (eslotd other-slots)
-      (initialize-internal-slot-functions eslotd))
+	    (assoc (slot-definition-name eslotd)
+		   (class-slot-cells (slot-definition-allocation eslotd)))))
+    (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))
 
-(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))
-         (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)
+(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)
+    eslotds))
+
+(defmethod compute-effective-slot-definition ((class slot-class) 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))
+	 (class (effective-slot-definition-class class initargs)))
+    (apply #'make-instance class initargs)))
 
 (defmethod effective-slot-definition-class ((class std-class) initargs)
   (declare (ignore initargs))
-  *the-class-standard-effective-slot-definition*)
+  (find-class 'standard-effective-slot-definition))
+
+(defmethod effective-slot-definition-class ((class structure-class) initargs)
+  (declare (ignore initargs))
+  (find-class 'structure-effective-slot-definition))
 
 (defmethod compute-effective-slot-definition-initargs 
     ((class slot-class) direct-slotds)
@@ -922,16 +853,10 @@
 	 (initform nil)
 	 (initargs nil)
 	 (allocation nil)
-         (documentation nil)
 	 (type t)
 	 (namep  nil)
 	 (initp  nil)
-	 (allocp nil)
-         (readers nil)
-         (writers nil)
-         (initfunction-side-effect-free-p nil))
-       (declare (type boolean namep initp allocp
-                              initfunction-side-effect-free-p))
+	 (allocp nil))
 
     (dolist (slotd direct-slotds)
       (when slotd
@@ -939,11 +864,9 @@
 	  (setq name (slot-definition-name slotd)
 		namep t))
 	(unless initp
-	  (setq initform (slot-definition-initform slotd))
 	  (when (slot-definition-initfunction slotd)
-	    (setq initfunction (slot-definition-initfunction slotd)
-                  initfunction-side-effect-free-p
-                    (slot-definition-initfunction-side-effect-free-p slotd)
+	    (setq initform (slot-definition-initform slotd)
+		  initfunction (slot-definition-initfunction slotd)
 		  initp t)))
 	(unless allocp
 	  (setq allocation (slot-definition-allocation slotd)
@@ -952,162 +875,65 @@
 	(let ((slotd-type (slot-definition-type slotd)))
 	  (setq type (cond ((eq type 't) slotd-type)
 			   ((*subtypep type slotd-type) 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))))
+			   (t `(and ,type ,slotd-type)))))))
     (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
-          :documentation documentation
-          :readers readers
-          :writers writers)))
-
-
+	  :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))))
 
 ;;;
 ;;; 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
-                              &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-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.
+(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
   (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.
+  (find-class 'standard-reader-method))
+
+(defmethod add-reader-method ((class slot-class) generic-function slot-name)
+  (add-method generic-function 
+	      (make-a-method 'standard-reader-method
+			     ()
+			     (list (or (class-name class) 'object))
+			     (list class)
+			     (make-reader-method-function class slot-name)
+			     "automatically generated reader method"
+			     slot-name)))
+
+(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
   (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)
-
+  (find-class 'standard-writer-method))
+
+(defmethod add-writer-method ((class slot-class) generic-function slot-name)
+  (add-method generic-function
+	      (make-a-method 'standard-writer-method
+			     ()
+			     (list 'new-value (or (class-name class) 'object))
+			     (list *the-class-t* class)
+			     (make-writer-method-function class slot-name)
+			     "automatically generated writer method"
+			     slot-name)))
+
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
+  (add-method generic-function 
+	      (make-a-method 'standard-boundp-method
+			     ()
+			     (list (or (class-name class) 'object))
+			     (list class)
+			     (make-boundp-method-function class slot-name)
+			     "automatically generated boundp method"
+			     slot-name)))
 
 (defmethod remove-reader-method ((class slot-class) generic-function)
   (let ((method (get-method generic-function () (list class) nil)))
@@ -1138,225 +964,14 @@
 ;;; *** 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)
+  (make-std-reader-method-function (class-name 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-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))
-
-(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)))
-
-
-
-(defvar *internal-reader-gf-table* (make-hash-table :test 'eql))
-(defvar *internal-writer-gf-table* (make-hash-table :test 'eql))
-(defvar *internal-boundp-gf-table* (make-hash-table :test 'eql))
-
-(defun get-reader-function (slot-name)
-  (or (gethash slot-name *internal-reader-gf-table*)
-      (error "No class has a slot named ~s" slot-name)))
-
-(defun get-writer-function (slot-name)
-  (or (gethash slot-name *internal-writer-gf-table*)
-      (error "No class has a slot named ~s" slot-name)))
-
-(defun get-boundp-function (slot-name)
-  (or (gethash slot-name *internal-boundp-gf-table*)
-      (error "No class has a slot named ~s" 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))))
-
-(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))))
-
-(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))))
+(defmethod make-writer-method-function ((class slot-class) slot-name)
+  (make-std-writer-method-function (class-name class) slot-name))
+
+(defmethod make-boundp-method-function ((class slot-class) slot-name)
+  (make-std-boundp-method-function (class-name class) slot-name))
 
 
 ;;;; inform-type-system-about-class
@@ -1372,7 +987,6 @@
 (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,
@@ -1430,18 +1044,15 @@
     ;; means do what FLUSH does and then some.
     ;; 
     (when (eq state 't)
-      (let ((nwrapper (make-wrapper class)))
+      (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+				    class)))
 	(setf (wrapper-instance-slots-layout nwrapper)
 	      (wrapper-instance-slots-layout owrapper))
 	(setf (wrapper-class-slots nwrapper)
 	      (wrapper-class-slots owrapper))
-	(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
+	(without-interrupts
 	  (setf (slot-value class 'wrapper) nwrapper)
-	  (invalidate-wrapper owrapper 'flush nwrapper))
+	  (invalidate-wrapper owrapper ':flush nwrapper))
 	(update-constructors class)))))		;??? ***
 
 (defun flush-cache-trap (owrapper nwrapper instance)
@@ -1456,22 +1067,17 @@
 ;;; update-instance-for-redefined-class mechanism.
 ;;; 
 (defmethod make-instances-obsolete ((class std-class))
-  (let ((owrapper (class-wrapper class))
-	(nwrapper (make-wrapper class)))
+  (let* ((owrapper (class-wrapper class))
+	 (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+				 class)))
       (setf (wrapper-instance-slots-layout nwrapper)
 	    (wrapper-instance-slots-layout owrapper))
       (setf (wrapper-class-slots nwrapper)
 	    (wrapper-class-slots owrapper))
-      (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
+      (without-interrupts
 	(setf (slot-value class 'wrapper) nwrapper)
-	(invalidate-wrapper owrapper 'obsolete nwrapper)
-	class)
-      (dolist (generic-function (class-cached-in-generic-functions class))
-        (update-dfun generic-function))))
+	(invalidate-wrapper owrapper ':obsolete nwrapper)
+	class)))
 
 (defmethod make-instances-obsolete ((class symbol))
   (make-instances-obsolete (find-class class)))
@@ -1508,11 +1114,7 @@
   ;;  --    --> 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))
+  (let* ((class (wrapper-class* nwrapper))
 	 (guts (allocate-instance class))	;??? allocate-instance ???
 	 (olayout (wrapper-instance-slots-layout owrapper))
 	 (nlayout (wrapper-instance-slots-layout nwrapper))
@@ -1522,8 +1124,6 @@
 	 (added ())
 	 (discarded ())
 	 (plist ()))
-    (declare (list olayout nlayout oclass-slots added discarded plist)
-             (simple-vector oslots nslots))
     ;;
     ;; Go through all the old local slots.
     ;; 
@@ -1531,10 +1131,10 @@
 	      (opos (interval :from 0)))
       (let ((npos (posq name nlayout)))
 	(if npos
-	    (setf (svref nslots npos) (svref oslots opos))
+	    (setf (instance-ref nslots npos) (instance-ref oslots opos))
 	    (progn (push name discarded)
-		   (unless (eq (svref oslots opos) *slot-unbound*)
-		     (setf (getf plist name) (svref oslots opos)))))))
+		   (unless (eq (instance-ref oslots opos) *slot-unbound*)
+		     (setf (getf plist name) (instance-ref oslots opos)))))))
     ;;
     ;; Go through all the old shared slots.
     ;;
@@ -1543,7 +1143,7 @@
 	    (val (cdr oclass-slot-and-val)))
 	(let ((npos (posq name nlayout)))
 	  (if npos
-	      (setf (svref nslots npos) (cdr oclass-slot-and-val))
+	      (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
 	      (progn (push name discarded)
 		     (unless (eq val *slot-unbound*)
 		       (setf (getf plist name) val)))))))
@@ -1555,9 +1155,7 @@
 		  (assq nlocal oclass-slots))
 	(push nlocal added)))
       
-    (without-interrupts-simple
-      (set-wrapper instance nwrapper)
-      (set-slots instance nslots))
+    (swap-wrappers-and-slots instance guts)
 
     (update-instance-for-redefined-class instance
 					 added
@@ -1570,19 +1168,29 @@
 ;;;
 ;;;
 ;;;
-(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
-  `(let* ((old-class (class-of instance))
-	  (copy (,alloc old-class))
-	  (guts (,alloc new-class))
-	  (new-wrapper (,wrapper-fetcher guts))
-	  (old-wrapper (class-wrapper old-class))
-	  (old-layout (wrapper-instance-slots-layout old-wrapper))
-	  (new-layout (wrapper-instance-slots-layout new-wrapper))
-	  (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))
+(defmacro copy-instance-internal (instance)
+  `(#+new-kcl-wrapper if #-new-kcl-wrapper progn
+			 #+new-kcl-wrapper (not (std-instance-p ,instance))
+      (let* ((class (class-of instance))
+	     (copy (allocate-instance class)))
+	 (if (std-instance-p ,instance)
+	     (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
+	     (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
+	 copy)
+      #+new-kcl-wrapper
+      (copy-structure-header ,instance)))
+
+(defun change-class-internal (instance new-class)
+  (let* ((old-class (class-of instance))
+	 (copy (copy-instance-internal instance))
+	 (guts (allocate-instance new-class))
+	 (new-wrapper (get-wrapper guts))
+	 (old-wrapper (class-wrapper old-class))
+	 (old-layout (wrapper-instance-slots-layout old-wrapper))
+	 (new-layout (wrapper-instance-slots-layout new-wrapper))
+	 (old-slots (get-slots instance))
+	 (new-slots (get-slots guts))
+	 (old-class-slots (wrapper-class-slots old-wrapper)))
 
     ;;
     ;; "The values of local slots specified by both the class Cto and
@@ -1593,8 +1201,8 @@
 	      (new-position (interval :from 0)))
       (let ((old-position (posq new-slot old-layout)))
 	(when old-position
-	  (setf (svref new-slots new-position)
-		(svref old-slots old-position)))))
+	  (setf (instance-ref new-slots new-position)
+		(instance-ref old-slots old-position)))))
 
     ;;
     ;; "The values of slots specified as shared in the class Cfrom and
@@ -1603,15 +1211,11 @@
     (iterate ((slot-and-val (list-elements old-class-slots)))
       (let ((position (posq (car slot-and-val) new-layout)))
 	(when position
-	  (setf (svref new-slots position) (cdr slot-and-val)))))
+	  (setf (instance-ref new-slots position) (cdr slot-and-val)))))
 
     ;; Make the copy point to the old instance's storage, and make the
     ;; old instance point to the new storage.
-    (without-interrupts-simple
-      (setf (,slots-fetcher copy) old-slots)
-      
-      (setf (,wrapper-fetcher instance) new-wrapper)
-      (setf (,slots-fetcher instance) new-slots))
+    (swap-wrappers-and-slots instance guts)
 
     (update-instance-for-different-class copy instance)
     instance))
@@ -1624,9 +1228,7 @@
 	   instance
 	   new-class
 	   'standard-class))
-  (change-class-internal std-instance-wrapper
-			 std-instance-slots
-			 allocate-instance))
+  (change-class-internal instance new-class))
 
 (defmethod change-class ((instance standard-object)
 			 (new-class funcallable-standard-class))
@@ -1636,9 +1238,7 @@
 	   instance
 	   new-class
 	   'funcallable-standard-class))
-  (change-class-internal fsc-instance-wrapper
-			 fsc-instance-slots
-			 allocate-instance))
+  (change-class-internal instance new-class))
 
 (defmethod change-class ((instance t) (new-class-name symbol))
   (change-class instance (find-class new-class-name)))
@@ -1660,6 +1260,11 @@
   (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*))
 
@@ -1670,7 +1275,7 @@
 ;;;
 
 (defmethod validate-superclass ((c slot-class)
-				(f forward-referenced-class))
+						(f forward-referenced-class))
   't)
 
 
@@ -1686,35 +1291,6 @@
 	(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/sys-package.lisp b/pcl/sys-package.lisp
index 88249cf04..82af68aec 100644
--- a/pcl/sys-package.lisp
+++ b/pcl/sys-package.lisp
@@ -28,9 +28,9 @@
          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::FIND-METHOD-COMBINATION PCL::UPDATE-DEPENDENT
+         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
@@ -41,7 +41,7 @@
          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::REINITIALIZE-INSTANCE
          PCL::STANDARD-METHOD PCL::STANDARD-ACCESSOR-METHOD
          PCL::FUNCALLABLE-STANDARD-INSTANCE PCL::FUNCTION-KEYWORDS
          PCL::STANDARD PCL::FIND-METHOD PCL::EXTRACT-SPECIALIZER-NAMES
@@ -88,9 +88,9 @@
          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::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))
@@ -115,7 +115,7 @@
          WALKER::NESTED-WALK-FORM WALKER::VARIABLE-DECLARATION
          WALKER::WALK-FORM-EXPAND-MACROS-P WALKER::VARIABLE-LEXICAL-P
          WALKER::VARIABLE-SPECIAL-P WALKER::WALK-FORM
-         WALKER::VARIABLE-GLOBALLY-SPECIAL-P))
+         WALKER::MACROEXPAND-ALL WALKER::VARIABLE-GLOBALLY-SPECIAL-P))
 
 ;;; Definitions for package SLOT-ACCESSOR-NAME of type SHADOW
 (LISP::IN-PACKAGE "SLOT-ACCESSOR-NAME")
@@ -127,7 +127,8 @@
 (LISP::IN-PACKAGE "PCL")
 (LISP::SHADOW '(PCL::DOTIMES PCL::DOCUMENTATION))
 (LISP::SHADOWING-IMPORT 'LISP::NIL)
-(LISP::IMPORT '(SYSTEM::STRUCTUREP))
+(LISP::IMPORT
+    '(SYSTEM::STRUCTURE-REF SYSTEM::STRUCTURE-DEF SYSTEM::STRUCTUREP))
 
 ;;; Definitions for package ITERATE of type SHADOW
 (LISP::IN-PACKAGE "ITERATE")
diff --git a/pcl/sys-proclaim.lisp b/pcl/sys-proclaim.lisp
index 3e8bef09d..97d2f9f0c 100644
--- a/pcl/sys-proclaim.lisp
+++ b/pcl/sys-proclaim.lisp
@@ -1,1162 +1,1050 @@
 
-(IN-PACKAGE "PCL") 
+(IN-PACKAGE "USER") 
+(PROCLAIM '(FTYPE (FUNCTION (*) FIXNUM) PCL::ZERO)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (FIXNUM T FIXNUM) FIXNUM)
-            COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) 
+    '(FTYPE (FUNCTION (T FIXNUM *) FIXNUM)
+            PCL::COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) FIXNUM) ARG-INFO-NUMBER-REQUIRED
-            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)) 
+    '(FTYPE (FUNCTION (T) FUNCTION) PCL::CACHE-LIMIT-FN
+            PCL::METHOD-CALL-FUNCTION PCL::FAST-METHOD-CALL-FUNCTION)) 
 (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)) 
+    '(FTYPE (FUNCTION (T) FIXNUM) PCL::DEFAULT-LIMIT-FN
+            PCL::PV-CACHE-LIMIT-FN PCL::CACHE-COUNT
+            PCL::ARG-INFO-NUMBER-REQUIRED PCL::ONE-INDEX-LIMIT-FN
+            PCL::N-N-ACCESSORS-LIMIT-FN PCL::CHECKING-LIMIT-FN
+            PCL::CACHING-LIMIT-FN PCL::CACHE-NLINES
+            PCL::CACHE-MAX-LOCATION PCL::CACHE-SIZE PCL::CACHE-MASK
+            PCL::PV-TABLE-PV-SIZE PCL::FAST-INSTANCE-BOUNDP-INDEX
+            PCL::EARLY-CLASS-SIZE)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) PCL::FIELD-TYPE) PCL::CACHE-FIELD)) 
+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM) T) PCL::POWER-OF-TWO-CEILING)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T) LIST) PCL::CACHE-OVERFLOW
+            PCL::PV-TABLE-SLOT-NAME-LISTS PCL::PV-TABLE-CALL-LIST)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) (MEMBER NIL T)) PCL::CACHE-VALUEP)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) SIMPLE-VECTOR) PCL::CACHE-VECTOR)) 
 (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 (FIXNUM T) T) MAKE-CAXR MAKE-CDXR
-            %CCLOSURE-ENV-NTHCDR)) 
+    '(FTYPE (FUNCTION (T) (VALUES T T)) PCL::MAKE-CLASS-PREDICATE-NAME
+            PCL::MAKE-KEYWORD)) 
+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T) T) PCL::%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)) 
+            PCL::COMPUTE-PRIMARY-CACHE-LOCATION)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 512)) PCL::CACHE-LINE-SIZE)) 
+(PROCLAIM '(FTYPE (FUNCTION (T) (INTEGER 1 256)) PCL::CACHE-NKEYS)) 
 (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)) 
+    '(FTYPE (FUNCTION (T) (OR PCL::CACHE NULL)) PCL::PV-TABLE-CACHE)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) (OR INDEX NULL)) ARG-INFO-NUMBER-OPTIONAL)) 
+    '(FTYPE (FUNCTION (T T T) *) PCL::OPTIMIZE-SLOT-VALUE-BY-CLASS-P
+            PCL::ACCESSOR-VALUES1 WALKER::WALK-LET-IF
+            PCL::EMIT-READER/WRITER
+            PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER PCL::GENERATING-LISP
+            PCL::SET-SLOT-VALUE PCL::EMIT-READER/WRITER-FUNCTION
+            PCL::EMIT-ONE-OR-N-INDEX-READER/WRITER-FUNCTION
+            PCL::ACCESSOR-VALUES-INTERNAL PCL::CONVERT-METHODS
+            PCL::|(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO
+    (STANDARD-GENERIC-FUNCTION))| PCL::SLOT-VALUE-USING-CLASS-DFUN
+            PCL::SLOT-BOUNDP-USING-CLASS-DFUN PCL::LOAD-LONG-DEFCOMBIN
+            PCL::CACHE-MISS-VALUES
+            PCL::|(FAST-METHOD METHOD-FUNCTION (STANDARD-METHOD))|
+            PCL::|(FAST-METHOD COMPUTE-DISCRIMINATING-FUNCTION
+    (STANDARD-GENERIC-FUNCTION))|
+            PCL::|(FAST-METHOD FUNCTION-KEYWORDS (STANDARD-METHOD))|
+            PCL::|(FAST-METHOD METHOD-PRETTY-ARGLIST (STANDARD-METHOD))|
+            PCL::GET-CLASS-SLOT-VALUE-1 ITERATE::EXPAND-INTO-LET
+            WALKER::WALK-FORM-INTERNAL ITERATE::RENAME-VARIABLES
+            PCL::ACCESSOR-VALUES ITERATE::WALK-GATHERING-BODY
+            PCL::MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
+            PCL::MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
+            PCL::MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION
+            PCL::CONSTANT-VALUE-MISS PCL::CACHING-MISS
+            PCL::CHECKING-MISS
+            PCL::GET-OPTIMIZED-STD-ACCESSOR-METHOD-FUNCTION
+            PCL::GET-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
+            PCL::|(FAST-METHOD CLASS-PROTOTYPE (STD-CLASS))|
+            PCL::|(FAST-METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))|
+            PCL::|(FAST-METHOD METHOD-LAMBDA-LIST (TRACED-METHOD))|
+            PCL::|(FAST-METHOD METHOD-SPECIALIZERS (TRACED-METHOD))|
+            PCL::|(FAST-METHOD METHOD-QUALIFIERS (TRACED-METHOD))|
+            PCL::|(FAST-METHOD ACCESSOR-METHOD-SLOT-NAME (TRACED-METHOD))|
+            PCL::MAKE-FINAL-N-N-ACCESSOR-DFUN
+            PCL::MAKE-FINAL-CACHING-DFUN
+            PCL::MAKE-FINAL-CONSTANT-VALUE-DFUN
+            PCL::|(FAST-METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))|)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T) (OR FUNCTION NULL))
-            INTERNAL-SLOTD-INITFUNCTION)) 
+    '(FTYPE (FUNCTION (T T T T) *) PCL::REAL-MAKE-METHOD-LAMBDA
+            PCL::|(FAST-METHOD CHANGE-CLASS (T SYMBOL))|
+            PCL::GET-ACCESSOR-METHOD-FUNCTION
+            PCL::EMIT-CHECKING-OR-CACHING
+            PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (SLOT-CLASS))|
+            PCL::BOOTSTRAP-ACCESSOR-DEFINITION
+            PCL::EMIT-CHECKING-OR-CACHING-FUNCTION
+            PCL::|(FAST-METHOD NO-APPLICABLE-METHOD (T))|
+            PCL::|(FAST-METHOD SLOT-ACCESSOR-FUNCTION (EFFECTIVE-SLOT-DEFINITION T))|
+            PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD LEGAL-QUALIFIERS-P (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD LEGAL-SPECIALIZERS-P (STANDARD-METHOD T))|
+            PCL::SETF-SLOT-VALUE-USING-CLASS-DFUN
+            PCL::LOAD-SHORT-DEFCOMBIN
+            PCL::|(FAST-METHOD COMPUTE-APPLICABLE-METHODS-USING-CLASSES
+    (GENERIC-FUNCTION T))| PCL::SET-CLASS-SLOT-VALUE-1
+            PCL::MAKE-SHARED-INITIALIZE-FORM-LIST
+            PCL::|(FAST-METHOD CLASS-SLOT-VALUE (STD-CLASS T))|
+            PCL::GENERATE-DISCRIMINATION-NET PCL::ORDER-SPECIALIZERS
+            PCL::MAKE-ONE-CLASS-ACCESSOR-DFUN PCL::ACCESSOR-MISS
+            PCL::|(FAST-METHOD ALLOCATE-INSTANCE (STRUCTURE-CLASS))|
+            PCL::GET-ACCESSOR-FROM-SVUC-METHOD-FUNCTION
+            PCL::|(FAST-METHOD DESCRIBE-OBJECT (T T))|
+            PCL::|(FAST-METHOD DOCUMENTATION (STANDARD-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD DESCRIBE-OBJECT (SLOT-OBJECT T))|
+            PCL::|(FAST-METHOD SLOTS-TO-INSPECT (SLOT-CLASS SLOT-OBJECT))|
+            PCL::|(FAST-METHOD DESCRIBE-OBJECT (STANDARD-GENERIC-FUNCTION T))|
+            PCL::|(FAST-METHOD DESCRIBE-OBJECT (CLASS T))|
+            PCL::|(FAST-METHOD MAKE-INSTANCE (SYMBOL))|
+            PCL::|(FAST-METHOD DEFAULT-INITARGS (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD INITIALIZE-INSTANCE (SLOT-OBJECT))|
+            PCL::|(FAST-METHOD MAYBE-UPDATE-CONSTRUCTORS (GENERIC-FUNCTION METHOD))|
+            PCL::MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN
+            PCL::MAKE-FINAL-CHECKING-DFUN)) 
 (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)) 
+    '(FTYPE (FUNCTION (T T T T T) *)
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (CLASS-EQ-SPECIALIZER T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (EQL-SPECIALIZER T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (CLASS T))|
+            PCL::ADD-METHOD-DECLARATIONS PCL::WALK-METHOD-LAMBDA
+            PCL::|(FAST-METHOD (SETF SLOT-ACCESSOR-FUNCTION)
+    (T EFFECTIVE-SLOT-DEFINITION T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-ACCESSOR-METHOD T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-GENERIC-FUNCTION T))|
+            PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-SLOT-DEFINITION T))|
+            PCL::|(FAST-METHOD (SETF CLASS-SLOT-VALUE) (T STD-CLASS T))|
+            PCL::|(FAST-METHOD SLOT-VALUE-USING-CLASS
+    (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::MAKE-TWO-CLASS-ACCESSOR-DFUN
+            PCL::|(FAST-METHOD SLOT-VALUE-USING-CLASS
+    (STRUCTURE-CLASS STRUCTURE-OBJECT
+        STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD
+    (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))|
+            PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T STANDARD-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD ADD-READER-METHOD (SLOT-CLASS T T))|
+            PCL::|(FAST-METHOD ADD-WRITER-METHOD (SLOT-CLASS T T))|
+            PCL::|(FAST-METHOD ADD-BOUNDP-METHOD (SLOT-CLASS T T))|
+            PCL::|(FAST-METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
+    (STANDARD-OBJECT STANDARD-OBJECT))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE (SLOT-OBJECT T))|)) 
 (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
-            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)) 
+    '(FTYPE (FUNCTION (T T *) *) PCL::TYPES-FROM-ARGUMENTS
+            PCL::MAKE-ACCESSOR-TABLE
+            PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION
+            PCL::GET-SIMPLE-INITIALIZATION-FUNCTION
+            PCL::GET-COMPLEX-INITIALIZATION-FUNCTIONS
+            PCL::MAKE-CHECKING-DFUN
+            PCL::MAKE-DEFAULT-INITARGS-FORM-LIST
+            PCL::SLOT-VALUE-OR-DEFAULT PCL::MAKE-N-N-ACCESSOR-DFUN
+            PCL::GET-EFFECTIVE-METHOD-FUNCTION PCL::LOAD-DEFGENERIC
+            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION
+            WALKER:NESTED-WALK-FORM)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T T T T T T T) *)
-            ITERATE::ITERATE-TRANSFORM-BODY EXPAND-DEFMETHOD-INTERNAL
-            MAKE-LAP-CLOSURE-GENERATOR)) 
+            ITERATE::ITERATE-TRANSFORM-BODY
+            PCL::|(FAST-METHOD UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+    (STANDARD-OBJECT T T T))|)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T T T T T T *) *) PCL::REAL-MAKE-A-METHOD)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T) *)
-            COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO-INTERNAL
-            MAKE-TWO-CLASS-ACCESSOR-DFUN
-            GENERATE-DISCRIMINATION-NET-INTERNAL-DO-METHODS)) 
-(PROCLAIM
-    '(FTYPE (FUNCTION (T T T *) *) WALKER::WALK-DECLARATIONS
-            GET-SECONDARY-DISPATCH-FUNCTION
-            MAKE-ONE-INDEX-ACCESSOR-DFUN)) 
+    '(FTYPE (FUNCTION (T T T T T T) *) PCL::REAL-LOAD-DEFCLASS
+            PCL::CACHE-MISS-VALUES-INTERNAL
+            PCL::GENERATE-DISCRIMINATION-NET-INTERNAL
+            PCL::|(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS)
+    (T STRUCTURE-CLASS STRUCTURE-OBJECT
+       STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::MAKE-LONG-METHOD-COMBINATION-FUNCTION
+            PCL::DO-SHORT-METHOD-COMBINATION PCL::MEMF-CODE-CONVERTER)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T T T T *) *) ITERATE::RENAME-LET-BINDINGS
-            NO-SLOT-ACCESSOR)) 
+            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE1)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T T T *) *) WALKER::WALK-DECLARATIONS
+            PCL::MAKE-ONE-INDEX-ACCESSOR-DFUN
+            PCL::GET-SECONDARY-DISPATCH-FUNCTION)) 
+(PROCLAIM '(FTYPE (FUNCTION (T STREAM T) T) PCL::PRINT-DFUN-INFO)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T *) T) EMIT-GET-CLASS-SLOT
-            EMIT-SET-CLASS-SLOT DEFOPCODE-1 CPL-ERROR
+    '(FTYPE (FUNCTION (T T *) T) PCL::CPL-ERROR
+            PCL::METHOD-FUNCTION-GET
+            PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS
+            PCL::GET-CACHE-FROM-CACHE PCL::EMIT-MISS
+            PCL::GET-METHOD-FUNCTION-PV-CELL
+            PCL::NAMED-OBJECT-PRINT-FUNCTION PCL::RECORD-DEFINITION
             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)) 
+            PCL::PRECOMPUTE-EFFECTIVE-METHODS
+            PCL::COMPUTE-SECONDARY-DISPATCH-FUNCTION1 PCL::PROBE-CACHE
+            PCL::MAP-CACHE PCL::INITIALIZE-INFO
+            PCL::GET-EFFECTIVE-METHOD-FUNCTION1
+            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-SIMPLE
+            PCL::MAKE-EMF-FROM-METHOD
+            PCL::EXPAND-EFFECTIVE-METHOD-FUNCTION
+            PCL::FIND-CLASS-FROM-CELL PCL::REAL-ADD-METHOD
+            PCL::FIND-CLASS-PREDICATE-FROM-CELL PCL::GET-DECLARATION
+            PCL::REAL-ENSURE-GF-USING-CLASS--GENERIC-FUNCTION
+            PCL::REAL-ENSURE-GF-USING-CLASS--NULL)) 
 (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 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)) 
+    '(FTYPE (FUNCTION (T T T) T) PCL::GET-NEW-FUNCTION-GENERATOR
+            PCL::|(FAST-METHOD SPECIALIZER-METHOD-TABLE (EQL-SPECIALIZER))|
+            PCL::|(FAST-METHOD SPECIALIZER-METHOD-TABLE (CLASS-EQ-SPECIALIZER))|
+            WALKER::WALK-TAGBODY-1 PCL::NOTE-PV-TABLE-REFERENCE
+            WALKER::WALK-LAMBDA
+            PCL::|(FAST-METHOD SPECIALIZER-DIRECT-METHODS (SPECIALIZER-WITH-OBJECT))|
+            PCL::|(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
+    (SPECIALIZER-WITH-OBJECT))| WALKER::WALK-COMPILER-LET
+            PCL::|(FAST-METHOD CLASS-DIRECT-SLOTS (BUILT-IN-CLASS))|
+            WALKER::WALK-UNEXPECTED-DECLARE WALKER::WALK-FLET
+            PCL::|(FAST-METHOD CLASS-SLOTS (BUILT-IN-CLASS))|
+            WALKER::WALK-IF WALKER::WALK-LABELS WALKER::WALK-LET
+            PCL::|(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (BUILT-IN-CLASS))|
+            PCL::FLUSH-CACHE-TRAP WALKER::WALK-LET*
+            PCL::OBSOLETE-INSTANCE-TRAP WALKER::WALK-MACROLET
+            WALKER::WALK-MULTIPLE-VALUE-SETQ
+            PCL::|(FAST-METHOD CLASS-DEFAULT-INITARGS (BUILT-IN-CLASS))|
+            WALKER::WALK-MULTIPLE-VALUE-BIND WALKER::WALK-SETQ
+            WALKER::WALK-SYMBOL-MACROLET WALKER::WALK-TAGBODY
+            WALKER::WALK-DO WALKER::WALK-DO* WALKER::WALK-PROG
+            WALKER::WALK-PROG* WALKER::WALK-NAMED-LAMBDA
+            PCL::OPTIMIZE-GF-CALL-INTERNAL PCL::SKIP-FAST-SLOT-ACCESS-P
+            PCL::SKIP-OPTIMIZE-SLOT-VALUE-BY-CLASS-P
+            PCL::EXPAND-DEFGENERIC
+            PCL::|(FAST-METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))|
+            PCL::EMIT-SLOT-READ-FORM PCL::EMIT-BOUNDP-CHECK
+            PCL::FIX-SLOT-ACCESSORS
+            PCL::MAKE-METHOD-INITARGS-FORM-INTERNAL
+            PCL::|(FAST-METHOD FINALIZE-INHERITANCE (STRUCTURE-CLASS))|
+            PCL::EMIT-GREATER-THAN-1-DLAP
+            PCL::|(FAST-METHOD FINALIZE-INHERITANCE (STD-CLASS))|
+            PCL::EMIT-1-T-DLAP
+            PCL::|(FAST-METHOD COMPUTE-DEFAULT-INITARGS (SLOT-CLASS))|
+            PCL::|(FAST-METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
+            PCL::|(FAST-METHOD COMPUTE-SLOTS (STD-CLASS))|
+            PCL::|(FAST-METHOD COMPUTE-SLOTS :AROUND (STD-CLASS))|
+            PCL::|(FAST-METHOD COMPUTE-SLOTS (STRUCTURE-CLASS))|
+            PCL::|(FAST-METHOD COMPUTE-SLOTS :AROUND (STRUCTURE-CLASS))|
+            PCL::|(FAST-METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
+            PCL::MAKE-METHOD-SPEC
+            PCL::NEW-ARG-INFO-FROM-GENERIC-FUNCTION PCL::PRINT-CACHE
+            PCL::SET-FUNCTION-NAME-1
+            PCL::|(FAST-METHOD METHOD-QUALIFIERS (STANDARD-METHOD))|
+            PCL::|SETF PCL METHOD-FUNCTION-GET| PCL::INVALIDATE-WRAPPER
+            PCL::PRINT-STD-INSTANCE PCL::|SETF PCL PLIST-VALUE|
+            PCL::TRACE-METHOD-INTERNAL PCL::ONE-INDEX-DFUN-INFO
+            PCL::|(FAST-METHOD GENERIC-FUNCTION-LAMBDA-LIST (GENERIC-FUNCTION))|
+            PCL::|(FAST-METHOD GF-FAST-METHOD-FUNCTION-P (STANDARD-GENERIC-FUNCTION))|
+            PCL::CONVERT-TABLE
+            PCL::|(FAST-METHOD SPECIALIZER-CLASS (CLASS))|
+            PCL::DECLARE-STRUCTURE PCL::LOAD-PRECOMPILED-IIS-ENTRY
+            PCL::|(FAST-METHOD SPECIALIZER-CLASS (EQL-SPECIALIZER))|
+            WALKER::WITH-AUGMENTED-ENVIRONMENT-INTERNAL
+            PCL::ONE-CLASS-DFUN-INFO
+            PCL::|(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-ACCESSOR-METHOD))|
+            PCL::|(FAST-METHOD ACCESSOR-METHOD-CLASS (STANDARD-WRITER-METHOD))|
+            PCL::|(FAST-METHOD GENERIC-FUNCTION-PRETTY-ARGLIST
+    (STANDARD-GENERIC-FUNCTION))| ITERATE::OPTIMIZE-ITERATE-FORM
+            PCL::|(FAST-METHOD COMPUTE-CLASS-PRECEDENCE-LIST (SLOT-CLASS))|
+            PCL::MAKE-DFUN-CALL
+            PCL::|(FAST-METHOD WRAPPER-FETCHER (STANDARD-CLASS))|
+            PCL::|(FAST-METHOD SLOTS-FETCHER (STANDARD-CLASS))|
+            PCL::|(FAST-METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))|
+            PCL::COMPUTE-PRECEDENCE PCL::FIRST-FORM-TO-LISP
+            ITERATE::OPTIMIZE-GATHERING-FORM WALKER::RECONS
+            ITERATE::SIMPLE-EXPAND-GATHERING-FORM
+            ITERATE::RENAME-AND-CAPTURE-VARIABLES
+            PCL::MAKE-TOP-LEVEL-FORM WALKER::RELIST-INTERNAL
+            ITERATE::VARIABLE-SAME-P PCL::ENTRY-IN-CACHE-P
+            PCL::MAKE-OPTIMIZED-STD-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
+            PCL::MAKE-OPTIMIZED-STD-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
+            PCL::MAKE-OPTIMIZED-STD-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
+            PCL::|(FAST-METHOD INITIALIZE-INTERNAL-SLOT-FUNCTIONS
+    (EFFECTIVE-SLOT-DEFINITION))|
+            PCL::WRAP-METHOD-GROUP-SPECIFIER-BINDINGS
+            PCL::|(FAST-METHOD SLOT-DEFINITION-ALLOCATION (STRUCTURE-SLOT-DEFINITION))|
+            PCL::MAP-ALL-ORDERS
+            PCL::|(FAST-METHOD CLASS-FINALIZED-P (PCL-CLASS))|
+            PCL::|(FAST-METHOD CLASS-DIRECT-DEFAULT-INITARGS (SLOT-CLASS))|
+            PCL::|(FAST-METHOD CLASS-DEFAULT-INITARGS (SLOT-CLASS))|
+            PCL::|(FAST-METHOD CLASS-CONSTRUCTORS (SLOT-CLASS))|
+            PCL::|(FAST-METHOD CLASS-SLOT-CELLS (STD-CLASS))|
+            PCL::CAN-OPTIMIZE-ACCESS PCL::OPTIMIZE-SLOT-VALUE
+            PCL::OPTIMIZE-SET-SLOT-VALUE PCL::OPTIMIZE-SLOT-BOUNDP
+            SYSTEM::APPLY-DISPLAY-FUN
+            PCL::|(FAST-METHOD UPDATE-CONSTRUCTORS (SLOT-CLASS))|
+            PCL::|(FAST-METHOD UPDATE-CONSTRUCTORS (CLASS))|
+            PCL::TRACE-EMF-CALL-INTERNAL
+            PCL::|(FAST-METHOD MAKE-INSTANCES-OBSOLETE (STD-CLASS))|
+            PCL::GET-FUNCTION-GENERATOR
+            PCL::|(FAST-METHOD SPECIALIZER-DIRECT-METHODS (CLASS))|
+            WALKER:VARIABLE-DECLARATION PCL::COMPUTE-STD-CPL-PHASE-3
+            PCL::|(FAST-METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))|)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T T T T) T) LOAD-DEFMETHOD-INTERNAL
-            LOAD-DEFMETHOD)) 
+    '(FTYPE (FUNCTION (T T T T) T) WALKER::WALK-LET/LET*
+            WALKER::WALK-PROG/PROG*
+            PCL::|(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT STANDARD-CLASS))|
+            WALKER::WALK-DO/DO* WALKER::WALK-BINDINGS-2
+            PCL::|(FAST-METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))|
+            PCL::|(FAST-METHOD ADD-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|
+            PCL::|(FAST-METHOD REMOVE-DIRECT-METHOD (SPECIALIZER-WITH-OBJECT METHOD))|
+            PCL::OPTIMIZE-READER PCL::OPTIMIZE-WRITER
+            PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (CLASS BUILT-IN-CLASS))|
+            PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (SLOT-CLASS FORWARD-REFERENCED-CLASS))|
+            PCL::FILL-CACHE-P
+            PCL::|(FAST-METHOD ADD-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|
+            PCL::ADJUST-CACHE PCL::EXPAND-CACHE
+            PCL::|(FAST-METHOD REMOVE-DEPENDENT (DEPENDENT-UPDATE-MIXIN T))|
+            PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS))|
+            PCL::|(FAST-METHOD MAP-DEPENDENTS (DEPENDENT-UPDATE-MIXIN T))|
+            PCL::|(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD-COMBINATION T))|
+            PCL::|(FAST-METHOD DIRECT-SLOT-DEFINITION-CLASS (STD-CLASS T))|
+            PCL::|(FAST-METHOD VALIDATE-SUPERCLASS
+    (FUNCALLABLE-STANDARD-CLASS STANDARD-CLASS))|
+            PCL::|(FAST-METHOD LEGAL-DOCUMENTATION-P (STANDARD-METHOD T))|
+            PCL::INITIALIZE-INSTANCE-SIMPLE
+            PCL::|(FAST-METHOD LEGAL-LAMBDA-LIST-P (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD LEGAL-METHOD-FUNCTION-P (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD LEGAL-SLOT-NAME-P (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD ALLOCATE-INSTANCE (FUNCALLABLE-STANDARD-CLASS))|
+            PCL::MAYBE-EXPAND-ACCESSOR-FORM
+            PCL::|(FAST-METHOD LEGAL-SPECIALIZER-P (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (GENERIC-FUNCTION T))|
+            PCL::|(FAST-METHOD MAKE-READER-METHOD-FUNCTION
+    (FUNCALLABLE-STANDARD-CLASS T))|
+            PCL::LOAD-PRECOMPILED-DFUN-CONSTRUCTOR PCL::GET-CACHE
+            PCL::|(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION
+    (FUNCALLABLE-STANDARD-CLASS T))|
+            PCL::|(FAST-METHOD INITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|
+            PCL::|(FAST-METHOD REINITIALIZE-INSTANCE :AFTER (STANDARD-GENERIC-FUNCTION))|
+            PCL::|(FAST-METHOD COMPUTE-APPLICABLE-METHODS (GENERIC-FUNCTION T))|
+            PCL::|(FAST-METHOD SAME-SPECIALIZER-P (SPECIALIZER SPECIALIZER))|
+            PCL::GET-WRAPPERS-FROM-CLASSES
+            PCL::|(FAST-METHOD SAME-SPECIALIZER-P (CLASS CLASS))|
+            PCL::|(FAST-METHOD SAME-SPECIALIZER-P
+    (CLASS-EQ-SPECIALIZER CLASS-EQ-SPECIALIZER))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (T T))|
+            PCL::|(FAST-METHOD SAME-SPECIALIZER-P (EQL-SPECIALIZER EQL-SPECIALIZER))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (CLASS T))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (SLOT-DEFINITION T))|
+            PCL::|(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STRUCTURE-CLASS T))|
+            PCL::TWO-CLASS-DFUN-INFO PCL::SET-MAKE-INSTANCE-FUNCTION
+            PCL::|(FAST-METHOD UPDATE-GF-DFUN (STD-CLASS T))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD PRINT-OBJECT (STANDARD-ACCESSOR-METHOD T))|
+            PCL::|(FAST-METHOD REINITIALIZE-INSTANCE (STANDARD-METHOD))|
+            WALKER::WALK-TEMPLATE PCL::EXPAND-DEFCLASS
+            PCL::BOOTSTRAP-SET-SLOT
+            PCL::|(FAST-METHOD ALLOCATE-INSTANCE (STANDARD-CLASS))|
+            PCL::|(FAST-METHOD SLOT-ACCESSOR-STD-P (EFFECTIVE-SLOT-DEFINITION T))|
+            PCL::|(FAST-METHOD DOCUMENTATION (T))|
+            PCL::|(FAST-METHOD DOCUMENTATION (DOCUMENTATION-MIXIN))|
+            PCL::|(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STD-CLASS T))|
+            PCL::|(FAST-METHOD EFFECTIVE-SLOT-DEFINITION-CLASS (STRUCTURE-CLASS T))|
+            PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS :AROUND
+    (STRUCTURE-CLASS T))| PCL::MAKE-EFFECTIVE-METHOD-FUNCTION1
+            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-INTERNAL
+            PCL::MAKE-EFFECTIVE-METHOD-FUNCTION-TYPE
+            PCL::|(FAST-METHOD REMOVE-READER-METHOD (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD REMOVE-WRITER-METHOD (SLOT-CLASS T))|
+            PCL::EMIT-CHECKING-OR-CACHING-FUNCTION-PRELIMINARY
+            PCL::MEMF-TEST-CONVERTER
+            PCL::|(FAST-METHOD REMOVE-BOUNDP-METHOD (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD MAKE-READER-METHOD-FUNCTION (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD ADD-DIRECT-SUBCLASS (CLASS CLASS))|
+            PCL::|(FAST-METHOD MAKE-WRITER-METHOD-FUNCTION (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD MAKE-INSTANCE (CLASS))|
+            PCL::|(FAST-METHOD REMOVE-DIRECT-SUBCLASS (CLASS CLASS))|
+            PCL::EXPAND-SYMBOL-MACROLET-INTERNAL
+            PCL::|(FAST-METHOD MAKE-BOUNDP-METHOD-FUNCTION (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD INFORM-TYPE-SYSTEM-ABOUT-CLASS (STD-CLASS T))|
+            PCL::|(FAST-METHOD ADD-DIRECT-METHOD (CLASS METHOD))|
+            PCL::|(FAST-METHOD REINITIALIZE-INSTANCE (SLOT-OBJECT))|
+            PCL::|(FAST-METHOD REMOVE-DIRECT-METHOD (CLASS METHOD))|
+            PCL::|(FAST-METHOD COMPATIBLE-META-CLASS-CHANGE-P (T T))|
+            PCL::|(FAST-METHOD VALIDATE-SUPERCLASS (CLASS CLASS))|)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T T T T T) T)
+            PCL::REAL-MAKE-METHOD-INITARGS-FORM PCL::MAKE-FGEN
+            WALKER::WALK-BINDINGS-1
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (BUILT-IN-CLASS T))|
+            PCL::COMPUTE-PV-SLOT
+            PCL::|(FAST-METHOD ENSURE-CLASS-USING-CLASS (T NULL))|
+            PCL::|(FAST-METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))|
+            PCL::OPTIMIZE-INSTANCE-ACCESS
+            PCL::BOOTSTRAP-MAKE-SLOT-DEFINITIONS
+            PCL::OPTIMIZE-ACCESSOR-CALL
+            PCL::BOOTSTRAP-ACCESSOR-DEFINITIONS
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STD-CLASS T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-CLASS T))|
+            PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD
+    (GENERIC-FUNCTION STANDARD-METHOD-COMBINATION T))|
+            PCL::MAKE-PARAMETER-REFERENCES PCL::UPDATE-SLOTS-IN-PV
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :BEFORE (STANDARD-ACCESSOR-METHOD T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STANDARD-METHOD T))|
+            PCL::|(FAST-METHOD REMOVE-NAMED-METHOD (T T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (STRUCTURE-SLOT-DEFINITION T))|
+            PCL::MAKE-EMF-CACHE PCL::MAKE-INSTANCE-FUNCTION-COMPLEX
+            PCL::MAKE-INSTANCE-FUNCTION-SIMPLE
+            WALKER::WALK-TEMPLATE-HANDLE-REPEAT
+            PCL::|(FAST-METHOD SLOT-BOUNDP-USING-CLASS
+    (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS
+    (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD SLOT-BOUNDP-USING-CLASS
+    (STRUCTURE-CLASS STRUCTURE-OBJECT
+        STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD SLOT-MAKUNBOUND-USING-CLASS
+    (STRUCTURE-CLASS STRUCTURE-OBJECT
+        STRUCTURE-EFFECTIVE-SLOT-DEFINITION))|
+            PCL::|(FAST-METHOD SLOT-UNBOUND (T T T))|
+            PCL::|(FAST-METHOD (SETF SLOT-ACCESSOR-STD-P)
+    (T EFFECTIVE-SLOT-DEFINITION T))|
+            PCL::|(FAST-METHOD COMPUTE-SLOT-ACCESSOR-INFO
+    (EFFECTIVE-SLOT-DEFINITION T T))|
+            PCL::|(FAST-METHOD SHARED-INITIALIZE :AFTER (DOCUMENTATION-MIXIN T))|
+            PCL::|(FAST-METHOD FIND-METHOD-COMBINATION
+    (GENERIC-FUNCTION (EQL STANDARD) T))|
+            PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T T))|
+            PCL::|(FAST-METHOD COMPUTE-EFFECTIVE-METHOD
+    (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))|
+            PCL::|(FAST-METHOD (SETF DOCUMENTATION) (T DOCUMENTATION-MIXIN))|
+            PCL::|(FAST-METHOD READER-METHOD-CLASS (SLOT-CLASS T))|
+            PCL::|(FAST-METHOD WRITER-METHOD-CLASS (SLOT-CLASS T))|
+            PCL::EXPAND-EMF-CALL-METHOD
+            PCL::OPTIMIZE-GENERIC-FUNCTION-CALL
+            PCL::MAKE-FINAL-ORDINARY-DFUN-INTERNAL
+            PCL::LOAD-FUNCTION-GENERATOR)) 
 (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)) 
+    '(FTYPE (FUNCTION (T T T T T T *) T) PCL::MAKE-DEFMETHOD-FORM
+            PCL::MAKE-DEFMETHOD-FORM-INTERNAL PCL::LOAD-DEFMETHOD
+            PCL::EARLY-MAKE-A-METHOD PCL::SET-ARG-INFO)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T T T T) T) EXPAND-DEFMETHOD
-            MAKE-LAP-CLOSURE-GENERATOR-LAMBDA)) 
+    '(FTYPE (FUNCTION (T T T T *) T) PCL::FILL-DFUN-CACHE
+            PCL::EARLY-ADD-NAMED-METHOD PCL::REAL-ADD-NAMED-METHOD)) 
 (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
-            |CONSTRUCTOR-CODE-GENERATOR PCL GENERAL|
-            WALKER::WALK-TEMPLATE-HANDLE-REPEAT
-            MAKE-PARAMETER-REFERENCES
-            |CONSTRUCTOR-CODE-GENERATOR PCL NO-METHODS|
-            |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)) 
+    '(FTYPE (FUNCTION (T T T *) T) WALKER::WALK-ARGLIST
+            PCL::CAN-OPTIMIZE-ACCESS1 PCL::EMIT-FETCH-WRAPPER
+            PCL::CHECK-INITARGS-1 PCL::MAKE-EMF-CALL PCL::FILL-CACHE
+            PCL::CHECK-INITARGS-2-PLIST PCL::REAL-GET-METHOD
+            PCL::CHECK-INITARGS-2-LIST PCL::GET-METHOD)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T T T T T T T) T) PCL::EXPAND-DEFMETHOD
+            PCL::LOAD-DEFMETHOD-INTERNAL
+            PCL::|(FAST-METHOD SLOT-MISSING (T T T T))|)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T T T T T T) T)
+            PCL::BOOTSTRAP-MAKE-SLOT-DEFINITION PCL::EMIT-SLOT-ACCESS
+            PCL::OPTIMIZE-GF-CALL PCL::LOAD-DEFCLASS
             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)) 
+            PCL::MAKE-EARLY-CLASS-DEFINITION
+            PCL::|(FAST-METHOD (SETF SLOT-VALUE-USING-CLASS)
+    (T STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|)) 
+(PROCLAIM
+    '(FTYPE (FUNCTION (T T T T T T T T) T)
+            PCL::GET-SECONDARY-DISPATCH-FUNCTION2)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T T T T T *) T) PCL::EMIT-DLAP
+            PCL::GET-MAKE-INSTANCE-FUNCTION-INTERNAL
+            PCL::GET-SECONDARY-DISPATCH-FUNCTION1)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T T T *) T) EMIT-FETCH-WRAPPER
-            FILL-DFUN-CACHE)) 
+    '(FTYPE (FUNCTION (T T T FIXNUM) T) PCL::FILL-CACHE-FROM-CACHE-P)) 
 (PROCLAIM
-    '(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)) 
+    '(FTYPE (FUNCTION (T T T T T T T T T *) T)
+            PCL::BOOTSTRAP-INITIALIZE-CLASS)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION NIL *) RENEW-SYS-FILES EMIT-N-N-READERS
-            COUNT-ALL-DFUNS EMIT-N-N-WRITERS)) 
+    '(FTYPE (FUNCTION NIL *) PCL::COUNT-ALL-DFUNS PCL::EMIT-N-N-READERS
+            PCL::EMIT-N-N-WRITERS PCL::RENEW-SYS-FILES)) 
 (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)) 
+    '(FTYPE (FUNCTION NIL T)
+            PCL::INITIALIZE-CHECKING-OR-CACHING-FUNCTION-LIST
+            PCL::SHOW-EMF-CALL-TRACE PCL::MAKE-CACHE PCL::MAKE-CPD
+            PCL::BOOTSTRAP-META-BRAID PCL::EARLY-INITIALIZE-SLOT-GFS
+            PCL::EARLY-INITIALIZE-CLASS-PREDICATES
+            PCL::BOOTSTRAP-BUILT-IN-CLASSES PCL::UPDATE-DISPATCH-DFUNS
+            PCL::SHOW-FREE-CACHE-VECTORS PCL::NO-METHODS-DFUN-INFO
+            PCL::IN-THE-COMPILER-P PCL::STRUCTURE-FUNCTIONS-EXIST-P
+            PCL::%%ALLOCATE-INSTANCE--CLASS
+            PCL::ALLOCATE-FUNCALLABLE-INSTANCE-2
+            PCL::ALLOCATE-FUNCALLABLE-INSTANCE-1
+            PCL::DEFAULT-METHOD-ONLY-DFUN-INFO
+            PCL::INITIAL-DISPATCH-DFUN-INFO PCL::INITIAL-DFUN-INFO
+            PCL::MAKE-ARG-INFO PCL::DISPATCH-DFUN-INFO
+            PCL::SHOW-DFUN-CONSTRUCTORS PCL::CACHES-TO-ALLOCATE
+            PCL::RESET-PCL-PACKAGE PCL::GET-EFFECTIVE-METHOD-GENSYM
+            PCL::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)) 
+    '(FTYPE (FUNCTION (*) *) PCL::LIST-LARGE-CACHES
+            PCL:INVALID-METHOD-ERROR PCL:METHOD-COMBINATION-ERROR
+            PCL::UNTRACE-METHOD)) 
+(PROCLAIM '(FTYPE (FUNCTION (FIXNUM T *) *) PCL::FIND-FREE-CACHE-LINE)) 
 (PROCLAIM
-    '(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|
-            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|)) 
+    '(FTYPE (FUNCTION (FIXNUM T T) *) PCL::COMPUTE-CACHE-PARAMETERS)) 
 (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)) 
+    '(FTYPE (FUNCTION (*) T) PCL::MAKE-METHOD-CALL
+            PCL::MAKE-FAST-METHOD-CALL PCL::MAKE-FAST-INSTANCE-BOUNDP
+            PCL::PV-WRAPPERS-FROM-PV-ARGS PCL::MAKE-PV-TABLE
+            PCL::|__si::MAKE-ARG-INFO| PCL::|__si::MAKE-PV-TABLE|
+            PCL::FIX-EARLY-GENERIC-FUNCTIONS PCL::|__si::MAKE-CACHE|
+            PCL::|__si::MAKE-NO-METHODS| PCL::|__si::MAKE-STD-INSTANCE|
+            PCL::CALLED-FIN-WITHOUT-FUNCTION
+            WALKER::UNBOUND-LEXICAL-FUNCTION PCL::MAKE-INITIALIZE-INFO
+            PCL::UPDATE-MAKE-INSTANCE-FUNCTION-TABLE
+            PCL::|__si::MAKE-DFUN-INFO|
+            PCL::|__si::MAKE-DEFAULT-METHOD-ONLY|
+            PCL::|__si::MAKE-ACCESSOR-DFUN-INFO| PCL::MAKE-PROGN
+            PCL::|__si::MAKE-ONE-INDEX-DFUN-INFO| PCL::|__si::MAKE-N-N|
+            PCL::|__si::MAKE-CLASS-PRECEDENCE-DESCRIPTION|
+            PCL::|__si::MAKE-ONE-CLASS| PCL::|__si::MAKE-TWO-CLASS|
+            PCL::|__si::MAKE-ONE-INDEX| PCL::|__si::MAKE-CHECKING|
+            PCL::|__si::MAKE-CACHING| PCL::|__si::MAKE-CONSTANT-VALUE|
+            PCL::INTERN-PV-TABLE PCL::TRUE PCL::|__si::MAKE-DISPATCH|
+            PCL::STRING-APPEND PCL::|__si::MAKE-INITIAL| PCL::FALSE
+            PCL::|__si::MAKE-INITIAL-DISPATCH|
+            PCL::|STRUCTURE-OBJECT class constructor|)) 
 (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)) 
+    '(FTYPE (FUNCTION (T) *) PCL::METHOD-PROTOTYPE-FOR-GF
+            PCL::FIND-WRAPPER PCL::PARSE-DEFMETHOD
+            PCL::PROTOTYPES-FOR-MAKE-METHOD-LAMBDA
+            PCL::FORCE-CACHE-FLUSHES PCL::STRUCTURE-WRAPPER
+            PCL::EMIT-ONE-CLASS-READER PCL::EMIT-ONE-CLASS-WRITER
+            PCL::EMIT-TWO-CLASS-READER PCL::EMIT-TWO-CLASS-WRITER
+            PCL::EMIT-ONE-INDEX-READERS PCL::EMIT-ONE-INDEX-WRITERS
+            PCL::EARLY-METHOD-FUNCTION PCL::EMIT-IN-CHECKING-CACHE-P
+            PCL::EMIT-CONSTANT-VALUE
+            PCL::COMPUTE-APPLICABLE-METHODS-EMF PCL::NET-CODE-CONVERTER
+            PCL::STRUCTURE-SLOTD-INIT-FORM PCL::MAKE-DISPATCH-DFUN
+            PCL::INSURE-CACHING-DFUN PCL::%FBOUNDP PCL::CCLOSUREP
+            PCL::EARLY-COLLECT-INHERITANCE PCL::TYPE-FROM-SPECIALIZER
+            PCL::*NORMALIZE-TYPE PCL::UNPARSE-TYPE
+            PCL::CONVERT-TO-SYSTEM-TYPE PCL::PCL-DESCRIBE
+            PCL::PARSE-METHOD-GROUP-SPECIFIER PCL::ANALYZE-LAMBDA-LIST
+            COMPILER::CAN-USE-PRINT-CIRCLE-P PCL::GF-LAMBDA-LIST
+            PCL::SPECIALIZER-FROM-TYPE PCL::CLASS-EQ-TYPE
+            PCL::FIND-STRUCTURE-CLASS PCL::GENERIC-FUNCTION-NAME-P
+            PCL::GET-DISPATCH-FUNCTION PCL::DEFAULT-CODE-CONVERTER
+            PCL::MAKE-FINAL-DISPATCH-DFUN)) 
 (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
+    '(FTYPE (FUNCTION (T) T) PCL::FGEN-GENERATOR PCL::FGEN-SYSTEM
+            PCL::STORE-FGEN PCL::MAKE-PV-TYPE-DECLARATION
+            PCL::MAKE-CALLS-TYPE-DECLARATION PCL::CHECK-CACHE
+            PCL::FGEN-GENSYMS PCL::MAKE-CONSTANT-FUNCTION
+            PCL::FGEN-GENERATOR-LAMBDA PCL::FUNCTION-RETURNING-T
+            PCL::METHOD-CALL-P PCL::FIND-CYCLE-REASONS
+            PCL::MAP-ALL-GENERIC-FUNCTIONS PCL::MAKE-PERMUTATION-VECTOR
+            PCL::FAST-METHOD-CALL-P PCL::ALLOCATE-CACHE-VECTOR
+            PCL::FLUSH-CACHE-VECTOR-INTERNAL PCL::FORMAT-CYCLE-REASONS
+            PCL::FAST-INSTANCE-BOUNDP-P PCL::METHOD-FUNCTION-PV-TABLE
+            PCL::METHOD-FUNCTION-METHOD
+            PCL::DO-STANDARD-DEFSETFS-FOR-DEFCLASS
+            PCL::GET-CACHE-VECTOR
+            PCL::METHOD-FUNCTION-NEEDS-NEXT-METHODS-P
+            PCL::WRAPPER-FIELD PCL::FREE-CACHE-VECTOR
+            PCL::METHOD-FUNCTION-PLIST PCL::SORT-SLOTS
+            PCL::MAP-SPECIALIZERS
+            PCL::FTYPE-DECLARATION-FROM-LAMBDA-LIST
+            PCL::ONE-INDEX-DFUN-INFO-CACHE PCL::SORT-CALLS
+            PCL::ONE-INDEX-DFUN-INFO-ACCESSOR-TYPE PCL::DFUN-ARG-SYMBOL
+            PCL::N-N-CACHE PCL::GF-DFUN-CACHE PCL::N-N-ACCESSOR-TYPE
+            PCL::GDEFINITION PCL::GF-DFUN-INFO PCL::ONE-CLASS-CACHE
+            PCL::EVAL-FORM PCL::EARLY-GF-NAME
+            PCL::ONE-CLASS-ACCESSOR-TYPE
+            PCL::SLOT-INITARGS-FROM-STRUCTURE-SLOTD
+            PCL::ONE-CLASS-INDEX
+            PCL:EXTRACT-LAMBDA-LIST PCL::SYMBOL-PKG-NAME
+            PCL::TWO-CLASS-CACHE PCL:EXTRACT-SPECIALIZER-NAMES
+            PCL::ARG-INFO-PRECEDENCE PCL::TWO-CLASS-ACCESSOR-TYPE
+            PCL::ARG-INFO-METATYPES PCL::TWO-CLASS-INDEX
+            PCL::INITIALIZE-INFO-KEY PCL::INTERNED-SYMBOL-P
+            PCL::ARG-INFO-NUMBER-OPTIONAL PCL::TWO-CLASS-WRAPPER0
+            PCL::INITIALIZE-INFO-WRAPPER PCL::FREE-CACHE
+            PCL::CLASS-HAS-A-FORWARD-REFERENCED-SUPERCLASS-P
+            PCL::ARG-INFO-KEY/REST-P PCL::ONE-INDEX-CACHE
+            PCL::ARG-INFO-KEYWORDS PCL::ONE-INDEX-ACCESSOR-TYPE
+            PCL::GF-INFO-SIMPLE-ACCESSOR-TYPE PCL::ONE-INDEX-INDEX
+            PCL::UPDATE-GFS-OF-CLASS PCL::GF-PRECOMPUTE-DFUN-AND-EMF-P
+            PCL::CHECKING-CACHE PCL::GF-INFO-STATIC-C-A-M-EMF
+            PCL::CACHING-CACHE PCL::GF-INFO-C-A-M-EMF-STD-P
+            PCL::CONSTANT-VALUE-CACHE PCL::UPDATE-CLASS-CAN-PRECEDE-P
+            PCL::GF-INFO-FAST-MF-P PCL::COMPUTE-CLASS-SLOTS
+            PCL::ARG-INFO-LAMBDA-LIST PCL:INTERN-EQL-SPECIALIZER
+            PCL::ARG-INFO-P PCL::ARG-INFO-VALID-P PCL::ARG-INFO-NKEYS
+            PCL::COMPILE-IIS-FUNCTIONS PCL::ARG-INFO-APPLYP
+            PCL::WRAPPER-FOR-STRUCTURE PCL::PV-TABLEP
+            PCL::UPDATE-GF-INFO PCL::MAKE-PV-TABLE-TYPE-DECLARATION
+            PCL::BUILT-IN-WRAPPER-OF PCL::CACHE-P
+            PCL::BUILT-IN-OR-STRUCTURE-WRAPPER1
+            PCL::RESET-INITIALIZE-INFO PCL::UPDATE-PV-TABLE-CACHE-INFO
+            PCL::UPDATE-C-A-M-GF-INFO
+            PCL::UPDATE-GF-SIMPLE-ACCESSOR-TYPE
+            PCL::INITIALIZE-INFO-CACHED-VALID-P PCL::EARLY-CLASS-NAME
+            PCL::NO-METHODS-P PCL::STANDARD-SVUC-METHOD
+            PCL::INTERN-FUNCTION-NAME
+            PCL::INITIALIZE-INFO-CACHED-RI-VALID-P
+            PCL::STRUCTURE-SVUC-METHOD PCL::COMPILE-LAMBDA-UNCOMPILED
+            PCL::INITIALIZE-INFO-CACHED-INITARGS-FORM-LIST
+            PCL::COMPILE-LAMBDA-DEFERRED
+            PCL::INITIALIZE-INFO-CACHED-NEW-KEYS
+            PCL::INITIALIZE-INFO-CACHED-DEFAULT-INITARGS-FUNCTION
+            PCL::UNDEFMETHOD-1
+            PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-T-FUNCTION
+            PCL::METHOD-LL->GENERIC-FUNCTION-LL
+            PCL::COMPUTE-MCASE-PARAMETERS
+            PCL::INITIALIZE-INFO-CACHED-SHARED-INITIALIZE-NIL-FUNCTION
+            PCL::INITIALIZE-INFO-CACHED-CONSTANTS PCL::COPY-CACHE
+            PCL::NET-TEST-CONVERTER
+            PCL::INITIALIZE-INFO-CACHED-COMBINED-INITIALIZE-FUNCTION
+            PCL::COMPUTE-LINE-SIZE
+            PCL::ACCESSOR-DFUN-INFO-ACCESSOR-TYPE
+            PCL::UPDATE-ALL-C-A-M-GF-INFO
+            PCL::ONE-INDEX-DFUN-INFO-INDEX PCL::ONE-CLASS-WRAPPER0
+            PCL::EXTRACT-PARAMETERS PCL::TWO-CLASS-WRAPPER1
+            PCL::EXTRACT-REQUIRED-PARAMETERS
+            PCL::FUNCTION-PRETTY-ARGLIST PCL::CHECKING-FUNCTION
+            PCL::CLASS-FROM-TYPE PCL::DNET-METHODS-P
+            PCL::PROCLAIM-INCOMPATIBLE-SUPERCLASSES
+            PCL::FUNCALLABLE-INSTANCE-P PCL::DEFAULT-STRUCTUREP
+            PCL::DEFAULT-STRUCTURE-INSTANCE-P PCL::GFS-OF-TYPE
+            PCL::DEFAULT-STRUCTURE-TYPE PCL::STRUCTURE-TYPE
+            PCL::STRUCTURE-TYPE-INCLUDED-TYPE-NAME
+            PCL::RESET-CLASS-INITIALIZE-INFO
+            PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST
+            PCL::CONSTANT-SYMBOL-P PCL::STRUCTURE-SLOTD-NAME
+            PCL::MAKE-INSTANCE-FUNCTION-SYMBOL
+            PCL::STRUCTURE-SLOTD-ACCESSOR-SYMBOL
+            PCL::MAKE-LAZY-GET-MAKE-INSTANCE-FUNCTION
+            PCL::%STD-INSTANCE-WRAPPER
+            PCL::STRUCTURE-SLOTD-WRITER-FUNCTION
+            PCL::%STD-INSTANCE-SLOTS PCL::STRUCTURE-SLOTD-TYPE
+            PCL::STD-INSTANCE-P PCL::CONSTANT-VALUE-P
+            PCL::USE-CACHING-DFUN-P
+            PCL::COMPLICATED-INSTANCE-CREATION-METHOD
+            PCL::MAKE-FUNCTION-INLINE
+            PCL::SLOT-VECTOR-SYMBOL PCL::CACHING-DFUN-INFO
+            PCL::COMPUTE-APPLICABLE-METHODS-EMF-STD-P
+            PCL::CONSTANT-VALUE-DFUN-INFO
+            PCL::STRUCTURE-TYPE-INTERNAL-SLOTDS WALKER::ENV-LOCK
+            PCL::CPD-CLASS WALKER::ENV-LEXICAL-VARIABLES
+            PCL::RESET-CLASS-INITIALIZE-INFO-1 WALKER::ENV-DECLARATIONS
+            ITERATE::VARIABLES-FROM-LET
             WALKER::GET-IMPLEMENTATION-DEPENDENT-WALKER-TEMPLATE
-            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
-            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
-            MAKE-DOCUMENTED-STD-BOUNDP-METHOD-FUNCTION SETFBOUNDP
-            |LAP Operand FSC-WRAPPER|)) 
+            PCL::UPDATE-INITIALIZE-INFO PCL::CPD-SUPERS
+            WALKER::ENV-WALK-FORM WALKER::ENV-WALK-FUNCTION
+            PCL::DEFAULT-SECONDARY-DISPATCH-FUNCTION PCL::CPD-AFTER
+            PCL::EARLY-CLASS-DEFINITION WALKER::GET-WALKER-TEMPLATE
+            PCL::GET-PV-CELL-FOR-CLASS ITERATE::SEQUENCE-ACCESSOR
+            PCL::CPD-COUNT PCL::%SYMBOL-FUNCTION PCL::%CCLOSURE-ENV
+            PCL::EARLY-CLASS-PRECEDENCE-LIST
+            PCL::INFORM-TYPE-SYSTEM-ABOUT-STD-CLASS
+            PCL::MAKE-INITFUNCTION PCL::DFUN-INFO-P PCL::ECD-CLASS-NAME
+            PCL::DISPATCH-P PCL::CANONICAL-SLOT-NAME
+            PCL::EARLY-CLASS-SLOTS PCL::EARLY-COLLECT-CPL
+            PCL::EARLY-COLLECT-SLOTS PCL::DEFAULT-METHOD-ONLY-P
+            PCL::METHODS-CONTAIN-EQL-SPECIALIZER-P
+            PCL::EARLY-COLLECT-DEFAULT-INITARGS
+            PCL::ECD-SUPERCLASS-NAMES PCL::ECD-CANONICAL-SLOTS
+            PCL::UNENCAPSULATED-FDEFINITION PCL::ECD-OTHER-INITARGS
+            PCL::FAST-METHOD-CALL-ARG-INFO PCL::MAKE-INITIAL-DFUN
+            PCL::ACCESSOR-DFUN-INFO-P PCL::ECD-SOURCE
+            PCL::ECD-METACLASS PCL::MAKE-TYPE-PREDICATE
+            PCL::ONE-INDEX-DFUN-INFO-P PCL::EARLY-CLASS-NAME-OF
+            PCL::UNPARSE-TYPE-LIST PCL::EARLY-CLASS-DIRECT-SUBCLASSES
+            PCL::N-N-P PCL::SLOT-READER-SYMBOL PCL::SLOT-WRITER-SYMBOL
+            PCL::SLOT-BOUNDP-SYMBOL
+            PCL::MAKE-STRUCTURE-SLOT-BOUNDP-FUNCTION PCL::ONE-CLASS-P
+            PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
+            PCL::GBOUNDP
+            PCL::MAKE-OPTIMIZED-STRUCTURE-SETF-SLOT-VALUE-USING-CLASS-METHOD-FUNCTION
+            PCL::GMAKUNBOUND
+            PCL::MAKE-OPTIMIZED-STRUCTURE-SLOT-BOUNDP-USING-CLASS-METHOD-FUNCTION
+            PCL::CLASS-PRECEDENCE-DESCRIPTION-P PCL::TWO-CLASS-P
+            PCL::EXPAND-LONG-DEFCOMBIN PCL::STRUCTURE-SLOT-BOUNDP
+            PCL::ONE-INDEX-P PCL::CHECKING-P
+            PCL::MAKE-DEFAULT-METHOD-GROUP-DESCRIPTION
+            SYSTEM:%STRUCTURE-NAME PCL::INITIALIZE-INTERNAL-SLOT-GFS
+            SYSTEM:%COMPILED-FUNCTION-NAME PCL::CACHING-P
+            PCL::EXPAND-SHORT-DEFCOMBIN
+            PCL::USE-DEFAULT-METHOD-ONLY-DFUN-P
+            PCL::METHOD-FUNCTION-FROM-FAST-FUNCTION
+            PCL::KEYWORD-SPEC-NAME PCL:CLASS-OF
+            PCL::GENERIC-CLOBBERS-FUNCTION PCL::FUNCTION-RETURNING-NIL
+            PCL::EARLY-METHOD-LAMBDA-LIST PCL::DO-STANDARD-DEFSETF-1
+            PCL::EARLY-GF-P PCL::PARSE-SPECIALIZERS PCL::TYPE-CLASS
+            PCL::MAKE-CALL-METHODS PCL::EARLY-METHOD-QUALIFIERS
+            PCL::CLASS-PREDICATE PCL::LEGAL-CLASS-NAME-P
+            PCL::MAKE-CLASS-EQ-PREDICATE PCL::STRUCTURE-TYPE-P
+            PCL::MAKE-EQL-PREDICATE
+            PCL::EARLY-METHOD-STANDARD-ACCESSOR-P
+            PCL::NEXT-WRAPPER-FIELD PCL::GET-BUILT-IN-CLASS-SYMBOL
+            PCL::GET-BUILT-IN-WRAPPER-SYMBOL PCL::UNPARSE-SPECIALIZERS
+            PCL::SETFBOUNDP PCL::GET-SETF-FUNCTION-NAME
+            PCL::METHOD-CALL-CALL-METHOD-ARGS SYSTEM::NEXT-STACK-FRAME
+            PCL::INITIALIZE-INFO-P PCL::WRAPPER-OF
+            PCL::FAST-METHOD-CALL-PV-CELL PCL::CHECK-WRAPPER-VALIDITY
+            PCL::FAST-METHOD-CALL-NEXT-METHOD-CALL PCL::INITIAL-P
+            PCL::DEFAULT-TEST-CONVERTER PCL::COMPUTE-STD-CPL-PHASE-2
+            PCL::DFUN-INFO-CACHE PCL::DEFAULT-CONSTANT-CONVERTER
+            WALKER:VARIABLE-GLOBALLY-SPECIAL-P PCL::NO-METHODS-CACHE
+            PCL::INITIAL-CACHE PCL::LIST-DFUN
+            PCL::INITIAL-DISPATCH-CACHE PCL::STRUCTURE-OBJECT-P
+            PCL::LIST-LARGE-CACHE PCL::DEFAULT-CONSTANTP
+            PCL::INITIAL-DISPATCH-P PCL::DISPATCH-CACHE PCL::COUNT-DFUN
+            PCL::FGEN-TEST PCL::DEFAULT-METHOD-ONLY-CACHE
+            PCL::LOOKUP-FGEN PCL::ACCESSOR-DFUN-INFO-CACHE)) 
 (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)) 
+    '(FTYPE (FUNCTION (T *) *) PCL::GET-FUNCTION PCL::GET-FUNCTION1
+            PCL:ENSURE-CLASS PCL::MAKE-METHOD-FUNCTION-INTERNAL
+            PCL::PARSE-SPECIALIZED-LAMBDA-LIST
+            PCL::MAKE-METHOD-LAMBDA-INTERNAL
+            PCL::GET-MAKE-INSTANCE-FUNCTION
+            PCL::GET-GENERIC-FUNCTION-INFO PCL::PARSE-METHOD-OR-SPEC
+            PCL::COMPILE-LAMBDA PCL::GET-DFUN-CONSTRUCTOR
+            PCL::MAKE-CACHING-DFUN PCL::MAKE-CONSTANT-VALUE-DFUN
+            PCL::MAKE-FINAL-DFUN-INTERNAL PCL::COERCE-TO-CLASS
+            PCL::MAP-ALL-CLASSES PCL:ENSURE-GENERIC-FUNCTION
+            PCL::GET-METHOD-FUNCTION PCL::EXTRACT-DECLARATIONS
+            WALKER:WALK-FORM WALKER:MACROEXPAND-ALL)) 
+(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) PCL::SYMBOL-APPEND)) 
+(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) PCL::CAPITALIZE-WORDS)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T (VECTOR T)) T) ALLOCATE-FUNCALLABLE-INSTANCE)) 
-(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) SYMBOL-APPEND)) 
+    '(FTYPE (FUNCTION (T T) *) PCL::COMPUTE-TEST
+            PCL::GET-NEW-FUNCTION-GENERATOR-INTERNAL PCL::COMPUTE-CODE
+            PCL::FIND-SUPERCLASS-CHAIN
+            PCL::GENERATE-FAST-CLASS-SLOT-ACCESS-P
+            PCL::MUTATE-SLOTS-AND-CALLS PCL::ENSURE-CLASS-VALUES
+            PCL::MAKE-DIRECT-SLOTD PCL::EMIT-DEFAULT-ONLY-FUNCTION
+            PCL::EMIT-DEFAULT-ONLY PCL::SPLIT-DECLARATIONS
+            PCL::SLOT-NAME-LISTS-FROM-SLOTS PCL::EMIT-CHECKING
+            PCL::EMIT-CACHING PCL::UPDATE-SLOT-VALUE-GF-INFO
+            PCL::SET-FUNCTION-NAME PCL::SDFUN-FOR-CACHING
+            ITERATE::PARSE-DECLARATIONS
+            PCL::COMPUTE-APPLICABLE-METHODS-USING-TYPES
+            PCL::INITIALIZE-INSTANCE-SIMPLE-FUNCTION
+            PCL::FORM-LIST-TO-LISP PCL::CHECK-INITARGS-VALUES
+            PCL::*SUBTYPEP PCL::CLASS-APPLICABLE-USING-CLASS-P
+            PCL::SAUT-AND PCL::SAUT-NOT PCL::SAUT-CLASS
+            PCL::SAUT-PROTOTYPE PCL::SAUT-CLASS-EQ PCL::SAUT-EQL
+            PCL::SPECIALIZER-APPLICABLE-USING-TYPE-P PCL::*TYPEP
+            COMPILER::CAN-USE-PRINT-CIRCLE-P1 PCL::DESTRUCTURE
+            PCL::INVOKE-EMF PCL:SLOT-BOUNDP PCL:SLOT-EXISTS-P
+            PCL:SLOT-MAKUNBOUND PCL:SLOT-VALUE
+            PCL::COMPUTE-STD-CPL-PHASE-1 PCL::SLOT-UNBOUND-INTERNAL)) 
 (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)) 
+    '(FTYPE (FUNCTION (T *) T) PCL::PV-TABLE-LOOKUP-PV-ARGS
+            WALKER::RELIST* WALKER::RELIST PCL::FIND-CLASS-PREDICATE
+            PCL::EXPAND-MAKE-INSTANCE-FORM PCL::SET-DFUN
+            PCL::MAKE-WRAPPER PCL::MAKE-SPECIALIZABLE
+            PCL::MAKE-FINAL-DFUN WALKER::WALKER-ENVIRONMENT-BIND-1
+            PCL::USE-DISPATCH-DFUN-P PCL::ALLOCATE-STRUCTURE-INSTANCE
+            PCL::ALLOCATE-STANDARD-INSTANCE ITERATE::FUNCTION-LAMBDA-P
+            ITERATE::MAYBE-WARN PCL::REAL-USE-DISPATCH-DFUN-P
+            PCL::MAKE-TYPE-PREDICATE-NAME PCL::USE-CONSTANT-VALUE-DFUN-P
+            PCL::ALLOCATE-FUNCALLABLE-INSTANCE
+            PCL::GET-MAKE-INSTANCE-FUNCTIONS PCL:FIND-CLASS
+            PCL::EARLY-METHOD-SPECIALIZERS
+            PCL::INITIALIZE-METHOD-FUNCTION PCL::TRACE-METHOD
+            PCL::UPDATE-DFUN PCL::FIND-CLASS-CELL)) 
 (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)) 
+    '(FTYPE (FUNCTION (T T T) (*)) PCL::SORT-APPLICABLE-METHODS
+            PCL::SORT-METHODS)) 
 (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|
-            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
-            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)) 
+    '(FTYPE (FUNCTION (T T) T) PCL::CPL-INCONSISTENT-ERROR
+            WALKER::NOTE-DECLARATION WALKER::NOTE-LEXICAL-BINDING
+            PCL::MAKE-PV-TABLE-INTERNAL PCL::FIND-SLOT-DEFINITION
+            WALKER::ENVIRONMENT-FUNCTION PCL::|SETF PCL FIND-CLASS|
+            PCL::|SETF PCL FIND-CLASS-PREDICATE|
+            PCL::COMPUTE-EMF-FROM-WRAPPERS PCL::COMPUTE-PV
+            PCL::COMPUTE-CALLS PCL::UPDATE-ALL-PV-TABLE-CACHES
+            PCL::MAP-PV-TABLE-REFERENCES-OF
+            PCL::GF-MAKE-FUNCTION-FROM-EMF PCL::PLIST-VALUE
+            PCL::ADD-DIRECT-SUBCLASSES PCL::UPDATE-CLASS
+            PCL::MAKE-CLASS-PREDICATE PCL::ADD-SLOT-ACCESSORS
+            PCL::SYMBOL-LESSP PCL::REDEFINE-FUNCTION
+            PCL::METHOD-FUNCTION-RETURNING-NIL
+            PCL::REMOVE-DIRECT-SUBCLASSES
+            PCL::METHOD-FUNCTION-RETURNING-T PCL::SYMBOL-OR-CONS-LESSP
+            PCL::REMOVE-SLOT-ACCESSORS
+            PCL:FUNCALLABLE-STANDARD-INSTANCE-ACCESS
+            PCL::PV-TABLE-LOOKUP PCL::UPDATE-CPL
+            PCL::PV-WRAPPERS-FROM-ALL-ARGS PCL::UPDATE-SLOTS
+            PCL::UPDATE-INITS PCL::EMIT-1-NIL-DLAP
+            PCL::EMIT-1-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
+            PCL::COMPUTE-LAYOUT
+            PCL::EMIT-N-WRAPPER-COMPUTE-PRIMARY-CACHE-LOCATION
+            PCL::GET-MAKE-INSTANCE-FUNCTION-KEY
+            PCL::CHANGE-CLASS-INTERNAL PCL::NEW-ARG-INFO-FROM-METHOD
+            PCL::ADD-ARG-INFO PCL::REMOVE-ARG-INFO
+            PCL:SET-FUNCALLABLE-INSTANCE-FUNCTION PCL::LIST-EQ
+            PCL::COMPUTE-APPLICABLE-METHODS-FUNCTION
+            PCL::UPDATE-INITIALIZE-INFO-INTERNAL
+            PCL::PV-WRAPPERS-FROM-ALL-WRAPPERS
+            PCL::UPDATE-STD-OR-STR-METHODS
+            PCL::SET-STANDARD-SVUC-METHOD
+            PCL::SET-STRUCTURE-SVUC-METHOD
+            PCL::|SETF PCL METHOD-FUNCTION-PLIST|
+            PCL::MEC-ALL-CLASSES-INTERNAL PCL::MEC-ALL-CLASSES
+            PCL::MEC-ALL-CLASS-LISTS PCL:STANDARD-INSTANCE-ACCESS
+            PCL::DESCRIBE-PACKAGE PCL::METHODS-CONVERTER
+            PCL::RAISE-METATYPE
+            PCL::MAKE-DISCRIMINATING-FUNCTION-ARGLIST
+            PCL::|SETF PCL GDEFINITION| PCL::NET-CONSTANT-CONVERTER
+            PCL::AUGMENT-TYPE PCL::SET-FUNCTION-PRETTY-ARGLIST
+            PCL::DOCTOR-DFUN-FOR-THE-DEBUGGER PCL::VALUE-FOR-CACHING
+            PCL::ACCESSOR-MISS-FUNCTION PCL::MAKE-UNORDERED-METHODS-EMF
+            PCL::FIND-STANDARD-II-METHOD PCL::N-N-DFUN-INFO
+            PCL::CHECKING-DFUN-INFO
+            PCL::CPL-FORWARD-REFERENCED-CLASS-ERROR
+            PCL::MAKE-DFUN-LAMBDA-LIST PCL::MAKE-DLAP-LAMBDA-LIST
+            WALKER::ENVIRONMENT-MACRO PCL::MAKE-DFUN-ARG-LIST
+            PCL::MAKE-FAST-METHOD-CALL-LAMBDA-LIST ITERATE::MV-SETQ
+            ITERATE::EXTRACT-SPECIAL-BINDINGS
+            WALKER::VARIABLE-SYMBOL-MACRO-P PCL::ADD-FORMS
+            PCL::SET-WRAPPER PCL::BOOTSTRAP-SLOT-INDEX
+            PCL::CLASS-CAN-PRECEDE-P PCL::SWAP-WRAPPERS-AND-SLOTS
+            PCL::ADD-TO-CVECTOR PCL::SAUT-NOT-CLASS
+            PCL::CANONICALIZE-SLOT-SPECIFICATION PCL::SAUT-NOT-CLASS-EQ
+            PCL::CANONICALIZE-DEFCLASS-OPTION PCL::SAUT-NOT-PROTOTYPE
+            WALKER::WALK-REPEAT-EVAL PCL::%SET-CCLOSURE-ENV
+            PCL::SAUT-NOT-EQL PCL::SUPERCLASSES-COMPATIBLE-P
+            ITERATE::SIMPLE-EXPAND-ITERATE-FORM
+            PCL::CLASSES-HAVE-COMMON-SUBCLASS-P PCL::FDEFINE-CAREFULLY
+            PCL::CLASS-MIGHT-PRECEDE-P PCL::NO-SLOT
+            PCL::DO-SATISFIES-DEFTYPE PCL::QUALIFIER-CHECK-RUNTIME
+            PCL::DEAL-WITH-ARGUMENTS-OPTION
+            PCL::MAKE-INTERNAL-READER-METHOD-FUNCTION
+            PCL::PARSE-QUALIFIER-PATTERN
+            PCL::MAKE-STD-READER-METHOD-FUNCTION
+            PCL::MAKE-STD-WRITER-METHOD-FUNCTION
+            PCL::MAKE-STD-BOUNDP-METHOD-FUNCTION
+            SYSTEM:%SET-COMPILED-FUNCTION-NAME PCL:ADD-METHOD
+            SYSTEM::DISPLAY-ENV PCL::PRINTING-RANDOM-THING-INTERNAL
+            SYSTEM::DISPLAY-COMPILED-ENV PCL::PROCLAIM-DEFGENERIC
+            PCL::COMPUTE-STD-CPL PCL::MAKE-PLIST PCL::REMTAIL
+            PCL::MEMF-CONSTANT-CONVERTER PCL::DESTRUCTURE-INTERNAL
+            PCL:REMOVE-METHOD PCL::STANDARD-COMPUTE-EFFECTIVE-METHOD
+            PCL::SET-METHODS PCL::VARIABLE-CLASS PCL::MAKE-CAXR
+            PCL::MAKE-CDXR PCL::REDIRECT-EARLY-FUNCTION-INTERNAL
+            WALKER:VARIABLE-LEXICAL-P WALKER:VARIABLE-SPECIAL-P
+            PCL::REAL-REMOVE-METHOD PCL::COMPUTE-CONSTANTS)) 
+(PROCLAIM '(FTYPE (FUNCTION NIL FIXNUM) PCL::GET-WRAPPER-CACHE-NUMBER)) 
 (IN-PACKAGE "PCL")
 
-(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 |(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-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
-                |(BOUNDP READER-FUNCTION)| |(BOUNDP PREDICATE-NAME)|
-                |(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 LOCATION)|
-                |(BOUNDP DOCUMENTATION)| SPECIALIZER-OBJECT
-                |(BOUNDP CACHED-FUNCTIONS-ALIST)|
-                |(BOUNDP INCOMPATIBLE-SUPERCLASS-LIST)|
-                ACCESSOR-METHOD-SLOT-NAME |(BOUNDP DECLARATIONS)|
-                |(BOUNDP CACHED-IN-GENERIC-FUNCTIONS)|
-                |(BOUNDP SPECIALIZERS)|
-                |STANDARD-DIRECT-SLOT-DEFINITION class predicate|
-                |(BOUNDP IDENTIFIER)| SPECIALIZER-CLASS
-                |(BOUNDP PRETTY-ARGLIST)|
-                |(SETF SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL)|
-                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 WRITER-FUNCTION)|
-                |(BOUNDP INITFUNCTION)| STRUCTURE-CLASS-P
-                |(BOUNDP WRITERS)| |(BOUNDP INITFORM)|
-                |(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 |(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)| |(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)|
-                |(BOUNDP BOUNDP-FUNCTION)|
-                |(BOUNDP DIRECT-SUPERCLASSES)|
-                |(BOUNDP DIRECT-SUBCLASSES)| ADD-CACHED-FUNCTION
-                |(BOUNDP METHODS)| |(BOUNDP OPTIONS)|
-                GET-CACHED-FUNCTION GENERIC-FUNCTION-PRETTY-ARGLIST
-                MAKE-CONSTRUCTOR-CODE-GENERATORS |(WRITER SOURCE)|
-                UPDATE-SLOT-ACCESSOR-FUNCTION
-                |SLOT-DEFINITION class predicate|
-                |(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
-                |SETF PCL GENERIC-FUNCTION-NAME|
-                |SETF PCL METHOD-FUNCTION-NAME| LEGAL-DECLARATIONS-P
-                |DEPENDENT-UPDATE-MIXIN class predicate|
-                |(READER READER-FUNCTION)| |(READER PREDICATE-NAME)|
-                |(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 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)|
-                |(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)|
-                |(READER INITFUNCTION-SIDE-EFFECT-FREE-P)|
-                |(METHOD UPDATE-INSTANCE-FOR-DIFFERENT-CLASS (STANDARD-OBJECT STANDARD-OBJECT))|
-                |(METHOD WRAPPER-FETCHER (STRUCTURE-CLASS))|
-                |(METHOD WRAPPER-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
-                |(METHOD CLASS-PROTOTYPE (STRUCTURE-CLASS))|
-                |(METHOD CHANGE-CLASS (STANDARD-OBJECT FUNCALLABLE-STANDARD-CLASS))|
-                |(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-GENERIC-FUNCTIONS (SPECIALIZER-WITH-OBJECT))|
-                |(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))|
-                |(READER FUNCTION-NAME)|
-                |(METHOD SPECIALIZER-CLASS (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 (SPECIALIZER-WITH-OBJECT METHOD))|
-                |(METHOD ADD-DIRECT-METHOD (CLASS METHOD))|
-                |(READER SLOT-NAME)| |(WRITER CACHED-FUNCTIONS-ALIST)|
-                |(WRITER INCOMPATIBLE-SUPERCLASS-LIST)|
-                |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))|
-                |SETF PCL CONSTRUCTOR-CODE-TYPE|
-                |(WRITER DECLARATIONS)|
-                |(WRITER CACHED-IN-GENERIC-FUNCTIONS)|
-                |(WRITER SPECIALIZERS)|
-                |(METHOD SPECIALIZER-CLASS (CLASS))|
-                |(METHOD SPECIALIZER-DIRECT-GENERIC-FUNCTIONS (CLASS))|
-                |(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)|
-                |(WRITER NEEDS-NEXT-METHODS-P)| |(READER LAMBDA-LIST)|
-                INITIALIZE-ALLOCATE-STATIC-SLOT-STORAGE-COPY
-                |SLOT-CLASS class predicate|
-                |SETF PCL SLOT-DEFINITION-INITFORM|
-                |(SETF METHOD-CACHED-FUNCTIONS)|
-                |(READER CAN-PRECEDE-LIST)|
-                |SETF PCL GENERIC-FUNCTION-METHOD-CLASS|
-                |(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
-                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))|
-                |(WRITER FUNCTION-NAME)| |(READER DFUN-STATE)|
-                |(READER FROM-DEFCLASS-P)| |SETF PCL GF-PRETTY-ARGLIST|
-                OPTIMIZE-INSTANCE-ACCESS
-                |SETF PCL SLOT-DEFINITION-LOCATION|
-                |SETF PCL SLOT-DEFINITION-READER-FUNCTION|
-                |SETF PCL SLOT-DEFINITION-WRITER-FUNCTION|
-                |SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION|
-                |SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION|
-                |SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION|
-                |SETF PCL SLOT-DEFINITION-ALLOCATION|
-                |SETF PCL SLOT-DEFINITION-INITFUNCTION|
-                |(METHOD MAKE-INSTANCES-OBSOLETE (SYMBOL))|
-                |(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))|
-                |(READER INTERNAL-SLOTD)|
-                |(METHOD MAKE-DIRECT-SLOTD (STRUCTURE-CLASS))|
-                |(METHOD MAKE-CLASS-PROTOTYPE (STRUCTURE-CLASS))|
-                |(METHOD MAKE-INSTANCES-OBSOLETE (STD-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))|
-                |(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 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 (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 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))|
-                |(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))|
-                |(METHOD SLOT-EXISTS-P-USING-CLASS (STD-CLASS STANDARD-OBJECT STANDARD-EFFECTIVE-SLOT-DEFINITION))|
-                |(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))|
-                |(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
-                |(METHOD SLOTS-FETCHER (STRUCTURE-CLASS))|
-                |(METHOD SLOTS-FETCHER (FUNCALLABLE-STANDARD-CLASS))|
-                |(METHOD SLOTS-FETCHER (STANDARD-CLASS))|
-                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)|
-                |STRUCTURE-SLOT-DEFINITION class predicate|
-                LEGAL-METHOD-FUNCTION-P |(WRITER INTERNAL-SLOTD)|
-                METHOD-CACHED-FUNCTIONS
-                |(METHOD INSTALL-LAZY-CONSTRUCTOR-INSTALLER (CONSTRUCTOR))|
-                CLASS-DEFSTRUCT-CONC-NAME |(WRITER METHOD-CLASS)|
-                |(METHOD ENSURE-CLASS-USING-CLASS (T PCL-CLASS))|
-                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)|
-                |(WRITER BOUNDP-FUNCTION)|
-                |(WRITER DIRECT-SUPERCLASSES)|
-                |(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
-                |(METHOD RAW-INSTANCE-ALLOCATOR (FUNCALLABLE-STANDARD-CLASS))|
-                |(METHOD RAW-INSTANCE-ALLOCATOR (STANDARD-CLASS))|
-                SEQUENCEP SPECIALIZER-METHOD-TABLE
-                |(METHOD MAYBE-UPDATE-CONSTRUCTORS (GENERIC-FUNCTION METHOD))|
-                METHOD-CLOSURE-GENERATOR REMOVE-CONSTRUCTOR
-                GF-PRETTY-ARGLIST SAME-SPECIALIZER-P CONSTRUCTOR-NAME
-                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
-                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
-                |(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)|
-                |(SETF SLOT-DEFINITION-INTERNAL-READER-FUNCTION)|
-                |(SETF SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION)|
-                |(SETF SLOT-DEFINITION-LOCATION)|
-                |(SETF SLOT-DEFINITION-READER-FUNCTION)|
-                |(SETF SLOT-DEFINITION-WRITER-FUNCTION)|
-                |(BOUNDP DEFSTRUCT-CONSTRUCTOR)|
-                |(SETF SLOT-DEFINITION-READERS)|
-                |(SETF SLOT-DEFINITION-WRITERS)|
-                MAYBE-UPDATE-CONSTRUCTORS |(SETF SLOT-DEFINITION-TYPE)|
-                CONSTRUCTOR-CODE-GENERATORS
-                |(SETF SLOT-DEFINITION-INITFORM)|
-                |EFFECTIVE-SLOT-DEFINITION class predicate|
-                MAKE-CLASS-PROTOTYPE |(BOUNDP VALID-P)|
-                |(BOUNDP INITARGS)| LONG-METHOD-COMBINATION-FUNCTION
-                |BUILT-IN-CLASS class predicate| GENERIC-FUNCTION-P
-                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)|
-                |(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| 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 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 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 DOCUMENTATION) (T T))|
-                |(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 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))|
-                |(METHOD LEGAL-QUALIFIER-P (STANDARD-METHOD T))|
-                |(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 (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))|
-                |(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-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)|
-                |(METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION LONG-METHOD-COMBINATION T))|
-                |(METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION SHORT-METHOD-COMBINATION T))|
-                |(METHOD COMPUTE-EFFECTIVE-METHOD (GENERIC-FUNCTION STANDARD-METHOD-COMBINATION T))|
-                |(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-INITARGS :AROUND (STRUCTURE-CLASS 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))|
-                |(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)|
-                |(WRITER CLASS-EQ-SPECIALIZER)|
-                |(METHOD FIND-METHOD-COMBINATION (GENERIC-FUNCTION (EQL STANDARD) T))|
-                STANDARD-BOUNDP-METHOD-P METHOD-FUNCTION-FOR-CACHING
-                |(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))|
-                |(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 ARG-INFO)| |(READER OPTIMIZED-METHOD-LAMBDA)|
-                COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO
-                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 |(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)| 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)| |(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|
-                |(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))|
-                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
-                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)) 
+(DOLIST (PCL::V '(PCL::ADD-READER-METHOD
+                     PCL::SHORT-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT
+                     PCL::|DEFINITION-SOURCE-MIXIN class predicate|
+                     PCL::REMOVE-READER-METHOD PCL::EQL-SPECIALIZER-P
+                     PCL::OBJECT-PLIST
+                     PCL::SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL
+                     PCL::SPECIALIZER-TYPE PCL::GF-DFUN-STATE
+                     PCL::CLASS-DEFSTRUCT-CONSTRUCTOR
+                     PCL::METHOD-FAST-FUNCTION PCL::SPECIALIZERP
+                     PCL::EXACT-CLASS-SPECIALIZER-P
+                     PCL::|STANDARD-OBJECT class predicate|
+                     PCL::COMPATIBLE-META-CLASS-CHANGE-P
+                     PCL::|STANDARD-METHOD-COMBINATION class predicate|
+                     PCL::UPDATE-GF-DFUN
+                     PCL::|STANDARD-EFFECTIVE-SLOT-DEFINITION class predicate|
+                     PCL::SPECIALIZER-OBJECT
+                     PCL::ACCESSOR-METHOD-SLOT-NAME
+                     PCL::|STANDARD-DIRECT-SLOT-DEFINITION class predicate|
+                     PCL::SPECIALIZER-CLASS PCL::CLASS-EQ-SPECIALIZER-P
+                     PCL::SLOTS-FETCHER PCL::REMOVE-WRITER-METHOD
+                     PCL::|STANDARD-SLOT-DEFINITION class predicate|
+                     PCL::STRUCTURE-CLASS-P PCL::UPDATE-CONSTRUCTORS
+                     PCL::DOCUMENTATION
+                     PCL::|SLOT-OBJECT class predicate|
+                     PCL::METHOD-PRETTY-ARGLIST
+                     PCL::|RATIONAL class predicate|
+                     PCL::CLASS-EQ-SPECIALIZER
+                     PCL::INFORM-TYPE-SYSTEM-ABOUT-CLASS
+                     PCL::|PCL-CLASS class predicate|
+                     PCL::ACCESSOR-METHOD-CLASS
+                     PCL::GENERIC-FUNCTION-PRETTY-ARGLIST
+                     PCL::MAKE-BOUNDP-METHOD-FUNCTION
+                     PCL::|SLOT-DEFINITION class predicate|
+                     PCL::|METAOBJECT class predicate|
+                     PCL::CLASS-PREDICATE-NAME
+                     PCL::|SEQUENCE class predicate| PCL::CLASSP
+                     PCL::|CHARACTER class predicate|
+                     PCL::|COMPLEX class predicate|
+                     PCL::|STD-CLASS class predicate|
+                     PCL::LEGAL-QUALIFIERS-P PCL::ADD-BOUNDP-METHOD
+                     PCL::LEGAL-LAMBDA-LIST-P
+                     PCL::|SETF PCL GENERIC-FUNCTION-NAME|
+                     PCL::|DEPENDENT-UPDATE-MIXIN class predicate|
+                     PCL::DESCRIBE-OBJECT
+                     PCL::MAKE-WRITER-METHOD-FUNCTION
+                     PCL::|SETF PCL GF-DFUN-STATE|
+                     PCL::|LONG-METHOD-COMBINATION class predicate|
+                     PCL::|VECTOR class predicate|
+                     PCL::|SETF PCL SLOT-DEFINITION-NAME|
+                     PCL::|SETF PCL CLASS-NAME|
+                     PCL::INITIALIZE-INTERNAL-SLOT-FUNCTIONS
+                     PCL::|SETF PCL SLOT-DEFINITION-TYPE|
+                     PCL::METHOD-COMBINATION-P
+                     PCL::|STRUCTURE-DIRECT-SLOT-DEFINITION class predicate|
+                     PCL::|STRUCTURE-EFFECTIVE-SLOT-DEFINITION class predicate|
+                     PCL::|SETF PCL GENERIC-FUNCTION-METHODS|
+                     PCL::|SETF PCL GENERIC-FUNCTION-METHOD-COMBINATION|
+                     PCL::|SETF PCL METHOD-GENERIC-FUNCTION|
+                     PCL::|SETF PCL SLOT-ACCESSOR-STD-P|
+                     PCL::LEGAL-SPECIALIZERS-P
+                     PCL::|SETF PCL OBJECT-PLIST|
+                     PCL::|SETF PCL SLOT-DEFINITION-INITFORM|
+                     PCL::|SETF PCL CLASS-DEFSTRUCT-FORM|
+                     PCL::|SETF PCL GENERIC-FUNCTION-METHOD-CLASS|
+                     PCL::SLOT-ACCESSOR-STD-P
+                     PCL::|SETF PCL GF-PRETTY-ARGLIST|
+                     PCL::|SETF PCL SLOT-ACCESSOR-FUNCTION|
+                     PCL::|SETF PCL SLOT-DEFINITION-LOCATION|
+                     PCL::|SETF PCL SLOT-DEFINITION-READER-FUNCTION|
+                     PCL::|SETF PCL SLOT-DEFINITION-WRITER-FUNCTION|
+                     PCL::|SETF PCL SLOT-DEFINITION-BOUNDP-FUNCTION|
+                     PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-READER-FUNCTION|
+                     PCL::|SETF PCL SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION|
+                     PCL::|SETF PCL SLOT-DEFINITION-ALLOCATION|
+                     PCL::|SETF PCL SLOT-DEFINITION-INITFUNCTION|
+                     PCL::METHOD-COMBINATION-OPTIONS
+                     PCL::|SETF PCL SLOT-DEFINITION-READERS|
+                     PCL::|STRUCTURE-OBJECT class predicate|
+                     PCL::|SETF PCL DOCUMENTATION|
+                     PCL::FUNCALLABLE-STANDARD-CLASS-P
+                     PCL::|SETF PCL SLOT-DEFINITION-CLASS|
+                     PCL::|SETF PCL SLOT-VALUE-USING-CLASS|
+                     PCL::CLASS-CAN-PRECEDE-LIST
+                     PCL::|SETF PCL CLASS-DIRECT-SLOTS|
+                     PCL::|SETF PCL CLASS-SLOTS|
+                     PCL::SLOT-ACCESSOR-FUNCTION
+                     PCL::|SETF PCL CLASS-INCOMPATIBLE-SUPERCLASS-LIST|
+                     PCL::|SETF PCL SLOT-DEFINITION-WRITERS|
+                     PCL::|STRUCTURE-SLOT-DEFINITION class predicate|
+                     PCL::SLOT-CLASS-P PCL::MAKE-READER-METHOD-FUNCTION
+                     PCL::|STRING class predicate|
+                     PCL::LEGAL-METHOD-FUNCTION-P
+                     PCL::|NUMBER class predicate| PCL::GET-METHOD
+                     PCL::SHORT-METHOD-COMBINATION-P PCL::GF-ARG-INFO
+                     PCL::|SYMBOL class predicate|
+                     PCL::SPECIALIZER-METHOD-TABLE
+                     PCL::MAKE-METHOD-INITARGS-FORM
+                     PCL::CLASS-DEFSTRUCT-FORM PCL::GF-PRETTY-ARGLIST
+                     PCL::SAME-SPECIALIZER-P
+                     PCL::SLOT-DEFINITION-BOUNDP-FUNCTION
+                     PCL::SLOT-DEFINITION-WRITER-FUNCTION
+                     PCL::SLOT-DEFINITION-READER-FUNCTION
+                     PCL::SLOT-DEFINITION-INTERNAL-WRITER-FUNCTION
+                     PCL::SLOT-DEFINITION-INTERNAL-READER-FUNCTION
+                     PCL::SLOT-DEFINITION-CLASS
+                     PCL::EQL-SPECIALIZER-OBJECT
+                     PCL::|RATIO class predicate|
+                     PCL::CLASS-CONSTRUCTORS PCL::SLOTS-TO-INSPECT
+                     PCL::SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
+                     PCL::ADD-WRITER-METHOD
+                     PCL::MAYBE-UPDATE-CONSTRUCTORS
+                     PCL::|EFFECTIVE-SLOT-DEFINITION class predicate|
+                     PCL::|LIST class predicate|
+                     PCL::LONG-METHOD-COMBINATION-FUNCTION
+                     PCL::|BUILT-IN-CLASS class predicate|
+                     PCL::GENERIC-FUNCTION-P PCL::|T class predicate|
+                     PCL::|FLOAT class predicate|
+                     PCL::|CONS class predicate| PCL::LEGAL-SLOT-NAME-P
+                     PCL::CLASS-WRAPPER PCL::|ARRAY class predicate|
+                     PCL::DEFINITION-SOURCE PCL::DEFAULT-INITARGS
+                     PCL::|NULL class predicate| PCL::CLASS-SLOT-VALUE
+                     PCL::FORWARD-REFERENCED-CLASS-P
+                     PCL::GF-FAST-METHOD-FUNCTION-P
+                     PCL::|SPECIALIZER-WITH-OBJECT class predicate|
+                     PCL::LEGAL-QUALIFIER-P PCL::METHOD-P
+                     PCL::|PLIST-MIXIN class predicate|
+                     PCL::CLASS-SLOT-CELLS
+                     PCL::STANDARD-ACCESSOR-METHOD-P
+                     PCL::STANDARD-GENERIC-FUNCTION-P
+                     PCL::STANDARD-READER-METHOD-P
+                     PCL::STANDARD-METHOD-P
+                     PCL::|TRACED-METHOD class predicate|
+                     PCL::COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS
+                     PCL::COMPUTE-DEFAULT-INITARGS
+                     PCL::|SETF PCL CLASS-SLOT-VALUE|
+                     PCL::METHOD-COMBINATION-TYPE PCL::STANDARD-CLASS-P
+                     PCL::LEGAL-SPECIALIZER-P
+                     PCL::COMPUTE-SLOT-ACCESSOR-INFO
+                     PCL::|DIRECT-SLOT-DEFINITION class predicate|
+                     PCL::STANDARD-BOUNDP-METHOD-P
+                     PCL::RAW-INSTANCE-ALLOCATOR
+                     PCL::|SETF PCL SLOT-DEFINITION-DEFSTRUCT-ACCESSOR-SYMBOL|
+                     PCL::COMPUTE-DISCRIMINATING-FUNCTION-ARGLIST-INFO
+                     PCL::STANDARD-WRITER-METHOD-P
+                     PCL::CLASS-INCOMPATIBLE-SUPERCLASS-LIST
+                     PCL::WRAPPER-FETCHER
+                     PCL::|INTEGER class predicate|
+                     PCL::METHOD-COMBINATION-DOCUMENTATION
+                     PCL::|SETF PCL SLOT-DEFINITION-INITARGS|
+                     PCL::REMOVE-BOUNDP-METHOD
+                     PCL::|SETF PCL CLASS-DEFSTRUCT-CONSTRUCTOR|
+                     PCL::|DOCUMENTATION-MIXIN class predicate|
+                     PCL::SHORT-COMBINATION-OPERATOR
+                     PCL::|BIT-VECTOR class predicate|
+                     PCL::REMOVE-NAMED-METHOD
+                     PCL::LEGAL-DOCUMENTATION-P
+                     PCL:CLASS-DIRECT-SUPERCLASSES
+                     PCL:CLASS-DIRECT-SUBCLASSES
+                     PCL:CLASS-DIRECT-DEFAULT-INITARGS
+                     PCL:SLOT-DEFINITION-READERS
+                     PCL:SLOT-VALUE-USING-CLASS
+                     PCL:COMPUTE-APPLICABLE-METHODS PCL:CLASS-NAME
+                     PCL:CLASS-PROTOTYPE PCL:READER-METHOD-CLASS
+                     PCL:REMOVE-METHOD PCL:SLOT-DEFINITION-INITFORM
+                     PCL:UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+                     PCL:UPDATE-INSTANCE-FOR-DIFFERENT-CLASS
+                     PCL:CHANGE-CLASS PCL:METHOD-FUNCTION
+                     PCL:DIRECT-SLOT-DEFINITION-CLASS
+                     PCL:MAKE-METHOD-LAMBDA
+                     PCL:EFFECTIVE-SLOT-DEFINITION-CLASS
+                     PCL:CLASS-SLOTS PCL:COMPUTE-SLOTS
+                     PCL:SLOT-DEFINITION-NAME PCL:FINALIZE-INHERITANCE
+                     PCL:GENERIC-FUNCTION-LAMBDA-LIST
+                     PCL:CLASS-DIRECT-SLOTS PCL:CLASS-DEFAULT-INITARGS
+                     PCL:COMPUTE-DISCRIMINATING-FUNCTION
+                     PCL:CLASS-FINALIZED-P PCL:GENERIC-FUNCTION-NAME
+                     PCL:REMOVE-DEPENDENT
+                     PCL:COMPUTE-CLASS-PRECEDENCE-LIST
+                     PCL:ADD-DEPENDENT PCL:SLOT-BOUNDP-USING-CLASS
+                     PCL:ACCESSOR-METHOD-SLOT-DEFINITION
+                     PCL:SHARED-INITIALIZE PCL:ADD-DIRECT-METHOD
+                     PCL:SLOT-DEFINITION-LOCATION
+                     PCL:SLOT-DEFINITION-INITFUNCTION
+                     PCL:SLOT-DEFINITION-ALLOCATION PCL:ADD-METHOD
+                     PCL:GENERIC-FUNCTION-METHOD-CLASS
+                     PCL:METHOD-SPECIALIZERS
+                     PCL:SLOT-DEFINITION-INITARGS
+                     PCL:WRITER-METHOD-CLASS PCL:ADD-DIRECT-SUBCLASS
+                     PCL:SPECIALIZER-DIRECT-METHODS
+                     PCL:GENERIC-FUNCTION-METHOD-COMBINATION
+                     PCL:ALLOCATE-INSTANCE PCL:COMPUTE-EFFECTIVE-METHOD
+                     PCL:SLOT-DEFINITION-TYPE PCL:SLOT-UNBOUND
+                     PCL:INITIALIZE-INSTANCE PCL:FUNCTION-KEYWORDS
+                     PCL:REINITIALIZE-INSTANCE PCL:VALIDATE-SUPERCLASS
+                     PCL:GENERIC-FUNCTION-METHODS
+                     PCL:REMOVE-DIRECT-METHOD PCL:METHOD-LAMBDA-LIST
+                     PCL:MAKE-INSTANCE
+                     PCL:COMPUTE-EFFECTIVE-SLOT-DEFINITION
+                     PCL:PRINT-OBJECT PCL:METHOD-QUALIFIERS
+                     PCL:METHOD-GENERIC-FUNCTION
+                     PCL:REMOVE-DIRECT-SUBCLASS
+                     PCL:MAKE-INSTANCES-OBSOLETE
+                     PCL:SLOT-MAKUNBOUND-USING-CLASS
+                     PCL:ENSURE-GENERIC-FUNCTION-USING-CLASS
+                     PCL:SLOT-MISSING PCL:MAP-DEPENDENTS
+                     PCL:FIND-METHOD-COMBINATION
+                     PCL:ENSURE-CLASS-USING-CLASS
+                     PCL:NO-APPLICABLE-METHOD
+                     PCL:SLOT-DEFINITION-WRITERS
+                     PCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES
+                     PCL:CLASS-PRECEDENCE-LIST))
+  (SETF (GET PCL::V 'COMPILER::PROCLAIMED-CLOSURE) T)) 
diff --git a/pcl/sysdef.lisp b/pcl/sysdef.lisp
index 6ddfed6d2..3056e6e3c 100644
--- a/pcl/sysdef.lisp
+++ b/pcl/sysdef.lisp
@@ -41,44 +41,7 @@
 (unless (boundp 'pcl::*redefined-functions*)
   (setq pcl::*redefined-functions* nil))
 
-(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")))
     (setq pcl::*pcl-directory* defsys)
@@ -111,7 +74,9 @@
 				 (lfi (get-loaded-file-info path)))
 			    (and lfi path-fwd (= path-fwd (lfi-fwd lfi)))))
 		      (pcl-binary-files)))
-    (reset-pcl-package)
+    (let ((b-s 'pcl::*boot-state*))
+      (when (and (boundp b-s) (symbol-value b-s))
+	(reset-pcl-package)))
     (pcl::load-pcl)))
 
 (defsystem pcl
@@ -133,9 +98,10 @@
    (progn
      (maybe-load-defsys t)
      (if (and (fboundp 'pcl::operation-transformations)
-	      (every #'(lambda (trans)
-			 (eq (car trans) :load))
-		     (pcl::operation-transformations 'pcl::pcl :compile)))
+	      (or (null (probe-file (subfile '("pcl") :name "defsys" :type "lisp")))
+		  (every #'(lambda (trans)
+			     (eq (car trans) :load))
+			 (pcl::operation-transformations 'pcl::pcl :compile))))
 	 (maybe-load-pcl)
 	 (let ((b-s 'pcl::*boot-state*))
 	   (when (and (boundp b-s) (symbol-value b-s))
@@ -145,7 +111,8 @@
 					 si::*system-directory*))
 	   (#+cmu with-compilation-unit #-cmu progn
 	    #+cmu (:optimize 
-		   '(optimize (user::debug-info #+small .5 #-small 2)
+		   '(optimize (user::debug-info #+(and small (not testing)) .5
+			                        #-(and small (not testing)) 2)
 		              (speed #+testing 1 #-testing 2)
 		              (safety #+testing 3 #-testing 0)
 		              #+ignore (user::inhibit-warnings 2))
@@ -157,7 +124,8 @@
 		       #-testing *fast-declaration*)
 	     (pcl::compile-pcl))
 	   (reset-pcl-package)
-	   (maybe-load-pcl t))))
+	   (maybe-load-pcl t)))
+     #+cmu (lisp::purify))
    :load
    (progn 
      (maybe-load-pcl)
diff --git a/pcl/time.lisp b/pcl/time.lisp
index 9abf2a7fa..06aefc4ca 100644
--- a/pcl/time.lisp
+++ b/pcl/time.lisp
@@ -9,19 +9,13 @@
 (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))
 
-(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))
       *tests*)
@@ -88,7 +82,7 @@
 	    '(time-default-initargs (find-class 'plist-mixin) 1000))
       *tests*)
 (defun time-default-initargs (class n)
-  (time (dotimes (i n) (default-initargs class nil (class-default-initargs class)))))
+  (time (dotimes (i n) (default-initargs class nil))))
 
 
 (push (cons "Time make-instance."
@@ -97,25 +91,18 @@
 (defun time-make-instance (class n)
   (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))
+(push (cons "Time constant-keys make-instance."
+	    '(time-constant-keys-make-instance 1000))
       *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))))
+(expanding-make-instance-top-level
+(defun constant-keys-make-instance (n)
+  (dotimes (i n) (make-instance 'plist-mixin))))
 
+(precompile-random-code-segments)
+
+(defun time-constant-keys-make-instance (n)
+  (time (constant-keys-make-instance n)))
 
 (defun expand-all-macros (form)
   (walk-form form nil #'(lambda (form context env)
@@ -127,17 +114,17 @@
 			      (values (macroexpand form env))
 			      form))))
 
-(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)))
+(push (cons "Macroexpand meth-structure-slot-value"
+	    '(pprint (multiple-value-bind (pgf pm)
+			 (prototypes-for-make-method-lambda 
+			  'meth-structure-slot-value)
+		       (expand-defmethod
+			'meth-structure-slot-value pgf pm
+			nil '((object str))
+			'(#'(lambda () (slot-value object 'slot)))
+			nil))))
       *tests*)
+
 #-kcl
 (push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
 	    '(disassemble (meth-structure-slot-value str)))
@@ -149,15 +136,10 @@
 #|| ; interesting, but long.  (produces 100 lines of output)
 (push (cons "Macroexpand meth-standard-slot-value"
 	    '(pprint (expand-all-macros
-                       (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))))
+		     (expand-defmethod-internal 'meth-standard-slot-value
+		      nil '((object standard-method))
+		      '(#'(lambda () (slot-value object 'function)))
+		      nil))))
       *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/vector.lisp b/pcl/vector.lisp
index d3ae7c761..b1a4161c5 100644
--- a/pcl/vector.lisp
+++ b/pcl/vector.lisp
@@ -29,191 +29,575 @@
 
 (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)
-  `(instance-slot-index-from-slots-layout
-      (wrapper-instance-slots-layout ,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)))))
 
 
 ;;;
 ;;;
 ;;;
+(defun pv-cache-limit-fn (nlines)
+  (default-limit-fn nlines))
+
+(defstruct (pv-table
+	     (:predicate pv-tablep)
+	     (:constructor make-pv-table-internal
+			   (slot-name-lists call-list)))
+  (cache nil :type (or cache null))
+  (pv-size 0 :type fixnum)
+  (slot-name-lists nil :type list)
+  (call-list nil :type list))
+
+(defvar *initial-pv-table* (make-pv-table-internal nil nil))
+
+; help new slot-value-using-class methods affect fast iv access
+(defvar *all-pv-table-list* nil) 
+
+(defun make-pv-table (&key slot-name-lists call-list)
+  (let ((pv-table (make-pv-table-internal slot-name-lists call-list)))
+    (push pv-table *all-pv-table-list*)
+    pv-table))
+
+(defun make-pv-table-type-declaration (var)
+  `(type pv-table ,var))
+
+(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
+(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
+
+;entries in this are lists of (table . pv-offset-list)
+(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
+
+(defun intern-pv-table (&key slot-name-lists call-list)
+  (let ((new-p nil))
+    (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*)
+		       (let ((snl (copy-list (cdr x)))
+			     (cl (car x)))
+			 (setq new-p t)
+			 (make-pv-table :slot-name-lists snl
+					:call-list cl))))))
+    (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists)))))
+      (when new-p
+	(let ((pv-index 1))
+	  (dolist (slot-name-list slot-name-lists)
+	    (dolist (slot-name (cdr slot-name-list))
+	      (note-pv-table-reference slot-name pv-index pv-table)
+	      (incf pv-index)))
+	  (dolist (gf-call call-list)
+	    (note-pv-table-reference gf-call pv-index pv-table)
+	    (incf pv-index))
+	  (setf (pv-table-pv-size pv-table) pv-index)))
+      pv-table))))
+
+(defun note-pv-table-reference (ref pv-offset pv-table)
+  (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
+    (when (listp entry)
+      (let ((table-entry (assq pv-table entry)))
+	(when (and (null table-entry)
+		   (> (length entry) 8))
+	  (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
+	    (dolist (table-entry entry)
+	      (setf (gethash (car table-entry) new-table-table)
+		    (cdr table-entry)))
+	    (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
+	(when (listp entry)
+	  (if (null table-entry)
+	      (let ((new (cons pv-table pv-offset)))
+		(if (consp entry)
+		    (push new (cdr entry))
+		    (setf (gethash ref *pv-key-to-pv-table-table*) (list new))))
+	      (push pv-offset (cdr table-entry)))
+	  (return-from note-pv-table-reference nil))))
+    (let ((list (gethash pv-table entry)))
+      (if (consp list)
+	  (push pv-offset (cdr list))
+	  (setf (gethash pv-table entry) (list pv-offset)))))
+  nil)
+
+(defun map-pv-table-references-of (ref function)
+  (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
+    (if (listp entry)
+	(dolist (table+pv-offset-list entry)
+	  (funcall function
+		   (car table+pv-offset-list) (cdr table+pv-offset-list)))
+	(maphash function entry)))
+  ref)
+
+
+(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))
+  (or (not (eq *boot-state* 'complete))
+      (let ((slotd (find-slot-definition class slot-name)))
+	(and slotd 
 	     (slot-accessor-std-p slotd type)))))
 
-(defun optimize-generic-function-call (form required-parameters env)
-  (declare (ignore env required-parameters))
-  form
-  #||
-  (let* ((gf-name (car form))
-	 (gf (gdefinition gf-name))
-	 (arg-info (gf-arg-info gf))
-	 (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 (consp arg)
-                              (setq arg (un-the arg)))
-			    (and (symbolp arg)
-				 (memq arg required-parameters))
-			    (let ((class-name (caddr (variable-declaration 
-						      'class arg env))))
-			      (and class-name (not (eq 't class-name)))))
-			(cdr form) metatypes)))
-	form
-	form))||#) ;`(maybe-fast-gf-call ,(car form) ,(cdr form))
-
-
-;; For calls to a gf:
-; gf-call-info: (gf call-info-vector . gf-function-vector)
-; call-info-vector:     #(call-info1 ... call-infon)
-; gf-function-vector:   #(function1 ... functionn)
-; --> once an entry is made in call-info-vector, it is never moved or removed
-; call-info:            (gf . arg-types)
-; arg-type:             a type. `(arg ,n) is not allowed here.
-
-;; For calls from a method:
-; method-gf-call-info:  (method-specializers method-call-info-vector . ???)
-; arg-type:             a type or `(arg ,n)
-; when arg-type is (arg n) the real type is either:
-;   the arg's specializer or
-;   (wrapper-eq ,wrapper) for a call appearing within a caching dfun gf
-
-; every optimized gf in a method has an entry in the method's method-call-info-vector
-; a macro: (get-call-cell mciv-index .all-wrappers.) ->
-;          index into the gf-function-vector
-
-;(defmacro maybe-fast-gf-call (gf-name args)
-;   nil)
+(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell)
+  (if (symbolp slot-name)
+      (when (optimize-slot-value-by-class-p class slot-name 'all)
+	(or (instance-slot-index wrapper slot-name)
+	    (let ((cell (assq slot-name class-slots)))
+	      (when cell
+		(setf (car class-slot-p-cell) t)
+		cell))))
+      (when (consp slot-name)
+	(dolist (type '(reader writer) nil)
+	  (when (eq (car slot-name) type)
+	    (return
+	      (let* ((gf-name (cadr slot-name))
+		     (gf (gdefinition gf-name))
+		     (location 
+		      (when (eq *boot-state* 'complete)
+			(accessor-values1 gf type class))))
+		(when (consp location)
+		  (setf (car class-slot-p-cell) t))
+		location)))))))
+
+(defun compute-pv (slot-name-lists wrappers)
+  (unless (listp wrappers) (setq wrappers (list wrappers)))
+  (let* ((not-simple-p-cell (list nil))
+	 (elements
+	  (gathering1 (collecting)
+	    (iterate ((slot-names (list-elements slot-name-lists)))
+	      (when slot-names
+		(let* ((wrapper     (pop wrappers))
+		       (class       (wrapper-class* wrapper))
+		       (class-slots (wrapper-class-slots wrapper)))
+		  (dolist (slot-name (cdr slot-names))
+		    (gather1
+		     (compute-pv-slot slot-name wrapper class 
+				      class-slots not-simple-p-cell)))))))))
+    (if (car not-simple-p-cell)
+	(make-permutation-vector (cons t elements))
+	(or (gethash elements *pvs*)
+	    (setf (gethash elements *pvs*)
+		  (make-permutation-vector (cons nil elements)))))))
+
+(defun compute-calls (call-list wrappers)
+  (map 'vector
+       #'(lambda (call)
+	   (compute-emf-from-wrappers call wrappers))
+       call-list))
+
+(defun compute-emf-from-wrappers (call wrappers)
+  (when call
+    (destructuring-bind (gf-name nreq restp arg-info) call
+      (if (eq gf-name 'make-instance)
+	  (error "should not get here") ; there is another mechanism for this.
+	  #'(lambda (&rest args)
+	      (if (not (eq *boot-state* 'complete))
+		  (apply (gdefinition gf-name) args)
+		  (let* ((gf (gdefinition gf-name))
+			 (arg-info (arg-info-reader gf))
+			 (classes '?)
+			 (types '?)
+			 (emf (cache-miss-values-internal gf arg-info 
+							  wrappers classes types 
+							  'caching)))
+		    (update-all-pv-tables call wrappers emf)
+		    (invoke-emf emf args))))))))
+
+(defun make-permutation-vector (indexes)
+  (make-array (length indexes) :initial-contents indexes))
+
+(defun pv-table-lookup (pv-table pv-wrappers)
+  (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
+	 (call-list (pv-table-call-list pv-table))
+	 (cache (or (pv-table-cache pv-table)
+		    (setf (pv-table-cache pv-table)
+			  (get-cache (- (length slot-name-lists)
+					(count nil slot-name-lists))
+				     t
+				     #'pv-cache-limit-fn
+				     2)))))
+    (or (probe-cache cache pv-wrappers)
+	(let* ((pv (compute-pv slot-name-lists pv-wrappers))
+	       (calls (compute-calls call-list pv-wrappers))
+	       (pv-cell (cons pv calls))
+	       (new-cache (fill-cache cache pv-wrappers pv-cell)))
+	  (unless (eq new-cache cache)
+	    (setf (pv-table-cache pv-table) new-cache)
+	    (free-cache cache))
+	  pv-cell))))
+
+(defun make-pv-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defvar *empty-pv* #())
+
+(defmacro pvref (pv index)
+  `(svref ,pv ,index))
+
+(defmacro copy-pv (pv)
+  `(copy-seq ,pv))
+
+(defun make-calls-type-declaration (var)
+  `(type simple-vector ,var))
+
+(defmacro callsref (calls index)
+  `(svref ,calls ,index))
+
+(defvar *pv-table-cache-update-info* nil)
+
+;called by: 
+;(method shared-initialize :after (structure-class t))
+;update-slots
+(defun update-pv-table-cache-info (class)
+  (let ((slot-names-for-pv-table-update nil)
+	(new-icui nil))
+    (dolist (icu *pv-table-cache-update-info*)
+      (if (eq (car icu) class)
+	  (pushnew (cdr icu) slot-names-for-pv-table-update)
+	  (push icu new-icui)))
+    (setq *pv-table-cache-update-info* new-icui)
+    (when slot-names-for-pv-table-update
+      (update-all-pv-table-caches class slot-names-for-pv-table-update))))
+
+(defun update-all-pv-table-caches (class slot-names)
+  (let* ((cwrapper (class-wrapper class))
+	 (class-slots (wrapper-class-slots cwrapper))
+	 (class-slot-p-cell (list nil))
+	 (new-values (mapcar #'(lambda (slot-name)
+				 (cons slot-name
+				       (compute-pv-slot 
+					slot-name cwrapper class 
+					class-slots class-slot-p-cell)))
+			     slot-names))
+	 (pv-tables nil))
+    (dolist (slot-name slot-names)
+      (map-pv-table-references-of
+       slot-name
+       #'(lambda (pv-table pv-offset-list)
+	   (declare (ignore pv-offset-list))
+	   (pushnew pv-table pv-tables))))
+    (dolist (pv-table pv-tables)
+      (let* ((cache (pv-table-cache pv-table))
+	     (slot-name-lists (pv-table-slot-name-lists pv-table))
+	     (pv-size (pv-table-pv-size pv-table))
+	     (pv-map (make-array pv-size)))
+	(let ((map-index 1)(param-index 0))
+	  (dolist (slot-name-list slot-name-lists)
+	    (dolist (slot-name (cdr slot-name-list))
+	      (let ((a (assoc slot-name new-values)))
+		(setf (svref pv-map map-index)
+		      (and a (cons param-index (cdr a)))))
+	      (incf map-index))
+	    (incf param-index)))
+	(when cache
+	  (map-cache #'(lambda (wrappers pv-cell)
+			 (setf (car pv-cell)
+			       (update-slots-in-pv wrappers (car pv-cell)
+						   cwrapper pv-size pv-map)))
+		     cache))))))
+
+(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
+  (if (not (if (atom wrappers)
+	       (eq cwrapper wrappers)
+	       (dolist (wrapper wrappers nil)
+		 (when (eq wrapper cwrapper)
+		   (return t)))))
+      pv
+      (let* ((old-intern-p (listp (pvref pv 0)))
+	     (new-pv (if old-intern-p
+			 (copy-pv pv)
+			 pv))
+	     (new-intern-p t))
+	(if (atom wrappers)
+	    (dotimes (i pv-size)
+	      (when (consp (let ((map (svref pv-map i)))
+			     (if map
+				 (setf (pvref new-pv i) (cdr map))
+				 (pvref new-pv i))))
+		(setq new-intern-p nil)))
+	    (let ((param 0))
+	      (dolist (wrapper wrappers)
+		(when (eq wrapper cwrapper)
+		  (dotimes (i pv-size)
+		    (when (consp (let ((map (svref pv-map i)))
+				   (if (and map (= (car map) param))
+				       (setf (pvref new-pv i) (cdr map))
+				       (pvref new-pv i))))
+		      (setq new-intern-p nil))))
+		(incf param))))
+	(when new-intern-p
+	  (setq new-pv (let ((list-pv (coerce pv 'list)))
+			 (or (gethash (cdr list-pv) *pvs*)
+			     (setf (gethash (cdr list-pv) *pvs*)
+				   (if old-intern-p
+				       new-pv
+				       (make-permutation-vector list-pv)))))))
+	new-pv)))
 
 
+(defun maybe-expand-accessor-form (form required-parameters slots env)
+  (let* ((fname (car form))
+	 (len (length form))
+	 (gf (if (symbolp fname)
+		 (unencapsulated-fdefinition fname)
+		 (gdefinition fname))))
+    (macrolet ((maybe-optimize-reader ()
+		 `(let ((parameter
+			 (can-optimize-access1 (cadr form)
+					       required-parameters env)))
+		   (when parameter
+		     (optimize-reader slots parameter gf-name form))))
+	       (maybe-optimize-writer ()
+		 `(let ((parameter
+			 (can-optimize-access1 (caddr form)
+					       required-parameters env)))
+		   (when parameter
+		     (optimize-writer slots parameter gf-name form)))))
+      (unless (and (consp (cadr form))
+		   (eq 'instance-accessor-parameter (caadr form)))
+	(or #||
+	    (cond ((and (= len 2) (symbolp fname))
+		   (let ((gf-name (gethash fname *gf-declared-reader-table*)))
+		     (when gf-name
+		       (maybe-optimize-reader))))
+		  ((= len 3)
+		   (let ((gf-name (gethash fname *gf-declared-writer-table*)))
+		     (when gf-name
+		       (maybe-optimize-writer)))))
+	    ||#
+	    (when (and (eq *boot-state* 'complete)
+		       (generic-function-p gf))
+	      (let ((methods (generic-function-methods gf)))
+		(when methods
+		  (let* ((gf-name (generic-function-name gf))
+			 (arg-info (gf-arg-info gf))
+			 (metatypes (arg-info-metatypes arg-info))
+			 (nreq (length metatypes))
+			 (applyp (arg-info-applyp arg-info)))
+		    (when (null applyp)
+		      (cond ((= nreq 1)
+			     (when (some #'standard-reader-method-p methods)
+			       (maybe-optimize-reader)))
+			    ((and (= nreq 2)
+				  (consp gf-name)
+				  (eq (car gf-name) 'setf))
+			     (when (some #'standard-writer-method-p methods)
+			       (maybe-optimize-writer))))))))))))))
+
+(defun optimize-generic-function-call (form required-parameters env slots calls)
+  (declare (ignore required-parameters env slots calls))
+  (or (and (eq (car form) 'make-instance)
+	   (expand-make-instance-form form t))
+      #||
+      (maybe-expand-accessor-form form required-parameters slots env)
+      (let* ((fname (car form))
+	     (len (length form))
+	     (gf (if (symbolp fname)
+		     (and (fboundp fname)
+			  (unencapsulated-fdefinition fname))
+		     (and (gboundp fname)
+			  (gdefinition fname))))
+	     (gf-name (and (fsc-instance-p gf)
+			   (if (early-gf-p gf)
+			       (early-gf-name gf)
+			       (generic-function-name gf)))))
+	(when gf-name
+	  (multiple-value-bind (nreq restp)
+	      (get-generic-function-info gf)
+	    (optimize-gf-call slots calls form nreq restp env))))
+      ||#
+      form))
+
+
+
 (defun can-optimize-access (form required-parameters env)
   (let ((type (ecase (car form)
 		(slot-value 'reader)
 		(set-slot-value 'writer)
 		(slot-boundp 'boundp)))
-	(var (un-the (cadr form)))
+	(var (cadr form))
 	(slot-name (eval (caddr form)))) ; known to be constant
-    (when (symbolp var)
-      (let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))
-	     (parameter-or-nil (car (memq (or rebound? var) required-parameters))))
-	(when parameter-or-nil
-	  (let* ((class-name (caddr (variable-declaration 
-				     'class parameter-or-nil env)))
-		 (class (find-class class-name nil)))
-	    (when (if (and 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))))
+    (can-optimize-access1 var required-parameters env type slot-name)))
+
+(defun can-optimize-access1 (var required-parameters env &optional type slot-name)
+  (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))))
+      (when parameter-or-nil
+	(let* ((class-name (caddr (variable-declaration 
+				   'class parameter-or-nil env)))
+	       (class (find-class class-name nil)))
+	  (when (or (not (eq *boot-state* 'complete))
+		    (and class (not (class-finalized-p class))))
+	    (setq class nil))
+	  (when (and class-name (not (eq class-name 't)))
+	    (when (or (null type)
+		      (not (and class
+				(memq *the-class-structure-object*
+				      (class-precedence-list class))))
+		      (optimize-slot-value-by-class-p class slot-name type))
 	      (cons parameter-or-nil (or class class-name)))))))))
 
-(defun optimize-slot-value (generic-function method slots sparameter form)
+(defun optimize-slot-value (slots sparameter form)
   (if sparameter
       (destructuring-bind (ignore ignore slot-name-form) 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)
+	(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)
   (if sparameter
       (destructuring-bind (ignore ignore slot-name-form new-value) 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)
+	(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)
   (if sparameter
       (destructuring-bind (ignore ignore slot-name-form new-value) 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))))
+	(let ((slot-name (eval slot-name-form)))
+	  (optimize-instance-access slots :boundp sparameter slot-name new-value)))
+      `(accessor-slot-boundp ,@(cdr form))))
+
+(defun optimize-reader (slots sparameter gf-name form)
+  (if sparameter
+      (optimize-accessor-call slots :read sparameter gf-name nil)
+      form))
 
+(defun optimize-writer (slots sparameter gf-name form)
+  (if sparameter
+      (destructuring-bind (ignore ignore new-value) form
+	(optimize-accessor-call slots :write sparameter gf-name new-value))
+      form))
 ;;;
 ;;; The <slots> argument is an alist, the CAR of each entry is the name of
 ;;; a required parameter to the function.  The alist is in order, so the
 ;;; 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)))))))
 
-(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.")))))
+(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
+  (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
+	 (parameter (if (consp sparameter) (car sparameter) sparameter))
+	 (parameter-entry (assq parameter slots))
+	 (name (case read/write
+		 (:read `(reader ,gf-name))
+		 (:write `(writer ,gf-name))))
+	 (slot-entry      (assoc name (cdr parameter-entry) :test #'equal))
+	 (position (posq parameter-entry slots))
+	 (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
     (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))
+    (unless slot-entry
+      (setq slot-entry (list name))
       (push slot-entry (cdr parameter-entry)))
+    (push pv-offset-form (cdr slot-entry))
     (ecase read/write
       (:read
-       (if slot-entry
-           `(instance-read   ,parameter ',slot-name ,index-name ,class-name)
-           `(fast-slot-value ,parameter ',slot-name)))
+       `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
       (: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))))))
+       `(let ((.new-value. ,new-value)) 
+	  (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
+	                   .new-value.))))))
+
+(defvar *unspecific-arg* '..unspecific-arg..)
+
+(defun optimize-gf-call-internal (form slots env)
+  (when (and (consp form)
+	     (eq (car form) 'the))
+    (setq form (caddr form)))
+  (or (and (symbolp form)
+	   (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
+							 form env)))
+		  (parameter-or-nil (car (assq (or rebound? form) slots))))
+	     (when parameter-or-nil
+	       (let* ((class-name (caddr (variable-declaration 
+					  'class parameter-or-nil env))))
+		 (when (and class-name (not (eq class-name 't)))
+		   (position parameter-or-nil slots :key #'car))))))
+      (if (constantp form)
+	  (let ((form (eval form)))
+	    (if (symbolp form)
+		form
+		*unspecific-arg*))
+	  *unspecific-arg*)))
 
+(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
+  (unless (eq (car gf-call-form) 'make-instance) ; needs more work
+    (let* ((args (cdr gf-call-form))
+	   (all-args-p (eq (car gf-call-form) 'make-instance))
+	   (non-required-args (nthcdr nreq args))
+	   (required-args (ldiff args non-required-args))
+	   (call-spec (list (car gf-call-form) nreq restp
+			    (mapcar #'(lambda (form)
+					(optimize-gf-call-internal form slots env))
+				    (if all-args-p
+					args
+					required-args))))
+	   (call-entry (assoc call-spec calls :test #'equal))
+	   (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
+      (unless (some #'integerp 
+		    (let ((spec-args (cdr call-spec)))
+		      (if all-args-p 
+			  (ldiff spec-args (nthcdr nreq spec-args))
+			  spec-args)))
+	(return-from optimize-gf-call nil))
+      (unless call-entry
+	(setq call-entry (list call-spec))
+	(push call-entry (cdr calls)))
+      (push pv-offset-form (cdr call-entry))
+      (if (eq (car call-spec) 'make-instance)
+	  `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
+	  `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
+	    (invoke-effective-method-function .emf. ,restp
+	     ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
+      
+
+(define-walker-template pv-offset) ; These forms get munged by mutate slots.
+(defmacro pv-offset (arg) arg)
+(define-walker-template instance-accessor-parameter)
+(defmacro instance-accessor-parameter (x) x)
 
 ;; It is safe for these two functions to be wrong.
 ;; They just try to guess what the most likely case will be.
@@ -224,231 +608,436 @@
 	 (standard-class-p class)
 	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
 	 (let ((slotd (find-slot-definition class slot-name)))
-           (and slotd (consp (slot-definition-location slotd)))))))
+	   (and slotd (classp (slot-definition-allocation slotd)))))))
 
-(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)))))
+(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))))
     (and (eq *boot-state* 'complete)
 	 (standard-class-p class)
 	 (not (eq class *the-class-t*)) ; shouldn't happen, though.
-         (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)))))))
+	 (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 (the boolean (slot-accessor-std-p slotd type))))))
+	 (not (slot-accessor-std-p slotd type)))))
 
-(defmacro instance-read (parameter slot-name index class)
+(defmacro instance-read-internal (pv slots pv-offset default &optional type)
+  (unless (member type '(nil :instance :class :default))
+    (error "Illegal type argument to ~S: ~S" 'instance-read-internal type))
+  (if (eq type ':default)
+      default
+      (let* ((index (gensym))
+	     (value index))
+	`(locally (declare #.*optimize-speed*)
+	  (let ((,index (pvref ,pv ,pv-offset)))
+	    (setq ,value (typecase ,index
+			   ,@(when (or (null type) (eq type ':instance))
+			       `((fixnum (%instance-ref ,slots ,index))))
+			   ,@(when (or (null type) (eq type ':class))
+			       `((cons (cdr ,index))))
+			   (t ',*slot-unbound*)))
+	    (if (eq ,value ',*slot-unbound*)
+		,default
+		,value))))))
+
+(defmacro instance-read (pv-offset parameter position slot-name class)
   (if (skip-fast-slot-access-p class slot-name 'reader)
-      `(fast-slot-value ,parameter ,slot-name)
-      `(optimized-parameter-read ,parameter ,slot-name ,index)))
+      `(accessor-slot-value ,parameter ,slot-name)
+      `(instance-read-internal .pv. ,(slot-vector-symbol position)
+	,pv-offset (accessor-slot-value ,parameter ,slot-name)
+	,(if (generate-fast-class-slot-access-p class slot-name)
+	     ':class ':instance))))
+
+(defmacro instance-reader (pv-offset parameter position gf-name class)
+  (declare (ignore class))
+  `(instance-read-internal .pv. ,(slot-vector-symbol position)
+    ,pv-offset 
+    (,gf-name (instance-accessor-parameter ,parameter))
+    :instance))
 
-(defmacro instance-write (parameter slot-name index class new-value)
+(defmacro instance-write-internal (pv slots pv-offset new-value default
+				      &optional type)
+  (unless (member type '(nil :instance :class :default))
+    (error "Illegal type argument to ~S: ~S" 'instance-write-internal type))
+  (if (eq type ':default)
+      default
+      (let* ((index (gensym)))
+	`(locally (declare #.*optimize-speed*)
+	  (let ((,index (pvref ,pv ,pv-offset)))
+	    (typecase ,index
+	      ,@(when (or (null type) (eq type ':instance))
+		  `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
+	      ,@(when (or (null type) (eq type ':class))
+		  `((cons (setf (cdr ,index) ,new-value))))
+	      (t ,default)))))))
+
+(defmacro instance-write (pv-offset parameter position slot-name class new-value)
   (if (skip-fast-slot-access-p class slot-name 'writer)
-      `(fast-set-slot-value ,parameter ,slot-name ,new-value)
-      `(optimized-parameter-write ,parameter ,slot-name ,index ,new-value)))
+      `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
+      `(instance-write-internal .pv. ,(slot-vector-symbol position)
+	,pv-offset ,new-value
+	(accessor-set-slot-value ,parameter ,slot-name ,new-value)
+	,(if (generate-fast-class-slot-access-p class slot-name)
+	     ':class ':instance))))
 
-(defmacro instance-boundp (parameter slot-name index class)
-  (if (skip-fast-slot-access-p class slot-name 'boundp)
-      `(fast-slot-boundp ,parameter ,slot-name)
-      `(optimized-parameter-boundp ,parameter ,slot-name ,index)))
-
-
-;;; 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 (method-function-funcall closure-generator nil)))
-    #+(and kcl turbo-closure) (si:turbo-closure function)
-    function))
-
-(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))))))))
+(defmacro instance-writer (pv-offset parameter position gf-name class new-value)
+  (declare (ignore class))
+  `(instance-write-internal .pv. ,(slot-vector-symbol position)
+    ,pv-offset ,new-value
+    (,(if (consp gf-name)
+	  (get-setf-function-name gf-name)
+	  gf-name)
+     (instance-accessor-parameter ,parameter)
+     ,new-value)
+    :instance))
 
-
-(defmethod wrapper-fetcher ((class standard-class))
-  'std-instance-wrapper)
+(defmacro instance-boundp-internal (pv slots pv-offset default
+				       &optional type)
+  (unless (member type '(nil :instance :class :default))
+    (error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type))
+  (if (eq type ':default)
+      default
+      (let* ((index (gensym)))
+	`(locally (declare #.*optimize-speed*)
+	  (let ((,index (pvref ,pv ,pv-offset)))
+	    (typecase ,index
+	      ,@(when (or (null type) (eq type ':instance))
+		  `((fixnum (not (eq (%instance-ref ,slots ,index) ',*slot-unbound*)))))
+	      ,@(when (or (null type) (eq type ':class))
+		  `((cons (not (eq (cdr ,index) ',*slot-unbound*)))))
+	      (t ,default)))))))
 
-(defmethod slots-fetcher ((class standard-class))
-  'std-instance-slots)
+(defmacro instance-boundp (pv-offset parameter position slot-name class)
+  (if (skip-fast-slot-access-p class slot-name 'boundp)
+      `(accessor-slot-boundp ,parameter ,slot-name)
+      `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
+	,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
+	,(if (generate-fast-class-slot-access-p class slot-name)
+	     ':class ':instance))))
 
-(defmethod raw-instance-allocator ((class standard-class))
-  '%%allocate-instance--class)
+;;;
+;;; 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 PV-TABLE'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 calls)
+  (multiple-value-bind (slots calls)
+      (mutate-slots-and-calls slots calls)
+    (let* ((slot-name-lists
+	    (mapcar #'(lambda (parameter-entry)
+			(cons nil (mapcar #'car (cdr parameter-entry))))
+		    slots))
+	   (call-list
+	    (mapcar #'car calls)))
+      (dolist (call call-list)
+	(dolist (arg (cdr call))
+	  (when (integerp arg)
+	    (setf (car (nth arg slot-name-lists)) t))))
+      (setq slot-name-lists (mapcar #'(lambda (r+snl)
+					(when (or (car r+snl) (cdr r+snl))
+					  r+snl))
+				    slot-name-lists))
+      (let ((cvt (apply #'vector
+			(let ((i -1))
+			  (mapcar #'(lambda (r+snl)
+				      (when r+snl (incf i)))
+				  slot-name-lists)))))
+	(setq call-list (mapcar #'(lambda (call)
+				    (cons (car call) 
+					  (mapcar #'(lambda (arg)
+						      (if (integerp arg)
+							  (svref cvt arg)
+							  arg))
+						  (cdr call))))
+				call-list)))
+      (values slot-name-lists call-list))))
 
+(defun mutate-slots-and-calls (slots calls)
+  (let ((sorted-slots (sort-slots slots))
+	(sorted-calls (sort-calls (cdr calls)))
+	(pv-offset 0))  ; index 0 is for info
+    (dolist (parameter-entry sorted-slots)
+      (dolist (slot-entry (cdr parameter-entry))
+	(incf pv-offset)	
+	(dolist (form (cdr slot-entry))
+	  (setf (cadr form) pv-offset))))
+    (dolist (call-entry sorted-calls)
+      (incf pv-offset)
+      (dolist (form (cdr call-entry))
+	(setf (cadr form) pv-offset)))
+    (values sorted-slots sorted-calls)))
 
-(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 symbol-pkg-name (sym) 
+  (let ((pkg (symbol-package sym)))
+    (if pkg (package-name pkg) "")))
 
-(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)))))
+(defun symbol-lessp (a b)
+  (if (eq (symbol-package a)
+	  (symbol-package b))
+      (string-lessp (symbol-name a)
+		    (symbol-name b))
+      (string-lessp (symbol-pkg-name a)
+		    (symbol-pkg-name b))))
 
-;;;
-;;;   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.
-;;;
+(defun symbol-or-cons-lessp (a b)
+  (etypecase a
+    (symbol (etypecase b
+	      (symbol (symbol-lessp a b))
+	      (cons t)))
+    (cons   (etypecase b
+	      (symbol nil)
+	      (cons (if (eq (car a) (car b))
+			(symbol-or-cons-lessp (cdr a) (cdr b))
+			(symbol-or-cons-lessp (car a) (car b))))))))
 
-#+pcl-user-instances
-(progn
-(proclaim '(notinline user-instance-p
-                      user-instance-wrapper
-                      user-instance-slots
-                      set-user-instance-wrapper
-                      set-user-instance-slots))
+(defun sort-slots (slots)
+  (mapcar #'(lambda (parameter-entry)
+	      (cons (car parameter-entry)
+		    (sort (cdr parameter-entry)	;slot entries
+			  #'symbol-or-cons-lessp
+			  :key #'car)))
+	  slots))
 
-(defun user-instance-p (x)
-  (declare (ignore x))
-  NIL)
+(defun sort-calls (calls)
+  (sort calls #'symbol-or-cons-lessp :key #'car))
+
+
+;;;
+;;; 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 use this stuff too.
 
-(defun user-instance-wrapper (x)
-  (declare (ignore x))
-  (error "No user-instance-wrapper function defined for user instances."))
+(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
+		      &body body)
+  (with-gathering ((slot-vars (collecting))
+		   (pv-parameters (collecting)))
+    (iterate ((slots (list-elements slot-name-lists))
+	      (required-parameter (list-elements required-parameters))
+	      (i (interval :from 0)))
+      (when slots
+	(gather required-parameter pv-parameters)
+	(gather (slot-vector-symbol i) slot-vars)))
+    `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
+       ,@body)))
 
-(defun set-user-instance-wrapper (x nv)
-  (declare (ignore x nv))
-  (error "No set-user-instance-wrapper function defined for user instances."))
+(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) 
+		       &body body)
+  `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+     (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+	       slot-vars pv-parameters))
+	,@body)))
 
-(defun user-instance-slots (x)
-  (declare (ignore x))
-  (error "No user-instance-slots function defined for user instances."))
+;This gets used only when the default make-method-lambda is overriden.
+(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
+		  &rest forms)
+  `(let* ((.pv-table. ,pv-table-symbol)
+	  (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
+	  (,pv (car .pv-cell.))
+	  (,calls (cdr .pv-cell.)))
+     (declare ,(make-pv-type-declaration pv))
+     (declare ,(make-calls-type-declaration calls))
+     ,@(when (symbolp pv-table-symbol)
+	 `((declare (special ,pv-table-symbol))))
+     ,pv ,calls
+     ,@forms))
 
-(defun set-user-instance-slots (x nv)
-  (declare (ignore x nv))
-  (error "No set-user-instance-slots function defined for user instances."))
+(defun split-declarations (body args)
+  (let* ((must-rebind-args-p nil)
+	 (inner-decls nil) (outer-decls nil) decl)
+    (loop (when (null body) (return nil))
+	  (setq decl (car body))
+	  (unless (and (consp decl)
+		       (eq (car decl) 'declare))
+	    (return nil))
+	  (dolist (form (cdr decl))
+	    (when (consp form)
+	      (case (car form)
+		((optimize method-name method-lambda-list)
+		 (push `(declare ,form) outer-decls))
+		((ignore type class)
+		 (let ((dname (list (pop form))) (inners nil) (outers nil))
+		   (when (member (car dname) '(type class))
+		     (setq dname (append dname (list (pop form)))))
+		   (dolist (var form)
+		     (if (member var args)
+			 (push var outers)
+			 (push var inners)))
+		   (when outers
+		     (push `(declare (,@dname ,@outers)) outer-decls))
+		   (when inners
+		     (push `(declare (,@dname ,@inners)) inner-decls))))
+		(t (setq must-rebind-args-p t)))))
+	  (setq body (cdr body)))
+    (values outer-decls inner-decls must-rebind-args-p body)))
 
-(defsetf user-instance-wrapper set-user-instance-wrapper)
-(defsetf user-instance-slots   set-user-instance-slots)
+(defun make-method-initargs-form-internal (method-lambda initargs env)
+  (declare (ignore env))
+  (let (method-lambda-args lmf lmf-params)
+    (if (not (and (= 3 (length method-lambda))
+		  (= 2 (length (setq method-lambda-args (cadr method-lambda))))
+		  (consp (setq lmf (third method-lambda)))
+		  (eq 'simple-lexical-method-functions (car lmf))
+		  (eq (car method-lambda-args) (cadr (setq lmf-params (cadr lmf))))
+		  (eq (cadr method-lambda-args) (caddr lmf-params))))
+	`(list* :function #',method-lambda
+	        ',initargs)
+	(let* ((lambda-list (car lmf-params))
+	       (nreq 0)(restp nil)(args nil))
+	  (dolist (arg lambda-list)
+	    (when (member arg '(&optional &rest &key))
+	      (setq restp t)(return nil))
+	    (when (eq arg '&aux) (return nil))
+	    (incf nreq)(push arg args))
+	  (setq args (nreverse args))
+	  (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
+	  (make-method-initargs-form-internal1
+	   initargs (cddr lmf) args lmf-params restp)))))
 
-;;; 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.
+(defun make-method-initargs-form-internal1 
+    (initargs body req-args lmf-params restp)
+  (multiple-value-bind (outer-decls inner-decls must-rebind-args-p body)
+      (split-declarations body req-args)
+    (let* ((rest-arg (when restp '.rest-arg.))
+	   (args+rest-arg (if restp (append req-args (list rest-arg)) req-args)))
+      `(list* :fast-function
+	#'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
+	    ,@outer-decls
+	    .pv-cell. .next-method-call.
+	    (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+				&rest forms)
+			 (declare (ignore pv-table-symbol pv-parameters))
+			 `(let ((,pv (car .pv-cell.))
+				(,calls (cdr .pv-cell.)))
+			   (declare ,(make-pv-type-declaration pv)
+			    ,(make-calls-type-declaration calls))
+			   ,pv ,calls
+			   ,@forms)))
+	      (fast-lexical-method-functions 
+	       (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+		 ,@(cdddr lmf-params))
+	       ,@inner-decls
+	       ,@body)))
+	',initargs))))
 
-(defmacro get-user-instance-p (x)
-  `(user-instance-p ,x))
+;use arrays and hash tables and the fngen stuff to make this much better.
+;It doesn't really matter, though, because a function returned by this
+;will get called only when the user explicitly funcalls a result of method-function. 
+;BUT, this is needed to make early methods work.
+(defun method-function-from-fast-function (fmf)
+  (let* ((method-function nil) (pv-table nil)
+	 (arg-info (method-function-get fmf ':arg-info))
+	 (nreq (car arg-info))
+	 (restp (cdr arg-info)))
+    (setq method-function
+	  #'(lambda (method-args next-methods)
+	      (unless pv-table
+		(setq pv-table (method-function-pv-table fmf)))
+	      (let* ((pv-cell (when pv-table
+				(get-method-function-pv-cell 
+				 method-function method-args pv-table)))
+		     (nm (car next-methods))
+		     (nms (cdr next-methods))
+		     (nmc (when nm
+			    (make-method-call :function (if (std-instance-p nm)
+							    (method-function nm)
+							    nm)
+					      :call-method-args (list nms)))))
+		(if restp
+		    (let* ((rest (nthcdr nreq method-args))
+			   (args (ldiff method-args rest)))
+		      (apply fmf pv-cell nmc (nconc args (list rest))))
+		    (apply fmf pv-cell nmc method-args)))))
+    (let* ((fname (method-function-get fmf :name))
+	   (name `(,(or (get (car fname) 'method-sym)
+			(setf (get (car fname) 'method-sym)
+			      (let ((str (symbol-name (car fname))))
+				(if (string= "FAST-" str :end2 5)
+				    (intern (subseq str 5) *the-pcl-package*)
+				    (car fname)))))
+		    ,@(cdr fname))))
+      (set-function-name method-function name))      
+    (setf (method-function-get method-function :fast-function) fmf)
+    method-function))
 
-(defmacro get-user-instance-wrapper (x)
-  `(user-instance-wrapper ,x))
+(defun get-method-function-pv-cell (method-function method-args &optional pv-table)
+  (let ((pv-table (or pv-table (method-function-pv-table method-function))))
+    (when pv-table
+      (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
+	(when pv-wrappers
+	  (pv-table-lookup pv-table pv-wrappers))))))
 
-(defmacro get-user-instance-slots (x)
-  `(user-instance-slots ,x))
+(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
+  (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
 
-(defmacro fast-check-user-wrapper-validity (object)
-  `(fast-check-wrapper-validity ,object get-user-instance-wrapper))
+(defun pv-wrappers-from-pv-args (&rest args)
+  (let* ((nkeys (length args))
+	 (pv-wrappers (make-list nkeys))
+	 w (w-t pv-wrappers))
+    (dolist (arg args)
+      (setq w (cond ((std-instance-p arg)
+		     (std-instance-wrapper arg))
+		    ((fsc-instance-p arg)
+		     (fsc-instance-wrapper arg))
+		    (t
+		     #+new-kcl-wrapper
+		     (built-in-wrapper-of arg)
+		     #-new-kcl-wrapper
+		     (built-in-or-structure-wrapper arg))))
+      (unless (eq 't (wrapper-state w))
+	(setq w (check-wrapper-validity arg)))
+      (setf (car w-t) w))
+      (setq w-t (cdr w-t))
+      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
+      pv-wrappers))
 
-) ;+pcl-user-instances
+(defun pv-wrappers-from-all-args (pv-table args)
+  (let ((nkeys 0)
+	(slot-name-lists (pv-table-slot-name-lists pv-table)))
+    (dolist (sn slot-name-lists)
+      (when sn (incf nkeys)))
+    (let* ((pv-wrappers (make-list nkeys))
+	   (pv-w-t pv-wrappers))
+      (dolist (sn slot-name-lists)
+	(when sn
+	  (let* ((arg (car args))
+		 (w (wrapper-of arg)))
+	    (unless w ; can-optimize-access prevents this from happening.
+	      (error "error in pv-wrappers-from-all-args"))
+	    (setf (car pv-w-t) w)
+	    (setq pv-w-t (cdr pv-w-t))))
+	(setq args (cdr args)))
+      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
+      pv-wrappers)))
 
+(defun pv-wrappers-from-all-wrappers (pv-table wrappers)
+  (let ((nkeys 0)
+	(slot-name-lists (pv-table-slot-name-lists pv-table)))
+    (dolist (sn slot-name-lists)
+      (when sn (incf nkeys)))
+    (let* ((pv-wrappers (make-list nkeys))
+	   (pv-w-t pv-wrappers))
+      (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)
+	    (setq pv-w-t (cdr pv-w-t))))
+	(setq wrappers (cdr wrappers)))
+      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
+      pv-wrappers)))
diff --git a/pcl/walk.lisp b/pcl/walk.lisp
index 6d26a482a..be759ab63 100644
--- a/pcl/walk.lisp
+++ b/pcl/walk.lisp
@@ -62,12 +62,14 @@
 ;;; 
 (export '(define-walker-template
 	  walk-form
+	  walk-form-expand-macros-p
 	  nested-walk-form
 	  variable-lexical-p
 	  variable-special-p
 	  variable-globally-special-p
 	  *variable-declarations*
 	  variable-declaration
+	  macroexpand-all
 	  ))
 
 
@@ -204,21 +206,24 @@
      ,@body))
 
 (defun with-augmented-environment-internal (env functions macros)
-  (dolist (f functions)
-    (push (list* f 'function #'unbound-lexical-function) env))
-  (dolist (m macros)
-    (push (list* (car m) 'excl::macro (cadr m)) env))
-  env)
+  (let (#+allegro-v4.1 (env-tail (cdr env)) #+allegro-v4.1 (env (car env)))
+    (dolist (f functions)
+      (push (list* f 'function #'unbound-lexical-function) env))
+    (dolist (m macros)
+      (push (list* (car m) 'excl::macro (cadr m)) env))
+    #-allegro-v4.1 env #+allegro-v4.1 (cons env env-tail)))
 
 (defun environment-function (env fn)
-  (let ((entry (assoc fn env :test #'equal)))
+  (let* (#+allegro-v4.1 (env (car env))
+	 (entry (assoc fn env :test #'equal)))
     (and entry
 	 (or (eq (cadr entry) 'function)
 	     (eq (cadr entry) 'compiler::function-value))
 	 (cddr entry))))
 
 (defun environment-macro (env macro)
-  (let ((entry (assoc macro env :test #'equal)))
+  (let* (#+allegro-v4.1 (env (car env))
+	 (entry (assoc macro env :test #'equal)))
     (and entry
 	 (eq (cadr entry) 'excl::macro)
 	 (cddr entry))))
@@ -858,15 +863,17 @@
   ;; we have no idea what to use for the environment.  So we just blow it
   ;; off, 'cause anything real we do would be wrong.  We still have to
   ;; make an entry so we can tell functions from macros.
-  (c::make-lexenv :default (or env (c::make-null-environment))
-		  :functions
-		  (append (mapcar #'(lambda (f)
-				      (cons (car f) (c::make-functional)))
-				  functions)
-			  (mapcar #'(lambda (m)
-				      (list* (car m) 'c::macro
-					     (coerce (cadr m) 'function)))
-				  macros))))
+  (let ((env (or env (c::make-null-environment))))
+    (c::make-lexenv 
+      :default env
+      :functions
+      (append (mapcar #'(lambda (f)
+			  (cons (car f) (c::make-functional :lexenv env)))
+		      functions)
+	      (mapcar #'(lambda (m)
+			  (list* (car m) 'c::macro
+				 (coerce (cadr m) 'function)))
+		      macros)))))
 
 (defun environment-function (env fn)
   (when env
@@ -986,11 +993,11 @@
       entry)))
 
 
-(defvar *VARIABLE-DECLARATIONS* (list 'special))
+(defvar *VARIABLE-DECLARATIONS* '(special))
 
 (defun VARIABLE-DECLARATION (declaration var env)
   (if (not (member declaration *variable-declarations*))
-      (error "~S is not a reckognized variable declaration." declaration)
+      (error "~S is not a recognized variable declaration." declaration)
       (let ((id (or (variable-lexical-p var env) var)))
 	(dolist (decl (env-declarations env))
 	  (when (and (eq (car decl) declaration)
@@ -1143,6 +1150,7 @@
 (define-walker-template LAMBDA               walk-lambda)
 (define-walker-template LET                  walk-let)
 (define-walker-template LET*                 walk-let*)
+(define-walker-template LOCALLY              walk-locally)
 (define-walker-template MACROLET             walk-macrolet)
 (define-walker-template MULTIPLE-VALUE-CALL  (NIL EVAL REPEAT (EVAL)))
 (define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
@@ -1156,6 +1164,7 @@
 (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)))
 
@@ -1203,6 +1212,12 @@
 
 
 
+(defvar walk-form-expand-macros-p nil)
+
+(defun macroexpand-all (form &optional environment)
+  (let ((walk-form-expand-macros-p t))
+    (walk-form form environment)))
+
 (defun WALK-FORM (form
 		  &optional environment
 			    (walk-function
@@ -1295,8 +1310,6 @@
 ;;;     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
@@ -1363,7 +1376,7 @@
         ((LAMBDA CALL)
 	 (cond ((or (symbolp form)
 		    (and (listp form)
-			 (= (length (the list form)) 2)
+			 (= (length form) 2)
 			 (eq (car form) 'setf)))
 		form)
 	       #+Lispm
@@ -1378,10 +1391,9 @@
 				       ;; call to length.
 				       (if (null (cddr template))
 					   ()
-					   (nthcdr (- (length (the list form))
+					   (nthcdr (- (length form)
 						      (length
-							(the list
-                                                             (cddr template))))
+							(cddr template)))
 						   form))
                                        context
 				       env))
@@ -1526,7 +1538,7 @@
 					 &aux arg)
   (cond ((null arglist) ())
         ((symbolp (setq arg (car arglist)))
-         (or (member arg lambda-list-keywords :test #'eq)
+         (or (member arg lambda-list-keywords)
              (note-lexical-binding arg env))
          (recons arglist
                  arg
@@ -1535,26 +1547,24 @@
 			       env
                                (and destructuringp
 				    (not (member arg
-						 lambda-list-keywords
-                                                 :test #'eq))))))
+						 lambda-list-keywords))))))
         ((consp arg)
-         (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))))
+         (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))
@@ -1590,6 +1600,15 @@
       (relist*
 	form let/let* walked-bindings walked-body))))
 
+(defun walk-locally (form context env)
+  (declare (ignore context))
+  (let* ((locally (car form))
+	 (body (cdr form))
+	 (walked-body
+	  (walk-declarations body #'walk-repeat-eval env)))
+    (relist*
+     form locally walked-body)))
+
 (defun walk-prog/prog* (form context old-env sequentialp)
   (walker-environment-bind (new-env old-env)
     (let* ((possible-block-name (second form))
@@ -1656,18 +1675,11 @@
     (if (some #'(lambda (var)
 		  (variable-symbol-macro-p var env))
 	      vars)
-	(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))))
+	(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))
 	       (walked (walk-form-internal expanded context env)))
 	  (if (eq walked expanded)
 	      form
@@ -1767,13 +1779,11 @@
 
 (defun walk-setq (form context env)
   (if (cdddr form)
-      (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))))))
+      (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)))))
 	     (walked (walk-repeat-eval expanded env)))
 	(if (eq expanded walked)
 	    form
@@ -1904,7 +1914,7 @@
                        Even if this is what~%~
                        you intended, you should fix your source code."
 		      form
-		      (length (the list (cdr form))))
+		      (length (cdr form)))
 		(cons 'progn (cdddr form)))
 	      (cadddr form))))
     (relist form
-- 
GitLab