[armedbear-cvs] r14149 - trunk/abcl/src/org/armedbear/lisp

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Wed Sep  5 03:29:55 2012
New Revision: 14149

Log:
Fix subtypep for anonymous classes

- Only use class name if the class has a proper name

  - The class name of an anonymous class is NIL, which is the universal
    subtype

  - Similarly, (setf (class-name c) t) would make c a supertype of
    everything ...

- Reported by Pascal Costanza

Modified:
   trunk/abcl/src/org/armedbear/lisp/subtypep.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/subtypep.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	Sun Sep  2 11:11:30 2012	(r14148)
+++ trunk/abcl/src/org/armedbear/lisp/subtypep.lisp	Wed Sep  5 03:29:55 2012	(r14149)
@@ -477,16 +477,20 @@
         (t
          (values nil nil))))
 
-(defun %subtypep (type1 type2)
+(defun properly-named-class-p (thing environment)
+  (and (classp thing) (class-name thing)
+       (eq thing (find-class (class-name thing) nil environment))))
+
+(defun %subtypep (type1 type2 &optional environment)
   (when (or (eq type1 type2)
             (null type1)
             (eq type2 t)
-            (and (classp type2) (eq (%class-name type2) t)))
+            (and (classp type2) (eq type2 (find-class t))))
     (return-from %subtypep (values t t)))
-  (when (classp type1)
-    (setf type1 (%class-name type1)))
-  (when (classp type2)
-    (setf type2 (%class-name type2)))
+  (when (properly-named-class-p type1 environment)
+    (setf type1 (class-name type1)))
+  (when (properly-named-class-p type2 environment)
+    (setf type2 (class-name type2)))
   (let ((ct1 (ctype type1))
         (ct2 (ctype type2)))
     (multiple-value-bind (subtype-p valid-p)
@@ -505,8 +509,8 @@
                                   (and (symbolp type2) (find-class type2 nil)))))
         (return-from %subtypep (values (subclassp class1 class2) t)))
       (when (or classp-1 classp-2)
-        (let ((t1 (if classp-1 (%class-name type1) type1))
-              (t2 (if classp-2 (%class-name type2) type2)))
+        (let ((t1 (if classp-1 (class-name type1) type1))
+              (t2 (if classp-2 (class-name type2) type2)))
           (return-from %subtypep (values (simple-subtypep t1 t2) t))))))
   (setf type1 (normalize-type type1)
         type2 (normalize-type type2))
@@ -590,7 +594,7 @@
            (cond ((memq t2 '(integer rational real number))
                   (values (sub-interval-p i1 i2) t))
                  ((or (eq t2 'bignum)
-                      (and (classp t2) (eq (%class-name t2) 'bignum)))
+                      (and (classp t2) (eq (class-name t2) 'bignum)))
                   (values
                    (or (sub-interval-p i1 (list '* (list most-negative-fixnum)))
                        (sub-interval-p i1 (list (list most-positive-fixnum) '*)))
@@ -628,7 +632,7 @@
                         (t
                          (values (subtypep (car i1) (car i2)) t))))))
           ((and (classp t1)
-                (eq (%class-name t1) 'array)
+                (eq (class-name t1) 'array)
                 (eq t2 'array))
            (values (equal i2 '(* *)) t))
           ((and (memq t1 '(array simple-array)) (eq t2 'array))
@@ -738,7 +742,7 @@
                (t
                 (values nil t)))))
           ((classp t2)
-           (let ((class-name (%class-name t2)))
+           (let ((class-name (class-name t2)))
              (cond ((eq class-name t1)
                     (values t t))
                    ((and (eq class-name 'array)
@@ -776,5 +780,4 @@
            (values nil nil)))))
 
 (defun subtypep (type1 type2 &optional environment)
-  (declare (ignore environment))
-  (%subtypep type1 type2))
+  (%subtypep type1 type2 environment))