0.7.12.38:

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

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index fdd43e6..26cc570 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -388,8 +388,7 @@
                                       slots
                                       calls)
   (declare (ignore required-parameters env slots calls))
-  (or (and (eq (car form) 'make-instance)
-          (expand-make-instance-form form))
+  (or ; (optimize-reader ...)?
       form))
 \f
 (defun can-optimize-access (form required-parameters env)
@@ -638,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)))
-          (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)))
@@ -988,20 +987,26 @@
                        (push declaration-name *var-declarations-without-arg*))
                      (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 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 `(declare (,@dname ,@outers)) outer-decls))
-                     (when inners
-                       (push `(declare (,@dname ,@inners)) inner-decls)))))))
+                     (case (car dname)
+                       (%class (push `(declare (,@dname ,@form)) inner-decls))
+                       (t
+                        (dolist (var form)
+                          (if (member var args)
+                              ;; 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 `(declare (,@dname ,@outers)) outer-decls))
+                        (when inners
+                          (push
+                           `(declare (,@dname ,@inners))
+                           inner-decls)))))))))
          (setq body (cdr body)))
     (values outer-decls inner-decls body)))
 
@@ -1150,52 +1155,24 @@
   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
 
 (defun pv-wrappers-from-pv-args (&rest args)
-  (let* ((nkeys (length args))
-        (pv-wrappers (make-list nkeys))
-        w
-        (w-t pv-wrappers))
-    (dolist (arg args)
-      (setq w (wrapper-of arg))
-      (when (invalid-wrapper-p w)
-       (setq w (check-wrapper-validity arg)))
-      (setf (car w-t) w))
-      (setq w-t (cdr w-t))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers))
+  (let (wrappers)
+    (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
+      (let ((wrapper (wrapper-of arg)))
+       (push (if (invalid-wrapper-p wrapper)
+                 (check-wrapper-validity wrapper)
+                 wrapper)
+             wrappers)))))
 
 (defun pv-wrappers-from-all-args (pv-table args)
-  (let ((nkeys 0)
-       (slot-name-lists (pv-table-slot-name-lists pv-table)))
-    (dolist (sn slot-name-lists)
-      (when sn (incf nkeys)))
-    (let* ((pv-wrappers (make-list nkeys))
-          (pv-w-t pv-wrappers))
-      (dolist (sn slot-name-lists)
-       (when sn
-         (let* ((arg (car args))
-                (w (wrapper-of arg)))
-           (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
-             (error "error in PV-WRAPPERS-FROM-ALL-ARGS"))
-           (setf (car pv-w-t) w)
-           (setq pv-w-t (cdr pv-w-t))))
-       (setq args (cdr args)))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers)))
+  (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
+        when snl
+          collect (wrapper-of arg) into wrappers
+        finally (return (if (cdr wrappers) wrappers (car wrappers)))))
 
+;;; Return the subset of WRAPPERS which is used in the cache
+;;; of PV-TABLE.
 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
-  (let ((nkeys 0)
-       (slot-name-lists (pv-table-slot-name-lists pv-table)))
-    (dolist (sn slot-name-lists)
-      (when sn (incf nkeys)))
-    (let* ((pv-wrappers (make-list nkeys))
-          (pv-w-t pv-wrappers))
-      (dolist (sn slot-name-lists)
-       (when sn
-         (let ((w (car wrappers)))
-           (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
-             (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS"))
-           (setf (car pv-w-t) w)
-           (setq pv-w-t (cdr pv-w-t))))
-       (setq wrappers (cdr wrappers)))
-      (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
-      pv-wrappers)))
+  (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
+        when snl
+          collect w into result
+        finally (return (if (cdr result) result (car result)))))