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
parent 636d516e
......@@ -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))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment