X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=995fa6ffdb3f86d1191362363f35134e33b2468c;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=fdd43e6eb4133dab57ee754bef3fd071c8dd8a4b;hpb=24bc431a3403af05c5df601d09c0d0c27cb500b2;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index fdd43e6..995fa6f 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)
@@ -388,8 +387,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))
 
 (defun can-optimize-access (form required-parameters env)
@@ -638,7 +636,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)))
@@ -667,8 +665,21 @@
 	`(locally (declare #.*optimize-speed*)
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (setq ,value (typecase ,index
+			   ;; FIXME: the line marked by KLUDGE below
+			   ;; (and the analogous spot in
+			   ;; INSTANCE-WRITE-INTERNAL) is there purely
+			   ;; to suppress a type mismatch warning that
+			   ;; propagates through to user code.
+			   ;; Presumably SLOTS at this point can never
+			   ;; actually be NIL, but the compiler seems
+			   ;; to think it could, so we put this here
+			   ;; to shut it up.  (see also mail Rudi
+			   ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
+			   ;; 2003-11-30
 			   ,@(when (or (null type) (eq type :instance))
-			       `((fixnum (clos-slots-ref ,slots ,index))))
+			       `((fixnum
+				  (and ,slots ; KLUDGE
+				   (clos-slots-ref ,slots ,index)))))
 			   ,@(when (or (null type) (eq type :class))
 			       `((cons (cdr ,index))))
 			   (t +slot-unbound+)))
@@ -702,8 +713,9 @@
 	  (let ((,index (pvref ,pv ,pv-offset)))
 	    (typecase ,index
 	      ,@(when (or (null type) (eq type :instance))
-                      `((fixnum (setf (clos-slots-ref ,slots ,index)
-				      ,new-value))))
+                  `((fixnum (and ,slots
+			     (setf (clos-slots-ref ,slots ,index)
+				   ,new-value)))))
 	      ,@(when (or (null type) (eq type :class))
 		  `((cons (setf (cdr ,index) ,new-value))))
 	      (t ,default)))))))
@@ -895,7 +907,8 @@
   `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
 		     slot-vars pv-parameters))
-	,@body)))
+       (declare (ignorable ,@(mapcar #'identity slot-vars)))
+       ,@body)))
 
 ;;; This gets used only when the default MAKE-METHOD-LAMBDA is
 ;;; overridden.
@@ -988,20 +1001,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)))
 
@@ -1009,8 +1028,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
@@ -1071,27 +1090,31 @@
 			      req-args)))
       `(list*
 	:fast-function
-	(named-lambda
-	 ,(or (body-method-name body) '.method.) ; function name
-	 (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
-	 ;; body of the function
-	 (declare (ignorable .pv-cell. .next-method-call.))
-	 ,@outer-decls
-	 (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
-			     &rest forms)
-			    (declare (ignore pv-table-symbol
-					     pv-parameters))
-			    `(let ((,pv (car .pv-cell.))
-				   (,calls (cdr .pv-cell.)))
-			       (declare ,(make-pv-type-declaration pv)
-					,(make-calls-type-declaration calls))
-			       ,pv ,calls
-			       ,@forms)))
-	   (fast-lexical-method-functions
-	    (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
-	     ,@(cdddr lmf-params))
-	    ,@inner-decls
-	    ,@body-sans-decls)))
+	(,(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.))
+	  ,@outer-decls
+	  (declare (disable-package-locks pv-env))
+	   (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+			       &rest forms)
+			(declare (ignore pv-table-symbol
+					 pv-parameters))
+			(declare (enable-package-locks pv-env))
+			`(let ((,pv (car .pv-cell.))
+			       (,calls (cdr .pv-cell.)))
+			   (declare ,(make-pv-type-declaration pv)
+				    ,(make-calls-type-declaration calls))
+			   ,pv ,calls
+			   ,@forms)))
+	     (declare (enable-package-locks pv-env))
+	     (fast-lexical-method-functions
+	      (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+		,@(cdddr lmf-params))
+	      ,@inner-decls
+	      ,@body-sans-decls)))
 	',initargs))))
 
 ;;; Use arrays and hash tables and the fngen stuff to make this much
@@ -1130,7 +1153,7 @@
 			(setf (get (car fname) 'method-sym)
 			      (let ((str (symbol-name (car fname))))
 				(if (string= "FAST-" str :end2 5)
-				    (intern (subseq str 5) *pcl-package*)
+				    (format-symbol *pcl-package* (subseq str 5))
 				    (car fname)))))
 		    ,@(cdr fname))))
       (set-fun-name method-function name))
@@ -1150,52 +1173,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)))))