0.7.10.31:

[sbcl.git] / src / pcl / vector.lisp

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 5f240ba..292e763 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -36,10 +36,10 @@
 (defun pv-cache-limit-fn (nlines)
   (default-limit-fn nlines))
 
 (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)))
+(defstruct (pv-table (:predicate pv-tablep)
+                    (:constructor make-pv-table-internal
+                                  (slot-name-lists call-list))
+                    (:copier nil))

   (cache nil :type (or cache null))
   (pv-size 0 :type fixnum)
   (slot-name-lists nil :type list)
   (cache nil :type (or cache null))
   (pv-size 0 :type fixnum)
   (slot-name-lists nil :type list)

@@ -63,7 +63,7 @@
 (defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
 (defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
 
 (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)
+;;; 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)
 (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
 
 (defun intern-pv-table (&key slot-name-lists call-list)

@@ -160,18 +160,23 @@
   (unless (listp wrappers) (setq wrappers (list wrappers)))
   (let* ((not-simple-p-cell (list nil))
         (elements
   (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)))
+          (let ((elements nil))
+            (dolist (slot-names slot-name-lists)

              (when slot-names
                (let* ((wrapper     (pop wrappers))
                       (std-p (typep wrapper 'wrapper))
                       (class       (wrapper-class* wrapper))
                       (class-slots (and std-p (wrapper-class-slots wrapper))))
                  (dolist (slot-name (cdr slot-names))
              (when slot-names
                (let* ((wrapper     (pop wrappers))
                       (std-p (typep wrapper 'wrapper))
                       (class       (wrapper-class* wrapper))
                       (class-slots (and std-p (wrapper-class-slots wrapper))))
                  (dolist (slot-name (cdr slot-names))

-                   (gather1
-                    (when std-p
-                      (compute-pv-slot slot-name wrapper class
-                                       class-slots not-simple-p-cell))))))))))
+                    ;; Original PCL code had this idiom.  why not:
+                    ;;
+                    ;; (WHEN STD-P
+                    ;;   (PUSH ...)) ?
+                    (push (when std-p
+                            (compute-pv-slot slot-name wrapper class
+                                             class-slots not-simple-p-cell))
+                          elements)))))
+            (nreverse elements))))

     (if (car not-simple-p-cell)
        (make-permutation-vector (cons t elements))
        (or (gethash elements *pvs*)
     (if (car not-simple-p-cell)
        (make-permutation-vector (cons t elements))
        (or (gethash elements *pvs*)

@@ -182,8 +187,8 @@
   (declare (ignore call-list wrappers))
   #||
   (map 'vector
   (declare (ignore call-list wrappers))
   #||
   (map 'vector

-       #'(lambda (call)
-          (compute-emf-from-wrappers call wrappers))
+       (lambda (call)
+        (compute-emf-from-wrappers call wrappers))

        call-list)
   ||#
   '#())
        call-list)
   ||#
   '#())

@@ -194,18 +199,18 @@
     (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.
     (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))))))))
+         (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)
 ||#
 
 (defun make-permutation-vector (indexes)

@@ -250,9 +255,6 @@
 
 (defvar *pv-table-cache-update-info* nil)
 
 
 (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))
 (defun update-pv-table-cache-info (class)
   (let ((slot-names-for-pv-table-update nil)
        (new-icui nil))

@@ -269,26 +271,26 @@
         (std-p (typep cwrapper 'wrapper))
         (class-slots (and std-p (wrapper-class-slots cwrapper)))
         (class-slot-p-cell (list nil))
         (std-p (typep cwrapper 'wrapper))
         (class-slots (and std-p (wrapper-class-slots cwrapper)))
         (class-slot-p-cell (list nil))

-        (new-values (mapcar #'(lambda (slot-name)
-                                (cons slot-name
-                                      (when std-p
-                                        (compute-pv-slot
-                                         slot-name cwrapper class
-                                         class-slots class-slot-p-cell))))
+        (new-values (mapcar (lambda (slot-name)
+                              (cons slot-name
+                                    (when std-p
+                                      (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
                             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))))
+       (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 :initial-element nil)))
     (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 :initial-element nil)))

-       (let ((map-index 1)(param-index 0))
+       (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)))
          (dolist (slot-name-list slot-name-lists)
            (dolist (slot-name (cdr slot-name-list))
              (let ((a (assoc slot-name new-values)))

@@ -297,10 +299,10 @@
              (incf map-index))
            (incf param-index)))
        (when cache
              (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)))
+         (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)
                     cache))))))
 
 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)

