X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=7403d3a45d9c2fe1bb3d9d83d2599dc89ca6e781;hb=0a1374c92d909493e8c20744d08025a346069f42;hp=9a1f11e9fe107a120abbad8c264c8d1a722359ca;hpb=2d4a0df3457bcd50916b33d374da592d8776db0a;p=sbcl.git

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 9a1f11e..7403d3a 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -665,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+)))
@@ -700,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)))))))
@@ -893,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.
@@ -943,7 +958,7 @@
     simple-bit-vector simple-string simple-vector single-float standard-char
     stream string symbol t unsigned-byte vector))
 
-(defun split-declarations (body args calls-next-method-p)
+(defun split-declarations (body args maybe-reads-params-p)
   (let ((inner-decls nil)
 	(outer-decls nil)
 	decl)
@@ -996,7 +1011,7 @@
 			       ;; involved, to prevent compiler
 			       ;; warnings about ignored args being
 			       ;; read.
-			       (unless (and calls-next-method-p
+			       (unless (and maybe-reads-params-p
 					    (eq (car dname) 'ignore))
 				 (push var outers))
 			       (push var inners)))
@@ -1013,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
@@ -1068,7 +1083,8 @@
     (initargs body req-args lmf-params restp)
   (multiple-value-bind (outer-decls inner-decls body-sans-decls)
       (split-declarations
-       body req-args (getf (cdr lmf-params) :call-next-method-p))
+       body req-args (or (getf (cdr lmf-params) :call-next-method-p)
+			 (getf (cdr lmf-params) :setq-p)))
     (let* ((rest-arg (when restp '.rest-arg.))
 	   (args+rest-arg (if restp
 			      (append req-args (list rest-arg))
@@ -1076,27 +1092,30 @@
       `(list*
 	:fast-function
 	(,(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
-	 (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)))
+	  ,@(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
@@ -1135,7 +1154,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))