X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=1a6a52932ee0b859ff98eebc395978c7263e1a70;hb=2dfaffe8bdce30dac9b5baa4d2645d074a176b4f;hp=606acba3abf17ab2ae1117fafc9fc62fd1117a75;hpb=bc2977763a323f3e180dfb227081688cd8d021af;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 606acba..1a6a529 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -81,7 +81,7 @@
       (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
 
 (defun optimize-slot-value-by-class-p (class slot-name type)
-  (or (not (eq *boot-state* 'complete))
+  (or (not (eq **boot-state** 'complete))
       (let ((slotd (find-slot-definition class slot-name)))
         (and slotd
              (slot-accessor-std-p slotd type)))))
@@ -155,7 +155,7 @@
                                                          parameter-or-nil
                                                          env)))
                      (class (find-class class-name nil)))
-                (when (or (not (eq *boot-state* 'complete))
+                (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)))
@@ -255,7 +255,7 @@
                                  new-value &optional safep)
   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
         (parameter (if (consp sparameter) (car sparameter) sparameter)))
-    (if (and (eq *boot-state* 'complete)
+    (if (and (eq **boot-state** 'complete)
              (classp class)
              (memq *the-class-structure-object* (class-precedence-list class)))
         (let ((slotd (find-slot-definition class slot-name)))
@@ -301,7 +301,7 @@
   (let ((class (and (constantp class-form) (constant-form-value class-form)))
         (slot-name (and (constantp slot-name-form)
                         (constant-form-value slot-name-form))))
-    (and (eq *boot-state* 'complete)
+    (and (eq **boot-state** 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
          (let ((slotd (find-slot-definition class slot-name)))
@@ -311,7 +311,7 @@
   (let ((class (and (constantp class-form) (constant-form-value class-form)))
         (slot-name (and (constantp slot-name-form)
                         (constant-form-value slot-name-form))))
-    (and (eq *boot-state* 'complete)
+    (and (eq **boot-state** 'complete)
          (standard-class-p class)
          (not (eq class *the-class-t*)) ; shouldn't happen, though.
          ;; FIXME: Is this really right? "Don't skip if there is
@@ -550,7 +550,7 @@
         (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
-(defun split-declarations (body args maybe-reads-params-p)
+(defun split-declarations (body args req-args cnm-p parameters-setqd)
   (let ((inner-decls nil)
         (outer-decls nil)
         decl)
@@ -579,7 +579,7 @@
                            ;; args when a next-method is involved, to
                            ;; prevent compiler warnings about ignored
                            ;; args being read.
-                           (unless (and (eq 'ignore name) maybe-reads-params-p)
+                           (unless (and (eq 'ignore name) (member var req-args :test #'eq) (or cnm-p (member var parameters-setqd)))
                              (push var outers))
                            (push var inners)))
                      (when outers
@@ -677,7 +677,7 @@
          (outer-parameters req-args)
          ;; The lambda-list used by BIND-ARGS
          (bind-list lambda-list)
-         (setq-p (getf (cdr lmf-params) :setq-p))
+         (parameters-setqd (getf (cdr lmf-params) :parameters-setqd))
          (auxp (member '&aux bind-list))
          (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
     ;; Try to use the normal function call machinery instead of BIND-ARGS
@@ -702,7 +702,7 @@
             bind-list req-args))
     (multiple-value-bind (outer-decls inner-decls body-sans-decls)
         (split-declarations
-         body outer-parameters (or call-next-method-p setq-p))
+         body outer-parameters req-args call-next-method-p parameters-setqd)
       (let* ((rest-arg (when restp
                          '.rest-arg.))
              (fmf-lambda-list (if rest-arg