+(defun cons-type-might-be-empty-type (type)
+ (declare (type cons-type type))
+ (let ((car-type (cons-type-car-type type))
+ (cdr-type (cons-type-cdr-type type)))
+ (or
+ (if (cons-type-p car-type)
+ (cons-type-might-be-empty-type car-type)
+ (multiple-value-bind (yes surep)
+ (type= car-type *empty-type*)
+ (aver (not yes))
+ (not surep)))
+ (if (cons-type-p cdr-type)
+ (cons-type-might-be-empty-type cdr-type)
+ (multiple-value-bind (yes surep)
+ (type= cdr-type *empty-type*)
+ (aver (not yes))
+ (not surep))))))
+
+(!define-type-method (named :complex-=) (type1 type2)
+ (cond
+ ((and (eq type2 *empty-type*)
+ (or (and (intersection-type-p type1)
+ ;; not allowed to be unsure on these... FIXME: keep
+ ;; the list of CL types that are intersection types
+ ;; once and only once.
+ (not (or (type= type1 (specifier-type 'ratio))
+ (type= type1 (specifier-type 'keyword)))))
+ (and (cons-type-p type1)
+ (cons-type-might-be-empty-type type1))))
+ ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
+ ;; STREAM) can get here. In general, we can't really tell
+ ;; whether these are equal to NIL or not, so
+ (values nil nil))
+ ((type-might-contain-other-types-p type1)
+ (invoke-complex-=-other-method type1 type2))
+ (t (values nil t))))
+
+(!define-type-method (named :simple-subtypep) (type1 type2)
+ (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (aver (not (eq type1 type2)))
+ (values (or (eq type1 *empty-type*)
+ (eq type2 *wild-type*)
+ (eq type2 *universal-type*)) t))
+
+(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
+ ;; This AVER causes problems if we write accurate methods for the
+ ;; union (and possibly intersection) types which then delegate to
+ ;; us; while a user shouldn't get here, because of the odd status of
+ ;; *wild-type* a type-intersection executed by the compiler can. -
+ ;; CSR, 2002-04-10
+ ;;
+ ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type1 *empty-type*)
+ t)
+ (;; When TYPE2 might be the universal type in disguise
+ (type-might-contain-other-types-p type2)
+ ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
+ ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
+ ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
+ ;; HAIRY-TYPEs as we used to. Instead we deal with the
+ ;; problem (where at least part of the problem is cases like
+ ;; (SUBTYPEP T '(SATISFIES FOO))
+ ;; or
+ ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
+ ;; where the second type is a hairy type like SATISFIES, or
+ ;; is a compound type which might contain a hairy type) by
+ ;; returning uncertainty.
+ (values nil nil))
+ ((eq type1 *funcallable-instance-type*)
+ (values (eq type2 (specifier-type 'function)) t))
+ (t
+ ;; This case would have been picked off by the SIMPLE-SUBTYPEP
+ ;; method, and so shouldn't appear here.
+ (aver (not (named-type-p type2)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another
+ ;; named type in disguise, TYPE2 is not a superset of TYPE1.
+ (values nil t))))
+
+(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
+ (aver (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type2 *universal-type*)
+ (values t t))
+ ;; some CONS types can conceal danger
+ ((and (cons-type-p type1) (cons-type-might-be-empty-type type1))
+ (values nil nil))
+ ((type-might-contain-other-types-p type1)
+ ;; those types can be other types in disguise. So we'd
+ ;; better delegate.
+ (invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (or (eq type2 *instance-type*)
+ (eq type2 *funcallable-instance-type*))
+ (member-type-p type1))
+ ;; member types can be subtypep INSTANCE and
+ ;; FUNCALLABLE-INSTANCE in surprising ways.
+ (invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (eq type2 *extended-sequence-type*) (classoid-p type1))
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (sequencep (find (classoid-layout (find-classoid 'sequence))
+ inherits)))
+ (values (if sequencep t nil) t)))
+ ((and (eq type2 *instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (cond
+ (functionp
+ (values nil t))
+ ((eq type1 (find-classoid 'function))
+ (values nil t))
+ ((or (structure-classoid-p type1)
+ #+nil
+ (condition-classoid-p type1))
+ (values t t))
+ (t (values nil nil))))))
+ ((and (eq type2 *funcallable-instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (values (if functionp t nil) t))))
+ (t
+ ;; FIXME: This seems to rely on there only being 4 or 5
+ ;; NAMED-TYPE values, and the exclusion of various
+ ;; possibilities above. It would be good to explain it and/or
+ ;; rewrite it so that it's clearer.
+ (values nil t))))
+
+(!define-type-method (named :complex-intersection2) (type1 type2)
+ ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
+ ;; Perhaps when bug 85 is fixed it can be reenabled.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (cond
+ ((eq type2 *extended-sequence-type*)
+ (typecase type1
+ (structure-classoid *empty-type*)
+ (classoid
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'sequence))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ nil)))
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ ((eq type2 *instance-type*)
+ (typecase type1
+ (structure-classoid type1)
+ (classoid
+ (if (and (not (member type1 *non-instance-classoid-types*
+ :key #'find-classoid))
+ (not (eq type1 (find-classoid 'function)))
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ *empty-type*))
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ ((eq type2 *funcallable-instance-type*)
+ (typecase type1
+ (structure-classoid *empty-type*)
+ (classoid
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ (if (type= type1 (find-classoid 'function))
+ type2
+ nil))))
+ (fun-type nil)
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ (t (hierarchical-intersection2 type1 type2))))
+
+(!define-type-method (named :complex-union2) (type1 type2)
+ ;; Perhaps when bug 85 is fixed this can be reenabled.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (cond
+ ((eq type2 *extended-sequence-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'sequence))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ type2)
+ nil))
+ ((eq type2 *instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1))))
+ nil
+ type2)
+ nil))
+ ((eq type2 *funcallable-instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ (if (eq type1 (specifier-type 'function))
+ type1
+ type2))
+ nil))
+ (t (hierarchical-union2 type1 type2))))
+
+(!define-type-method (named :negate) (x)
+ (aver (not (eq x *wild-type*)))
+ (cond
+ ((eq x *universal-type*) *empty-type*)
+ ((eq x *empty-type*) *universal-type*)
+ ((or (eq x *instance-type*)
+ (eq x *funcallable-instance-type*)
+ (eq x *extended-sequence-type*))
+ (make-negation-type :type x))
+ (t (bug "NAMED type unexpected: ~S" x))))
+
+(!define-type-method (named :unparse) (x)