0.6.10.20:

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

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 7b3b4cf..524a854 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -24,9 +24,6 @@
 ;;;; specification.
 
 (in-package "SB-PCL")
 ;;;; specification.
 
 (in-package "SB-PCL")

-
-(sb-int:file-comment
-  "$Header$")

 \f
 (defmacro instance-slot-index (wrapper slot-name)
   `(let ((pos 0))
 \f
 (defmacro instance-slot-index (wrapper slot-name)
   `(let ((pos 0))

@@ -66,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)

@@ -253,9 +250,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))

@@ -364,34 +358,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

@@ -401,24 +385,6 @@
   (declare (ignore required-parameters env slots calls))
   (or (and (eq (car form) 'make-instance)
           (expand-make-instance-form form))
   (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))))
-      ||#

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

@@ -430,32 +396,32 @@
        (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
+    (let* ((rebound? (caddr (variable-declaration '%variable-rebinding

                                                  var
                                                  env)))
           (parameter-or-nil (car (memq (or rebound? var)
                                        required-parameters))))
       (when parameter-or-nil
                                                  var
                                                  env)))
           (parameter-or-nil (car (memq (or rebound? var)
                                        required-parameters))))
       (when parameter-or-nil

-       (let* ((class-name (caddr (variable-declaration 'class
+       (let* ((class-name (caddr (variable-declaration '%class

                                                        parameter-or-nil
                                                        env)))
               (class (find-class class-name nil)))
                                                        parameter-or-nil
                                                        env)))
               (class (find-class class-name nil)))

@@ -493,19 +459,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))

@@ -529,10 +497,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

@@ -606,7 +574,7 @@
             (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
+          (let* ((rebound? (caddr (variable-declaration '%variable-rebinding

                                                         form env)))
                  (parameter-or-nil (car (assq (or rebound? form) slots))))
             (when parameter-or-nil
                                                         form env)))
                  (parameter-or-nil (car (assq (or rebound? form) slots))))
             (when parameter-or-nil

@@ -622,7 +590,7 @@
          *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))
     (let* ((args (cdr gf-call-form))
           (all-args-p (eq (car gf-call-form) 'make-instance))
           (non-required-args (nthcdr nreq args))

@@ -656,8 +624,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))))

@@ -674,7 +642,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)))

@@ -693,11 +663,11 @@
          (let ((,index (pvref ,pv ,pv-offset)))
            (setq ,value (typecase ,index
                           ,@(when (or (null type) (eq type ':instance))
          (let ((,index (pvref ,pv ,pv-offset)))
            (setq ,value (typecase ,index
                           ,@(when (or (null type) (eq type ':instance))

-                              `((fixnum (%instance-ref ,slots ,index))))
+                              `((fixnum (clos-slots-ref ,slots ,index))))

                           ,@(when (or (null type) (eq type ':class))
                               `((cons (cdr ,index))))
                           ,@(when (or (null type) (eq type ':class))
                               `((cons (cdr ,index))))

-                          (t ',*slot-unbound*)))
-           (if (eq ,value ',*slot-unbound*)
+                          (t +slot-unbound+)))
+           (if (eq ,value +slot-unbound+)

                ,default
                ,value))))))
 
                ,default
                ,value))))))
 

@@ -727,7 +697,8 @@
          (let ((,index (pvref ,pv ,pv-offset)))
            (typecase ,index
              ,@(when (or (null type) (eq type ':instance))
          (let ((,index (pvref ,pv ,pv-offset)))
            (typecase ,index
              ,@(when (or (null type) (eq type ':instance))

-                 `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
+                      `((fixnum (setf (clos-slots-ref ,slots ,index)
+                                     ,new-value))))

              ,@(when (or (null type) (eq type ':class))
                  `((cons (setf (cdr ,index) ,new-value))))
              (t ,default)))))))
              ,@(when (or (null type) (eq type ':class))
                  `((cons (setf (cdr ,index) ,new-value))))
              (t ,default)))))))

@@ -773,10 +744,11 @@
          (let ((,index (pvref ,pv ,pv-offset)))
            (typecase ,index
              ,@(when (or (null type) (eq type ':instance))
          (let ((,index (pvref ,pv ,pv-offset)))
            (typecase ,index
              ,@(when (or (null type) (eq type ':instance))

-                 `((fixnum (not (eq (%instance-ref ,slots ,index)
-                                    ',*slot-unbound*)))))
+                 `((fixnum (not (and ,slots
+                                      (eq (clos-slots-ref ,slots ,index)
+                                          +slot-unbound+))))))

              ,@(when (or (null type) (eq type ':class))
              ,@(when (or (null type) (eq type ':class))

-                 `((cons (not (eq (cdr ,index) ',*slot-unbound*)))))
+                 `((cons (not (eq (cdr ,index) +slot-unbound+)))))

              (t ,default)))))))
 
 (defmacro instance-boundp (pv-offset parameter position slot-name class)
              (t ,default)))))))
 
 (defmacro instance-boundp (pv-offset parameter position slot-name class)

@@ -789,18 +761,20 @@
 
 ;;; 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

@@ -883,19 +857,20 @@
                        (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)

@@ -917,7 +892,7 @@
               slot-vars pv-parameters))
        ,@body)))
 
               slot-vars pv-parameters))
        ,@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)

@@ -932,18 +907,25 @@
      ,@forms))
 
 (defvar *non-variable-declarations*
      ,@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
+  ;; 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*
     optimize ftype inline notinline))
 
 (defvar *variable-declarations-with-argument*

-  '(class
+  '(%class

     type))
 
 (defvar *variable-declarations-without-argument*
     type))
 
 (defvar *variable-declarations-without-argument*

-  '(ignore ignorable special dynamic-extent
+  '(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

@@ -953,7 +935,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)

@@ -973,9 +957,15 @@
                          (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 *VARIABLE-DECLARATIONS-FOO* and/or
+                       ;; *NON-VARIABLE-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)."
                        (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)."

@@ -990,11 +980,12 @@
                        (setq dname (append dname (list (pop form)))))
                      (dolist (var form)
                        (if (member var args)
                        (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 warns 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

@@ -1039,29 +1030,30 @@
                              (append req-args (list rest-arg))
                              req-args)))
       `(list* :fast-function
                              (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)))
+       (lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
+         (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)))

        ',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)