X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fvector.lisp;h=e6bfa4b28a9288be43a7d5ca5ab7efacb670c449;hb=c41cb4c87eae7b04f844dca5f7edb5086c5d2d68;hp=9ad92722cbca18ef127f4fa276a5d66052c29ecf;hpb=42f11f1ddfa083cb62921c77e391441fdd11f3ae;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 9ad9272..e6bfa4b 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)
@@ -1014,8 +1013,8 @@
 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
 (defun body-method-name (body)
   (multiple-value-bind (real-body declarations documentation)
-      (parse-body body nil)
-    (declare (ignore documentation real-body))
+      (parse-body body)
+    (declare (ignore real-body documentation))
     (let ((name-decl (get-declaration '%method-name declarations)))
       (and name-decl
 	   (destructuring-bind (name) name-decl
@@ -1076,8 +1075,9 @@
 			      req-args)))
       `(list*
 	:fast-function
-	(named-lambda
-	 ,(or (body-method-name body) '.method.) ; function name
+	(,(if (body-method-name body) 'named-lambda 'lambda)
+	 ,@(when (body-method-name body)
+	     (list (body-method-name body))) ; function name
 	 (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
 	 ;; body of the function
 	 (declare (ignorable .pv-cell. .next-method-call.))
@@ -1155,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)))))