@@ -361,34 +363,24 @@
                     (optimize-writer slots parameter gf-name form)))))
       (unless (and (consp (cadr form))
                   (eq 'instance-accessor-parameter (caadr form)))
                     (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))))))))))))))
+       (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
 
 (defun optimize-generic-function-call (form
                                       required-parameters

@@ -396,26 +388,7 @@
                                       slots
                                       calls)
   (declare (ignore required-parameters env slots calls))
                                       slots
                                       calls)
   (declare (ignore required-parameters env slots calls))

-  (or (and (eq (car form) 'make-instance)
-          (expand-make-instance-form form))
-      #||
-      (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))))
-      ||#
+  (or ; (optimize-reader ...)?

       form))
 \f
 (defun can-optimize-access (form required-parameters env)
       form))
 \f
 (defun can-optimize-access (form required-parameters env)

@@ -427,39 +400,37 @@
        (slot-name (eval (caddr form)))) ; known to be constant
     (can-optimize-access1 var required-parameters env type slot-name)))
 
        (slot-name (eval (caddr form)))) ; known to be constant
     (can-optimize-access1 var required-parameters env type slot-name)))
 

-;;; FIXME: This looks like an internal helper function for CAN-OPTIMIZE-ACCESS,
-;;; and it is used that way, but
-;;; it's also called bare from several places in the code. Perhaps
-;;; the two functions should be renamed fo CAN-OPTIMIZE-ACCESS-FOR-FORM
-;;; and CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
+;;; FIXME: This looks like an internal helper function for
+;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
+;;; bare from several places in the code. Perhaps the two functions
+;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
+;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword

 ;;; args instead of optional ones, too.
 (defun can-optimize-access1 (var required-parameters env
                             &optional type slot-name)
   (when (and (consp var) (eq 'the (car var)))
 ;;; args instead of optional ones, too.
 (defun can-optimize-access1 (var required-parameters env
                             &optional type slot-name)
   (when (and (consp var) (eq 'the (car var)))

-    ;; FIXME: We should assert list of length 3 here. Or maybe we should just
-    ;; define EXTRACT-THE, replace the whole
+    ;; FIXME: We should assert list of length 3 here. Or maybe we
+    ;; should just define EXTRACT-THE, replace the whole

     ;;   (WHEN ..)
     ;; form with
     ;;   (AWHEN (EXTRACT-THE VAR)
     ;;     (SETF VAR IT))
     ;;   (WHEN ..)
     ;; form with
     ;;   (AWHEN (EXTRACT-THE VAR)
     ;;     (SETF VAR IT))

-    ;; and then use EXTRACT-THE similarly to clean up the other tests against
-    ;; 'THE scattered through the PCL code.
+    ;; and then use EXTRACT-THE similarly to clean up the other tests
+    ;; against 'THE scattered through the PCL code.

     (setq var (caddr var)))
   (when (symbolp var)
     (setq var (caddr var)))
   (when (symbolp var)

-    (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
-                                                 var
-                                                 env)))
+    (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))

           (parameter-or-nil (car (memq (or rebound? var)
                                        required-parameters))))
       (when parameter-or-nil
           (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)))
+       (let* ((class-name (caddr (var-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))
               (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 (and class-name (not (eq class-name t)))

            (when (or (null type)
                      (not (and class
                                (memq *the-class-structure-object*
            (when (or (null type)
                      (not (and class
                                (memq *the-class-structure-object*

@@ -490,19 +461,21 @@
 (defun optimize-slot-boundp (slots sparameter form)
   (if sparameter
       (destructuring-bind
 (defun optimize-slot-boundp (slots sparameter form)
   (if sparameter
       (destructuring-bind

-         ;; FIXME: In CMU CL ca. 19991205, this binding list had a fourth
-         ;; element in it, NEW-VALUE. It's hard to see how that could possibly
-         ;; be right, since SLOT-BOUNDP has no NEW-VALUE. Since it was causing
-         ;; a failure in building PCL for SBCL, so I changed it to match the
-         ;; definition of SLOT-BOUNDP (and also to match the list used in the
-         ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded out by
-         ;; this, since this is old code which has worked for ages to build
-         ;; PCL for CMU CL, so it's hard to see why it should need a patch
-         ;; like this in order to build PCL for SBCL. I'd like to return to
-         ;; this and find a test case which exercises this function both in
-         ;; CMU CL, to see whether it's really a previously-unexercised bug or
-         ;; whether I've misunderstood something (and, presumably, patched it
-         ;; wrong).
+         ;; FIXME: In CMU CL ca. 19991205, this binding list had a
+         ;; fourth element in it, NEW-VALUE. It's hard to see how
+         ;; that could possibly be right, since SLOT-BOUNDP has no
+         ;; NEW-VALUE. Since it was causing a failure in building PCL
+         ;; for SBCL, so I changed it to match the definition of
+         ;; SLOT-BOUNDP (and also to match the list used in the
+         ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded
+         ;; out by this, since this is old code which has worked for
+         ;; ages to build PCL for CMU CL, so it's hard to see why it
+         ;; should need a patch like this in order to build PCL for
+         ;; SBCL. I'd like to return to this and find a test case
+         ;; which exercises this function both in CMU CL, to see
+         ;; whether it's really a previously-unexercised bug or
+         ;; whether I've misunderstood something (and, presumably,
+         ;; patched it wrong).

          (slot-boundp-symbol instance slot-name-form)
          form
        (declare (ignore slot-boundp-symbol instance))
          (slot-boundp-symbol instance slot-name-form)
          form
        (declare (ignore slot-boundp-symbol instance))

@@ -526,10 +499,10 @@
        (optimize-accessor-call slots :write sparameter gf-name 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.
+;;; 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
 (defun optimize-instance-access (slots
                                 read/write
                                 sparameter

@@ -549,13 +522,13 @@
                     ,parameter)
                    ,new-value))
            (:boundp
                     ,parameter)
                    ,new-value))
            (:boundp

-            'T)))
+            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
        (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"))
+           (bug "slot optimization bewilderment: O-I-A"))

          (unless slot-entry
            (setq slot-entry (list slot-name))
            (push slot-entry (cdr parameter-entry)))
          (unless slot-entry
            (setq slot-entry (list slot-name))
            (push slot-entry (cdr parameter-entry)))

@@ -583,7 +556,7 @@
         (position (posq parameter-entry slots))
         (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
     (unless parameter-entry
         (position (posq parameter-entry slots))
         (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
     (unless parameter-entry

-      (error "internal error in slot optimization"))
+      (error "slot optimization bewilderment: O-A-C"))

     (unless slot-entry
       (setq slot-entry (list name))
       (push slot-entry (cdr parameter-entry)))
     (unless slot-entry
       (setq slot-entry (list name))
       (push slot-entry (cdr parameter-entry)))

@@ -603,13 +576,15 @@
             (eq (car form) 'the))
     (setq form (caddr form)))
   (or (and (symbolp form)
             (eq (car form) 'the))
     (setq form (caddr form)))
   (or (and (symbolp form)

-          (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
-                                                        form env)))
+          (let* ((rebound? (caddr (var-declaration '%variable-rebinding
+                                                   form
+                                                   env)))

                  (parameter-or-nil (car (assq (or rebound? form) slots))))
             (when parameter-or-nil
                  (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)))
+              (let* ((class-name (caddr (var-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)))
                   (position parameter-or-nil slots :key #'car))))))
       (if (constantp form)
          (let ((form (eval form)))

@@ -619,14 +594,14 @@
          *unspecific-arg*)))
 
 (defun optimize-gf-call (slots calls gf-call-form nreq restp env)
          *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
+  (unless (eq (car gf-call-form) 'make-instance) ; XXX 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
     (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))
+                           (mapcar (lambda (form)
+                                     (optimize-gf-call-internal form slots env))

                                    (if all-args-p
                                        args
                                        required-args))))
                                    (if all-args-p
                                        args
                                        required-args))))

@@ -653,8 +628,8 @@
 (define-walker-template instance-accessor-parameter)
 (defmacro instance-accessor-parameter (x) x)
 
 (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.
+;;; It is safe for these two functions to be wrong. They just try to
+;;; guess what the most likely case will be.

 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
   (let ((class (and (constantp class-form) (eval class-form)))
        (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
   (let ((class (and (constantp class-form) (eval class-form)))
        (slot-name (and (constantp slot-name-form) (eval slot-name-form))))

@@ -662,7 +637,7 @@
         (standard-class-p class)
         (not (eq class *the-class-t*)) ; shouldn't happen, though.
         (let ((slotd (find-slot-definition class slot-name)))
         (standard-class-p class)
         (not (eq class *the-class-t*)) ; shouldn't happen, though.
         (let ((slotd (find-slot-definition class slot-name)))

-          (and slotd (classp (slot-definition-allocation slotd)))))))
+          (and slotd (eq :class (slot-definition-allocation slotd)))))))

 
 (defun skip-fast-slot-access-p (class-form slot-name-form type)
   (let ((class (and (constantp class-form) (eval class-form)))
 
 (defun skip-fast-slot-access-p (class-form slot-name-form type)
   (let ((class (and (constantp class-form) (eval class-form)))

@@ -671,7 +646,9 @@
         (standard-class-p class)
         (not (eq class *the-class-t*)) ; shouldn't happen, though.
         (let ((slotd (find-slot-definition class slot-name)))
         (standard-class-p class)
         (not (eq class *the-class-t*)) ; shouldn't happen, though.
         (let ((slotd (find-slot-definition class slot-name)))

-          (and slotd (skip-optimize-slot-value-by-class-p class slot-name type))))))
+          (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)))
 
 (defun skip-optimize-slot-value-by-class-p (class slot-name type)
   (let ((slotd (find-slot-definition class slot-name)))

@@ -682,16 +659,16 @@
 (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))
 (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)
+  (if (eq type :default)

       default
       (let* ((index (gensym))
             (value index))
        `(locally (declare #.*optimize-speed*)
          (let ((,index (pvref ,pv ,pv-offset)))
            (setq ,value (typecase ,index
       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))
+                          ,@(when (or (null type) (eq type :instance))
+                              `((fixnum (clos-slots-ref ,slots ,index))))
+                          ,@(when (or (null type) (eq type :class))

                               `((cons (cdr ,index))))
                           (t +slot-unbound+)))
            (if (eq ,value +slot-unbound+)
                               `((cons (cdr ,index))))
                           (t +slot-unbound+)))
            (if (eq ,value +slot-unbound+)

@@ -704,7 +681,7 @@
       `(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)
       `(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))))
+            :class :instance))))

 
 (defmacro instance-reader (pv-offset parameter position gf-name class)
   (declare (ignore class))
 
 (defmacro instance-reader (pv-offset parameter position gf-name class)
   (declare (ignore class))

@@ -717,15 +694,16 @@
                                      &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
                                      &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-write-internal type))

-  (if (eq type ':default)
+  (if (eq type :default)

       default
       (let* ((index (gensym)))
        `(locally (declare #.*optimize-speed*)
          (let ((,index (pvref ,pv ,pv-offset)))
            (typecase ,index
       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))
+             ,@(when (or (null type) (eq type :instance))
+                      `((fixnum (setf (clos-slots-ref ,slots ,index)
+                                     ,new-value))))
+             ,@(when (or (null type) (eq type :class))

                  `((cons (setf (cdr ,index) ,new-value))))
              (t ,default)))))))
 
                  `((cons (setf (cdr ,index) ,new-value))))
              (t ,default)))))))
 

@@ -741,7 +719,7 @@
        ,pv-offset ,new-value
        (accessor-set-slot-value ,parameter ,slot-name ,new-value)
        ,(if (generate-fast-class-slot-access-p class slot-name)
        ,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))))
+            :class :instance))))

 
 (defmacro instance-writer (pv-offset
                           parameter
 
 (defmacro instance-writer (pv-offset
                           parameter

@@ -753,7 +731,7 @@
   `(instance-write-internal .pv. ,(slot-vector-symbol position)
     ,pv-offset ,new-value
     (,(if (consp gf-name)
   `(instance-write-internal .pv. ,(slot-vector-symbol position)
     ,pv-offset ,new-value
     (,(if (consp gf-name)

-         (get-setf-function-name gf-name)
+         (get-setf-fun-name gf-name)

          gf-name)
      (instance-accessor-parameter ,parameter)
      ,new-value)
          gf-name)
      (instance-accessor-parameter ,parameter)
      ,new-value)

@@ -763,16 +741,17 @@
                                       &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
                                       &optional type)
   (unless (member type '(nil :instance :class :default))
     (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))

-  (if (eq type ':default)
+  (if (eq type :default)

       default
       (let* ((index (gensym)))
        `(locally (declare #.*optimize-speed*)
          (let ((,index (pvref ,pv ,pv-offset)))
            (typecase ,index
       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))
+             ,@(when (or (null type) (eq type :instance))
+                 `((fixnum (not (and ,slots
+                                      (eq (clos-slots-ref ,slots ,index)
+                                          +slot-unbound+))))))
+             ,@(when (or (null type) (eq type :class))

                  `((cons (not (eq (cdr ,index) +slot-unbound+)))))
              (t ,default)))))))
 
                  `((cons (not (eq (cdr ,index) +slot-unbound+)))))
              (t ,default)))))))
 

@@ -782,27 +761,29 @@
       `(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)
       `(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))))
+            :class :instance))))

 
 ;;; This magic function has quite a job to do indeed.
 ;;;
 
 ;;; 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.
+;;; 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.
+;;; 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.
+;;; 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
 (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))))
