0.pre7.98:

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

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index b4180e2..c4555b4 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*)

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

@@ -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

@@ -398,24 +390,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)

@@ -427,39 +401,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 +462,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 +500,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,7 +523,7 @@
                     ,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))
        (let* ((parameter-entry (assq parameter slots))
               (slot-entry      (assq slot-name (cdr parameter-entry)))
               (position (posq parameter-entry slots))

@@ -603,13 +577,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,7 +595,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))

@@ -653,8 +629,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))))

@@ -671,7 +647,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)))

@@ -690,11 +668,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))))))
 

@@ -724,7 +702,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)))))))

@@ -753,7 +732,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)

@@ -770,10 +749,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)

@@ -786,18 +766,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

@@ -880,31 +862,32 @@
                        (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)))
 
 (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)

@@ -914,7 +897,8 @@
               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)

@@ -928,19 +912,26 @@
      ,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
+(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))
 
     optimize ftype inline notinline))
 

-(defvar *variable-declarations-with-argument*
-  '(class
+(defvar *var-declarations-with-argument*
+  '(%class

     type))
 
     type))
 

-(defvar *variable-declarations-without-argument*
-  '(ignore ignorable special dynamic-extent
+(defvar *var-declarations-without-argument*
+  '(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 +941,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 +952,46 @@
          (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-argument*))

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

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

                          (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*)
+                             '*non-var-declarations*
+                             '*var-declarations-with-argument*
+                             '*var-declarations-without-argument*)

                        (push declaration-name
                        (push declaration-name

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

                      (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 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

@@ -1036,29 +1036,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)

@@ -1075,10 +1076,11 @@
                     (nm (car next-methods))
                     (nms (cdr next-methods))
                     (nmc (when nm
                     (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)))))
+                           (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)))
                (if restp
                    (let* ((rest (nthcdr nreq method-args))
                           (args (ldiff method-args rest)))

@@ -1092,7 +1094,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 +1117,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
+      (unless (eq t (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P

        (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))