Ignore:
Timestamp:
09/05/12 10:29:55 (9 years ago)
Author:
rschlatte
Message:

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
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/subtypep.lisp

    r11586 r14149  
    478478         (values nil nil))))
    479479
    480 (defun %subtypep (type1 type2)
     480(defun properly-named-class-p (thing environment)
     481  (and (classp thing) (class-name thing)
     482       (eq thing (find-class (class-name thing) nil environment))))
     483
     484(defun %subtypep (type1 type2 &optional environment)
    481485  (when (or (eq type1 type2)
    482486            (null type1)
    483487            (eq type2 t)
    484             (and (classp type2) (eq (%class-name type2) t)))
     488            (and (classp type2) (eq type2 (find-class t))))
    485489    (return-from %subtypep (values t t)))
    486   (when (classp type1)
    487     (setf type1 (%class-name type1)))
    488   (when (classp type2)
    489     (setf type2 (%class-name type2)))
     490  (when (properly-named-class-p type1 environment)
     491    (setf type1 (class-name type1)))
     492  (when (properly-named-class-p type2 environment)
     493    (setf type2 (class-name type2)))
    490494  (let ((ct1 (ctype type1))
    491495        (ct2 (ctype type2)))
     
    506510        (return-from %subtypep (values (subclassp class1 class2) t)))
    507511      (when (or classp-1 classp-2)
    508         (let ((t1 (if classp-1 (%class-name type1) type1))
    509               (t2 (if classp-2 (%class-name type2) type2)))
     512        (let ((t1 (if classp-1 (class-name type1) type1))
     513              (t2 (if classp-2 (class-name type2) type2)))
    510514          (return-from %subtypep (values (simple-subtypep t1 t2) t))))))
    511515  (setf type1 (normalize-type type1)
     
    591595                  (values (sub-interval-p i1 i2) t))
    592596                 ((or (eq t2 'bignum)
    593                       (and (classp t2) (eq (%class-name t2) 'bignum)))
     597                      (and (classp t2) (eq (class-name t2) 'bignum)))
    594598                  (values
    595599                   (or (sub-interval-p i1 (list '* (list most-negative-fixnum)))
     
    629633                         (values (subtypep (car i1) (car i2)) t))))))
    630634          ((and (classp t1)
    631                 (eq (%class-name t1) 'array)
     635                (eq (class-name t1) 'array)
    632636                (eq t2 'array))
    633637           (values (equal i2 '(* *)) t))
     
    739743                (values nil t)))))
    740744          ((classp t2)
    741            (let ((class-name (%class-name t2)))
     745           (let ((class-name (class-name t2)))
    742746             (cond ((eq class-name t1)
    743747                    (values t t))
     
    777781
    778782(defun subtypep (type1 type2 &optional environment)
    779   (declare (ignore environment))
    780   (%subtypep type1 type2))
     783  (%subtypep type1 type2 environment))
Note: See TracChangeset for help on using the changeset viewer.