0.8.10.14:

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

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index f4cab13..f75acf6 100644 (file)
--- 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.
@@ -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
@@ -1075,8 +1090,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.))