1.0.5.32: partial fix for DISASSEMBLE bug reported by Peter Graves

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

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index d995810..384d36b 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -606,31 +606,35 @@ 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))
@@ -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