1.0.12.31: fix READ-SEQUENCE regression from 1.0.12.22

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 56317d7..bfa56ce 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -617,7 +617,6 @@ bootstrapping.
                         parameters
                         specializers))
                (slots (mapcar #'list required-parameters))
-               (calls (list nil))
                (class-declarations
                 `(declare
                   ;; These declarations seem to be used by PCL to pass
@@ -692,29 +691,24 @@ bootstrapping.
               (walk-method-lambda method-lambda
                                   required-parameters
                                   env
-                                  slots
-                                  calls)
+                                  slots)
             (multiple-value-bind (walked-lambda-body
                                   walked-declarations
                                   walked-documentation)
                 (parse-body (cddr walked-lambda))
               (declare (ignore walked-documentation))
               (when (some #'cdr slots)
-                (multiple-value-bind (slot-name-lists call-list)
-                    (slot-name-lists-from-slots slots calls)
+                (let ((slot-name-lists (slot-name-lists-from-slots slots)))
                   (setq plist
                         `(,@(when slot-name-lists
                                   `(:slot-name-lists ,slot-name-lists))
-                            ,@(when call-list
-                                    `(:call-list ,call-list))
                             ,@plist))
                   (setq walked-lambda-body
                         `((pv-binding (,required-parameters
                                        ,slot-name-lists
                                        (load-time-value
                                         (intern-pv-table
-                                         :slot-name-lists ',slot-name-lists
-                                         :call-list ',call-list)))
+                                         :slot-name-lists ',slot-name-lists)))
                             ,@walked-lambda-body)))))
               (when (and (memq '&key lambda-list)
                          (not (memq '&allow-other-keys lambda-list)))
@@ -1021,7 +1015,7 @@ bootstrapping.
 
 (defstruct (fast-method-call (:copier nil))
   (function #'identity :type function)
-  pv-cell
+  pv
   next-method-call
   arg-info)
 (defstruct (constant-fast-method-call
@@ -1038,7 +1032,7 @@ bootstrapping.
 
 (defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
   `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
-                                (fast-method-call-pv-cell ,method-call)
+                                (fast-method-call-pv ,method-call)
                                 (fast-method-call-next-method-call ,method-call)
                                 ,@required-args+rest-arg))
 
@@ -1048,7 +1042,7 @@ bootstrapping.
                                         &rest required-args)
   (macrolet ((generate-call (n)
                ``(funcall (fast-method-call-function ,method-call)
-                          (fast-method-call-pv-cell ,method-call)
+                          (fast-method-call-pv ,method-call)
                           (fast-method-call-next-method-call ,method-call)
                           ,@required-args
                           ,@(loop for x below ,n
@@ -1062,7 +1056,7 @@ bootstrapping.
        (0 ,(generate-call 0))
        (1 ,(generate-call 1))
        (t (multiple-value-call (fast-method-call-function ,method-call)
-            (values (fast-method-call-pv-cell ,method-call))
+            (values (fast-method-call-pv ,method-call))
             (values (fast-method-call-next-method-call ,method-call))
             ,@required-args
             (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
@@ -1210,7 +1204,7 @@ bootstrapping.
             (nreq (car arg-info)))
        (if restp
            (apply (fast-method-call-function emf)
-                  (fast-method-call-pv-cell emf)
+                  (fast-method-call-pv emf)
                   (fast-method-call-next-method-call emf)
                   args)
            (cond ((null args)
@@ -1233,7 +1227,7 @@ bootstrapping.
                              :format-arguments nil)))
                  (t
                   (apply (fast-method-call-function emf)
-                         (fast-method-call-pv-cell emf)
+                         (fast-method-call-pv emf)
                          (fast-method-call-next-method-call emf)
                          args))))))
     (method-call
@@ -1439,7 +1433,7 @@ bootstrapping.
         when (eq key keyword)
           return tail))
 
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+(defun walk-method-lambda (method-lambda required-parameters env slots)
   (let (;; flag indicating that CALL-NEXT-METHOD should be in the
         ;; method definition
         (call-next-method-p nil)
@@ -1619,11 +1613,10 @@ bootstrapping.
           (set-fun-name mff fast-name))))
     (when plist
       (let ((plist plist))
-        (let ((snl (getf plist :slot-name-lists))
-              (cl (getf plist :call-list)))
-          (when (or snl cl)
+        (let ((snl (getf plist :slot-name-lists)))
+          (when snl
             (setf (method-plist-value method :pv-table)
-                  (intern-pv-table :slot-name-lists snl :call-list cl))))))))
+                  (intern-pv-table :slot-name-lists snl))))))))
 \f
 (defun analyze-lambda-list (lambda-list)
   (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
@@ -2054,6 +2047,7 @@ bootstrapping.
                                                               lambda-list-p)
                                             argument-precedence-order
                                             source-location
+                                            documentation
                                             &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
@@ -2063,7 +2057,8 @@ bootstrapping.
         ((assoc spec *!generic-function-fixups* :test #'equal)
          (if existing
              (make-early-gf spec lambda-list lambda-list-p existing
-                            argument-precedence-order source-location)
+                            argument-precedence-order source-location
+                            documentation)
              (bug "The function ~S is not already defined." spec)))
         (existing
          (bug "~S should be on the list ~S."
@@ -2071,10 +2066,12 @@ bootstrapping.
         (t
          (pushnew spec *!early-generic-functions* :test #'equal)
          (make-early-gf spec lambda-list lambda-list-p nil
-                        argument-precedence-order source-location))))
+                        argument-precedence-order source-location
+                        documentation))))
 
 (defun make-early-gf (spec &optional lambda-list lambda-list-p
-                      function argument-precedence-order source-location)
+                      function argument-precedence-order source-location
+                      documentation)
   (let ((fin (allocate-standard-funcallable-instance
               *sgf-wrapper* *sgf-slots-init*)))
     (set-funcallable-instance-function
@@ -2090,10 +2087,10 @@ bootstrapping.
                          has not been set." fin)))))
     (setf (gdefinition spec) fin)
     (!bootstrap-set-slot 'standard-generic-function fin 'name spec)
-    (!bootstrap-set-slot 'standard-generic-function
-                         fin
-                         'source
-                         source-location)
+    (!bootstrap-set-slot 'standard-generic-function fin
+                         'source source-location)
+    (!bootstrap-set-slot 'standard-generic-function fin
+                         '%documentation documentation)
     (set-fun-name fin spec)
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
@@ -2404,7 +2401,7 @@ bootstrapping.
     (setf (getf (getf initargs 'plist) :name)
           (make-method-spec gf qualifiers specializers))
     (let ((new (make-a-method 'standard-method qualifiers arglist
-                              specializers initargs ())))
+                              specializers initargs (getf initargs :documentation))))
       (when existing (remove-method gf existing))
       (add-method gf new))))