+           (mapcar (lambda (parameter-entry)
+                     (cons nil (mapcar #'car (cdr parameter-entry))))

                    slots))
           (call-list
            (mapcar #'car calls)))
                    slots))
           (call-list
            (mapcar #'car calls)))

@@ -810,22 +791,22 @@
        (dolist (arg (cdr call))
          (when (integerp arg)
            (setf (car (nth arg slot-name-lists)) t))))
        (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))
+      (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))
                                    slot-name-lists))
       (let ((cvt (apply #'vector
                        (let ((i -1))

-                         (mapcar #'(lambda (r+snl)
-                                     (when r+snl (incf i)))
+                         (mapcar (lambda (r+snl)
+                                   (when r+snl (incf i)))

                                  slot-name-lists)))))
                                  slot-name-lists)))))

-       (setq call-list (mapcar #'(lambda (call)
-                                   (cons (car call)
-                                         (mapcar #'(lambda (arg)
-                                                     (if (integerp arg)
-                                                         (svref cvt arg)
-                                                         arg))
-                                                 (cdr call))))
+       (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))))
 
                                call-list)))
       (values slot-name-lists call-list))))
 

@@ -880,41 +861,43 @@
                        (symbol-or-cons-lessp (car a) (car b))))))))
 
 (defun sort-slots (slots)
                        (symbol-or-cons-lessp (car a) (car b))))))))
 
 (defun sort-slots (slots)

-  (mapcar #'(lambda (parameter-entry)
-             (cons (car parameter-entry)
-                   (sort (cdr parameter-entry) ;slot entries
-                         #'symbol-or-cons-lessp
-                         :key #'car)))
+  (mapcar (lambda (parameter-entry)
+           (cons (car parameter-entry)
+                 (sort (cdr parameter-entry)   ;slot entries
+                       #'symbol-or-cons-lessp
+                       :key #'car)))

          slots))
 
 (defun sort-calls (calls)
   (sort calls #'symbol-or-cons-lessp :key #'car))
 \f
          slots))
 
 (defun sort-calls (calls)
   (sort calls #'symbol-or-cons-lessp :key #'car))
 \f

-;;; 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.
+;;;; 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.

 
 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
                      &body body)
 
 (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)
+  (let (slot-vars pv-parameters)
+    (loop for slots in slot-name-lists
+          for required-parameter in required-parameters
+          for i from 0
+          do (when slots
+               (push required-parameter pv-parameters)
+               (push (slot-vector-symbol i) slot-vars)))
+    `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+                   ,(nreverse pv-parameters) ,(nreverse slot-vars))

        ,@body)))
 
 (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
                       &body body)
   `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
        ,@body)))
 
 (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))
+     (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+                    slot-vars pv-parameters))

        ,@body)))
 
        ,@body)))
 

