X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=f4cab13a5a103cb6f4c7e5057f5eb767977049d8;hb=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;hp=292e76333763fa1c20192c7d72af304f9359e545;hpb=1e08b23e730c7a1c9cda1b918e9fdca38b8c4e17;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 292e763..f4cab13 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -232,8 +232,7 @@
 	       (pv-cell (cons pv calls))
 	       (new-cache (fill-cache cache pv-wrappers pv-cell)))
 	  (unless (eq new-cache cache)
-	    (setf (pv-table-cache pv-table) new-cache)
-	    (free-cache cache))
+	    (setf (pv-table-cache pv-table) new-cache))
 	  pv-cell))))
 
 (defun make-pv-type-declaration (var)
@@ -987,20 +986,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)))
 
@@ -1149,52 +1154,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)))))