1.0.28.65: fix compiling with *PROFILE-HASH-CACHE* set to T

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index e71a3bb..12467fa 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -590,6 +590,12 @@ bootstrapping.
   (setf (gdefinition 'make-method-lambda)
         (symbol-function 'real-make-method-lambda)))
 
+(defun declared-specials (declarations)
+  (loop for (declare . specifiers) in declarations
+        append (loop for specifier in specifiers
+                     when (eq 'special (car specifier))
+                     append (cdr specifier))))
+
 (defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
   (declare (ignore proto-gf proto-method))
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
@@ -641,9 +647,12 @@ bootstrapping.
                   ;; KLUDGE: when I tried moving these to
                   ;; ADD-METHOD-DECLARATIONS, things broke.  No idea
                   ;; why.  -- CSR, 2004-06-16
-                  ,@(mapcar #'parameter-specializer-declaration-in-defmethod
-                            parameters
-                            specializers)))
+                  ,@(let ((specials (declared-specials declarations)))
+                      (mapcar (lambda (par spec)
+                                (parameter-specializer-declaration-in-defmethod
+                                 par spec specials env))
+                              parameters
+                              specializers))))
                (method-lambda
                 ;; Remove the documentation string and insert the
                 ;; appropriate class declarations. The documentation
@@ -799,8 +808,12 @@ bootstrapping.
         (symbol-function 'real-unparse-specializer-using-class)))
 
 ;;; a helper function for creating Python-friendly type declarations
-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
+;;; in DEFMETHOD forms.
+;;;
+;;; We're too lazy to cons up a new environment for this, so we just pass in
+;;; the list of locally declared specials in addition to the old environment.
+(defun parameter-specializer-declaration-in-defmethod
+    (parameter specializer specials env)
   (cond ((and (consp specializer)
               (eq (car specializer) 'eql))
          ;; KLUDGE: ANSI, in its wisdom, says that
@@ -853,16 +866,10 @@ bootstrapping.
          '(ignorable))
         ((typep specializer 'eql-specializer)
          `(type (eql ,(eql-specializer-object specializer)) ,parameter))
-        ((var-globally-special-p parameter)
-         ;; KLUDGE: Don't declare types for global special variables
-         ;; -- our rebinding magic for SETQ cases don't work right
-         ;; there.
-         ;;
-         ;; FIXME: It would be better to detect the SETQ earlier and
-         ;; skip declarations for specials only when needed, not
-         ;; always.
-         ;;
-         ;; --NS 2004-10-14
+        ((or (var-special-p parameter env) (member parameter specials))
+         ;; Don't declare types for special variables -- our rebinding magic
+         ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE),
+         ;; etc. make things undecidable.
          '(ignorable))
         (t
          ;; Otherwise, we can usually make Python very happy.
@@ -1701,9 +1708,6 @@ bootstrapping.
                                     (when (or allow-other-keys-p old-allowp)
                                       '(&allow-other-keys)))))
                  *))))
-
-(defun defgeneric-declaration (spec lambda-list)
-  `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
 \f
 ;;;; early generic function support
 
@@ -2096,7 +2100,10 @@ bootstrapping.
     (let ((arg-info (make-arg-info)))
       (setf (early-gf-arg-info fin) arg-info)
       (when lambda-list-p
-        (proclaim (defgeneric-declaration spec lambda-list))
+        (setf (info :function :type spec)
+              (specifier-type
+               (ftype-declaration-from-lambda-list lambda-list spec))
+              (info :function :where-from spec) :defined-method)
         (if argument-precedence-order
             (set-arg-info fin
                           :lambda-list lambda-list
@@ -2216,7 +2223,10 @@ bootstrapping.
   (prog1
       (apply #'reinitialize-instance existing all-keys)
     (when lambda-list-p
-      (proclaim (defgeneric-declaration fun-name lambda-list)))))
+      (setf (info :function :type fun-name)
+            (specifier-type
+             (ftype-declaration-from-lambda-list lambda-list fun-name))
+            (info :function :where-from fun-name) :defined-method))))
 
 (defun real-ensure-gf-using-class--null
        (existing
@@ -2232,7 +2242,10 @@ bootstrapping.
             (apply #'make-instance generic-function-class
                    :name fun-name all-keys))
     (when lambda-list-p
-      (proclaim (defgeneric-declaration fun-name lambda-list)))))
+      (setf (info :function :type fun-name)
+            (specifier-type
+             (ftype-declaration-from-lambda-list lambda-list fun-name))
+            (info :function :where-from fun-name) :defined-method))))
 \f
 (defun safe-gf-arg-info (generic-function)
   (if (eq (class-of generic-function) *the-class-standard-generic-function*)