-;This gets used only when the default make-method-lambda is overriden.
+;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; overridden.

 (defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
                  &rest forms)
   `(let* ((.pv-table. ,pv-table-symbol)
 (defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
                  &rest forms)
   `(let* ((.pv-table. ,pv-table-symbol)

@@ -928,19 +911,31 @@
      ,pv ,calls
      ,@forms))
 
      ,pv ,calls
      ,@forms))
 

-(defvar *non-variable-declarations*
-  ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but
-  ;; I don't *think* CMU CL had, or SBCL has, VALUES declarations. If
-  ;; SBCL doesn't have 'em, VALUES should probably be removed from this list.
-  '(values method-name method-lambda-list
-    optimize ftype inline notinline))
-
-(defvar *variable-declarations-with-argument*
-  '(class
+(defvar *non-var-declarations*
+  ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
+  ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
+  ;; SBCL doesn't have 'em, VALUES should probably be removed from
+  ;; this list.
+  '(values
+    %method-name
+    %method-lambda-list
+    optimize
+    ftype
+    inline
+    notinline))
+
+(defvar *var-declarations-with-arg*
+  '(%class

     type))
 
     type))
 

-(defvar *variable-declarations-without-argument*
-  '(ignore ignorable special dynamic-extent
+(defvar *var-declarations-without-arg*
+  '(ignore
+    ignorable special dynamic-extent
+    ;; FIXME: Possibly this entire list and variable could go away.
+    ;; If not, certainly we should remove all these built-in typenames
+    ;; from the list, and replace them with a test for "is it a type
+    ;; name?" (CLTL1 allowed only built-in type names as declarations,
+    ;; but ANSI CL allows any type name as a declaration.)

     array atom base-char bignum bit bit-vector character compiled-function
     complex cons double-float extended-char
     fixnum float function hash-table integer
     array atom base-char bignum bit bit-vector character compiled-function
     complex cons double-float extended-char
     fixnum float function hash-table integer

@@ -950,7 +945,9 @@
     stream string symbol t unsigned-byte vector))
 
 (defun split-declarations (body args calls-next-method-p)
     stream string symbol t unsigned-byte vector))
 
 (defun split-declarations (body args calls-next-method-p)

-  (let ((inner-decls nil) (outer-decls nil) decl)
+  (let ((inner-decls nil)
+       (outer-decls nil)
+       decl)

     (loop (when (null body) (return nil))
          (setq decl (car body))
          (unless (and (consp decl)
     (loop (when (null body) (return nil))
          (setq decl (car body))
          (unless (and (consp decl)

@@ -959,39 +956,45 @@
          (dolist (form (cdr decl))
            (when (consp form)
              (let ((declaration-name (car form)))
          (dolist (form (cdr decl))
            (when (consp form)
              (let ((declaration-name (car form)))

-               (if (member declaration-name *non-variable-declarations*)
+               (if (member declaration-name *non-var-declarations*)

                    (push `(declare ,form) outer-decls)
                    (let ((arg-p
                           (member declaration-name
                    (push `(declare ,form) outer-decls)
                    (let ((arg-p
                           (member declaration-name

-                                  *variable-declarations-with-argument*))
+                                  *var-declarations-with-arg*))

                          (non-arg-p
                           (member declaration-name
                          (non-arg-p
                           (member declaration-name

-                                  *variable-declarations-without-argument*))
+                                  *var-declarations-without-arg*))

                          (dname (list (pop form)))
                          (inners nil) (outers nil))
                      (unless (or arg-p non-arg-p)
                          (dname (list (pop form)))
                          (inners nil) (outers nil))
                      (unless (or arg-p non-arg-p)

-                       ;; FIXME: This warning should probably go away now
-                       ;; that we're not trying to be portable between
-                       ;; different CLTL1 hosts the way PCL was.
+                       ;; FIXME: This warning, and perhaps the
+                       ;; various *VAR-DECLARATIONS-FOO* and/or
+                       ;; *NON-VAR-DECLARATIONS* variables,
+                       ;; could probably go away now that we're not
+                       ;; trying to be portable between different
+                       ;; CLTL1 hosts the way PCL was. (Note that to
+                       ;; do this right, we need to be able to handle
+                       ;; user-defined (DECLAIM (DECLARATION FOO))
+                       ;; stuff.)

                        (warn "The declaration ~S is not understood by ~S.~@
                               Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
                        (Assuming it is a variable declaration without argument)."
                              declaration-name 'split-declarations
                              declaration-name
                        (warn "The declaration ~S is not understood by ~S.~@
                               Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
                        (Assuming it is a variable declaration without argument)."
                              declaration-name 'split-declarations
                              declaration-name

-                             '*non-variable-declarations*
-                             '*variable-declarations-with-argument*
-                             '*variable-declarations-without-argument*)
-                       (push declaration-name
-                             *variable-declarations-without-argument*))
+                             '*non-var-declarations*
+                             '*var-declarations-with-arg*
+                             '*var-declarations-without-arg*)
+                       (push declaration-name *var-declarations-without-arg*))

                      (when arg-p
                        (setq dname (append dname (list (pop form)))))
                      (dolist (var form)
                        (if (member var args)
                      (when arg-p
                        (setq dname (append dname (list (pop form)))))
                      (dolist (var form)
                        (if (member var args)

-                           ;; Quietly remove IGNORE declarations on args when
-                           ;; a next-method is involved, to prevent compiler
-                           ;; warns about ignored args being read.
-                           (unless (and  calls-next-method-p
-                                         (eq (car dname) 'ignore))
+                           ;; Quietly remove IGNORE declarations on
+                           ;; args when a next-method is involved, to
+                           ;; prevent compiler warnings about ignored
+                           ;; args being read.
+                           (unless (and calls-next-method-p
+                                        (eq (car dname) 'ignore))

                                (push var outers))
                            (push var inners)))
                      (when outers
                                (push var outers))
                            (push var inners)))
                      (when outers

@@ -1001,9 +1004,34 @@
          (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 
          (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 

+;;; Pull a name out of the %METHOD-NAME declaration in the function
+;;; body given, or return NIL if no %METHOD-NAME declaration is found.
+(defun body-method-name (body)
+  (multiple-value-bind (real-body declarations documentation)
+      (parse-body body nil)
+    (declare (ignore documentation real-body))
+    (let ((name-decl (get-declaration '%method-name declarations)))
+      (and name-decl
+          (destructuring-bind (name) name-decl
+            name)))))
+
+;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
+;;; declaration (which is a naming style internal to PCL) into an
+;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
+;;; throughout SBCL, understood by the main compiler); or if there's
+;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
+;;; lambda expression.
+(defun name-method-lambda (method-lambda)
+  (let ((method-name (body-method-name (cddr method-lambda))))
+    (if method-name
+       `(named-lambda ,method-name ,(rest method-lambda))
+       method-lambda)))
+

 (defun make-method-initargs-form-internal (method-lambda initargs env)
   (declare (ignore env))
 (defun make-method-initargs-form-internal (method-lambda initargs env)
   (declare (ignore env))

-  (let (method-lambda-args lmf lmf-params)
+  (let (method-lambda-args
+       lmf ; becomes body of function
+       lmf-params)

     (if (not (and (= 3 (length method-lambda))
                  (= 2 (length (setq method-lambda-args (cadr method-lambda))))
                  (consp (setq lmf (third method-lambda)))
     (if (not (and (= 3 (length method-lambda))
                  (= 2 (length (setq method-lambda-args (cadr method-lambda))))
                  (consp (setq lmf (third method-lambda)))

@@ -1012,78 +1040,90 @@
                      (cadr (setq lmf-params (cadr lmf))))
                  (eq (cadr method-lambda-args)
                      (caddr lmf-params))))
                      (cadr (setq lmf-params (cadr lmf))))
                  (eq (cadr method-lambda-args)
                      (caddr lmf-params))))

-       `(list* :function #',method-lambda
+       `(list* :function ,(name-method-lambda method-lambda)

                ',initargs)
        (let* ((lambda-list (car lmf-params))
                ',initargs)
        (let* ((lambda-list (car lmf-params))

-              (nreq 0)(restp nil)(args nil))
+              (nreq 0)
+              (restp nil)
+              (args nil))

          (dolist (arg lambda-list)
            (when (member arg '(&optional &rest &key))
          (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 restp t)
+             (return nil))
+           (when (eq arg '&aux)
+             (return nil))
+           (incf nreq)
+           (push arg args))

          (setq args (nreverse args))
          (setq args (nreverse args))

-         (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
+         (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp))

          (make-method-initargs-form-internal1
           initargs (cddr lmf) args lmf-params restp)))))
 
 (defun make-method-initargs-form-internal1
     (initargs body req-args lmf-params restp)
          (make-method-initargs-form-internal1
           initargs (cddr lmf) args lmf-params restp)))))
 
 (defun make-method-initargs-form-internal1
     (initargs body req-args lmf-params restp)

-  (multiple-value-bind (outer-decls inner-decls body)
+  (multiple-value-bind (outer-decls inner-decls body-sans-decls)

       (split-declarations
        body req-args (getf (cdr lmf-params) :call-next-method-p))
     (let* ((rest-arg (when restp '.rest-arg.))
           (args+rest-arg (if restp
                              (append req-args (list rest-arg))
                              req-args)))
       (split-declarations
        body req-args (getf (cdr lmf-params) :call-next-method-p))
     (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)))
+      `(list*
+       :fast-function
+       (named-lambda
+        ,(or (body-method-name body) '.method.) ; function name
+        (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
+        ;; body of the function
+        (declare (ignorable .pv-cell. .next-method-call.))
+        ,@outer-decls
+        (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-sans-decls)))

        ',initargs))))
 
        ',initargs))))
 

-;;; 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.
+;;; 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)
   (declare (type function fmf))
   (let* ((method-function nil) (pv-table nil)
 (defun method-function-from-fast-function (fmf)
   (declare (type function fmf))
   (let* ((method-function nil) (pv-table nil)

-        (arg-info (method-function-get fmf ':arg-info))
+        (arg-info (method-function-get fmf :arg-info))

         (nreq (car arg-info))
         (restp (cdr arg-info)))
     (setq method-function
         (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)))))
+         (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* ((fname (method-function-get fmf :name))
           (name `(,(or (get (car fname) 'method-sym)
                        (setf (get (car fname) 'method-sym)

@@ -1092,7 +1132,7 @@
                                    (intern (subseq str 5) *pcl-package*)
                                    (car fname)))))
                    ,@(cdr fname))))
                                    (intern (subseq str 5) *pcl-package*)
                                    (car fname)))))
                    ,@(cdr fname))))

-      (set-function-name method-function name))
+      (set-fun-name method-function name))

     (setf (method-function-get method-function :fast-function) fmf)
     method-function))
 
     (setf (method-function-get method-function :fast-function) fmf)
     method-function))
 

@@ -1115,7 +1155,7 @@
         (w-t pv-wrappers))
     (dolist (arg args)
       (setq w (wrapper-of arg))
         (w-t pv-wrappers))
     (dolist (arg args)
       (setq w (wrapper-of arg))

-      (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
+      (when (invalid-wrapper-p w)

        (setq w (check-wrapper-validity arg)))
       (setf (car w-t) w))
       (setq w-t (cdr w-t))
        (setq w (check-wrapper-validity arg)))
       (setf (car w-t) w))
       (setq w-t (cdr w-t))