1.0.6.3: thread and interrupt safe CLOS cache

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 8c4e28e..8d87432 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -606,35 +606,39 @@ bootstrapping.
          ;; We still need to deal with the class case too, but at
          ;; least #.(find-class 'integer) and integer as equivalent
          ;; specializers with this.
-         (let* ((specializer (if (and (typep specializer 'class)
-                                      (let ((name (class-name specializer)))
-                                        (and name (symbolp name)
-                                             (eq specializer (find-class name nil)))))
-                                 (class-name specializer)
-                                 specializer))
-                (kind (info :type :kind specializer)))
-
-           (flet ((specializer-class ()
-                    (if (typep specializer 'class)
-                        specializer
-                        (find-class specializer nil))))
+         (let* ((specializer-nameoid
+                 (if (and (typep specializer 'class)
+                          (let ((name (class-name specializer)))
+                            (and name (symbolp name)
+                                 (eq specializer (find-class name nil)))))
+                     (class-name specializer)
+                     specializer))
+                (kind (info :type :kind specializer-nameoid)))
+
+           (flet ((specializer-nameoid-class ()
+                    (typecase specializer-nameoid
+                      (symbol (find-class specializer-nameoid nil))
+                      (class specializer-nameoid)
+                      (class-eq-specializer
+                       (specializer-class specializer-nameoid))
+                      (t nil))))
              (ecase kind
-               ((:primitive) `(type ,specializer ,parameter))
+               ((:primitive) `(type ,specializer-nameoid ,parameter))
                ((:defined)
-                (let ((class (specializer-class)))
-                  ;; CLASS can be null here if the user has erroneously
-                 ;; tried to use a defined type as a specializer; it
-                 ;; can be a non-BUILT-IN-CLASS if the user defines a
-                 ;; type and calls (SETF FIND-CLASS) in a consistent
-                 ;; way.
+                (let ((class (specializer-nameoid-class)))
+                  ;; CLASS can be null here if the user has
+                  ;; erroneously tried to use a defined type as a
+                  ;; specializer; it can be a non-BUILT-IN-CLASS if
+                  ;; the user defines a type and calls (SETF
+                  ;; FIND-CLASS) in a consistent way.
                  (when (and class (typep class 'built-in-class))
-                   `(type ,specializer ,parameter))))
+                   `(type ,specializer-nameoid ,parameter))))
               ((:instance nil)
-               (let ((class (specializer-class)))
+               (let ((class (specializer-nameoid-class)))
                  (cond
                    (class
                     (if (typep class '(or built-in-class structure-class))
-                        `(type ,specializer ,parameter)
+                        `(type ,class ,parameter)
                         ;; don't declare CLOS classes as parameters;
                         ;; it's too expensive.
                         '(ignorable)))
@@ -645,8 +649,8 @@ bootstrapping.
                     ;; ...)).  Best to let the user know we haven't
                     ;; been able to extract enough information:
                     (style-warn
-                     "~@<can't find type for presumed class ~S in ~S.~@:>"
-                     specializer
+                     "~@<can't find type for specializer ~S in ~S.~@:>"
+                     specializer-nameoid
                      'parameter-specializer-declaration-in-defmethod)
                     '(ignorable)))))
               ((:forthcoming-defclass-type)
@@ -1416,7 +1420,13 @@ bootstrapping.
                    (t form))))
 
       (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
-        (values walked-lambda
+        ;;; FIXME: the walker's rewriting of the source code causes
+        ;;; trouble when doing code coverage. The rewrites should be
+        ;;; removed, and the same operations done using
+        ;;; compiler-macros or tranforms.
+        (values (if (sb-c:policy env (= sb-c:store-coverage-data 0))
+                    walked-lambda
+                    method-lambda)
                 call-next-method-p
                 closurep
                 next-method-p-p
@@ -1600,17 +1610,21 @@ bootstrapping.
   (declare (ignore environment))
   (let ((existing (and (fboundp fun-name)
                        (gdefinition fun-name))))
-    (if (and existing
-             (eq *boot-state* 'complete)
-             (null (generic-function-p existing)))
-        (generic-clobbers-function fun-name)
-        (apply #'ensure-generic-function-using-class
-               existing fun-name all-keys))))
+    (cond ((and existing
+                (eq *boot-state* 'complete)
+                (null (generic-function-p existing)))
+           (generic-clobbers-function fun-name)
+           (fmakunbound fun-name)
+           (apply #'ensure-generic-function fun-name all-keys))
+          (t
+           (apply #'ensure-generic-function-using-class
+                  existing fun-name all-keys)))))
 
 (defun generic-clobbers-function (fun-name)
-  (error 'simple-program-error
-         :format-control "~S already names an ordinary function or a macro."
-         :format-arguments (list fun-name)))
+  (cerror "Replace the function binding"
+          'simple-program-error
+          :format-control "~S already names an ordinary function or a macro."
+          :format-arguments (list fun-name)))
 
 (defvar *sgf-wrapper*
   (boot-make-wrapper (early-class-size 'standard-generic-function)
@@ -1995,8 +2009,6 @@ bootstrapping.
       (setf (gf-dfun-state generic-function) new-value)))
 
 (defun set-dfun (gf &optional dfun cache info)
-  (when cache
-    (setf (cache-owner cache) gf))
   (let ((new-state (if (and dfun (or cache info))
                        (list* dfun cache info)
                        dfun)))