X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=8ffba535cbafdc4ca5168ff493aaa235b492574e;hb=01e9e8c568777d6480699e6cb3947f38c3bed350;hp=5d4f9404d22b991766268d9be38eaca9503431c6;hpb=fcbf5a7338a1600a6a05bc8be7b42be43505d1dc;p=sbcl.git

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 5d4f940..8ffba53 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -604,39 +604,58 @@ bootstrapping.
          '(ignorable))
         (t
          ;; Otherwise, we can usually make Python very happy.
-         (let ((kind (info :type :kind specializer)))
-           (ecase kind
-             ((:primitive) `(type ,specializer ,parameter))
-             ((:defined)
-              (let ((class (find-class specializer nil)))
-                ;; 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))))
-             ((:instance nil)
-              (let ((class (find-class specializer nil)))
-                (cond
-                  (class
-                   (if (typep class '(or built-in-class structure-class))
-                       `(type ,specializer ,parameter)
-                       ;; don't declare CLOS classes as parameters;
-                       ;; it's too expensive.
-                       '(ignorable)))
-                  (t
-                   ;; we can get here, and still not have a failure
-                   ;; case, by doing MOP programming like (PROGN
-                   ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
-                   ;; ...)).  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
-                    'parameter-specializer-declaration-in-defmethod)
-                   '(ignorable)))))
-             ((:forthcoming-defclass-type) '(ignorable)))))))
+         ;;
+         ;; KLUDGE: Since INFO doesn't work right for class objects here,
+         ;; and they are valid specializers, see if the specializer is
+         ;; a named class, and use the name in that case -- otherwise
+         ;; the class instance is ok, since info will just return NIL, NIL.
+         ;;
+         ;; 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)
+                                      (eq specializer (find-class (class-name specializer))))
+                                 (class-name specializer)
+                                 specializer))
+                (kind (info :type :kind specializer)))
+
+           (flet ((specializer-class ()
+                    (if (typep specializer 'class)
+                        specializer
+                        (find-class specializer nil))))
+             (ecase kind
+               ((:primitive) `(type ,specializer ,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.
+                 (when (and class (typep class 'built-in-class))
+                   `(type ,specializer ,parameter))))
+              ((:instance nil)
+               (let ((class (specializer-class)))
+                 (cond
+                   (class
+                    (if (typep class '(or built-in-class structure-class))
+                        `(type ,specializer ,parameter)
+                        ;; don't declare CLOS classes as parameters;
+                        ;; it's too expensive.
+                        '(ignorable)))
+                   (t
+                    ;; we can get here, and still not have a failure
+                    ;; case, by doing MOP programming like (PROGN
+                    ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+                    ;; ...)).  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
+                     'parameter-specializer-declaration-in-defmethod)
+                    '(ignorable)))))
+              ((:forthcoming-defclass-type)
+               '(ignorable))))))))
 
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
@@ -1344,37 +1363,12 @@ bootstrapping.
            (funcallable-instance-p (gdefinition name)))))
 
 (defvar *method-function-plist* (make-hash-table :test 'eq))
-(defvar *mf1* nil)
-(defvar *mf1p* nil)
-(defvar *mf1cp* nil)
-(defvar *mf2* nil)
-(defvar *mf2p* nil)
-(defvar *mf2cp* nil)
 
 (defun method-function-plist (method-function)
-  (unless (eq method-function *mf1*)
-    (rotatef *mf1* *mf2*)
-    (rotatef *mf1p* *mf2p*)
-    (rotatef *mf1cp* *mf2cp*))
-  (unless (or (eq method-function *mf1*) (null *mf1cp*))
-    (setf (gethash *mf1* *method-function-plist*) *mf1p*))
-  (unless (eq method-function *mf1*)
-    (setf *mf1* method-function
-          *mf1cp* nil
-          *mf1p* (gethash method-function *method-function-plist*)))
-  *mf1p*)
-
-(defun (setf method-function-plist)
-    (val method-function)
-  (unless (eq method-function *mf1*)
-    (rotatef *mf1* *mf2*)
-    (rotatef *mf1cp* *mf2cp*)
-    (rotatef *mf1p* *mf2p*))
-  (unless (or (eq method-function *mf1*) (null *mf1cp*))
-    (setf (gethash *mf1* *method-function-plist*) *mf1p*))
-  (setf *mf1* method-function
-        *mf1cp* t
-        *mf1p* val))
+  (gethash method-function *method-function-plist*))
+
+(defun (setf method-function-plist) (val method-function)
+  (setf (gethash method-function *method-function-plist*) val))
 
 (defun method-function-get (method-function key &optional default)
   (getf (method-function-plist method-function) key default))