+ (invoke-complex-subtypep-arg1-method type1 type2)))))
+
+(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
+ ;; "Incrementally extended heuristic algorithms tend inexorably toward the
+ ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
+ (let ((hairy-spec (hairy-type-specifier type1)))
+ (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
+ ;; You may not believe this. I couldn't either. But then I
+ ;; sat down and drew lots of Venn diagrams. Comments
+ ;; involving a and b refer to the call (subtypep '(not a)
+ ;; 'b) -- CSR, 2002-02-27.
+ (block nil
+ ;; (Several logical truths in this block are true as
+ ;; long as b/=T. As of sbcl-0.7.1.28, it seems
+ ;; impossible to construct a case with b=T where we
+ ;; actually reach this type method, but we'll test for
+ ;; and exclude this case anyway, since future
+ ;; maintenance might make it possible for it to end up
+ ;; in this code.)
+ (multiple-value-bind (equal certain)
+ (type= type2 (specifier-type t))
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values t t))))
+ (let ((complement-type1 (specifier-type (cadr hairy-spec))))
+ ;; Do the special cases first, in order to give us a
+ ;; chance if subtype/supertype relationships are hairy.
+ (multiple-value-bind (equal certain)
+ (type= complement-type1 type2)
+ ;; If a = b, ~a is not a subtype of b (unless b=T,
+ ;; which was excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; KLUDGE: ANSI requires that the SUBTYPEP result
+ ;; between any two built-in atomic type specifiers
+ ;; never be uncertain. This is hard to do cleanly for
+ ;; the built-in types whose definitions include
+ ;; (NOT FOO), i.e. CONS and RATIO. However, we can do
+ ;; it with this hack, which uses our global knowledge
+ ;; that our implementation of the type system uses
+ ;; disjoint implementation types to represent disjoint
+ ;; sets (except when types are contained in other types).
+ ;; (This is a KLUDGE because it's fragile. Various
+ ;; changes in internal representation in the type
+ ;; system could make it start confidently returning
+ ;; incorrect results.) -- WHN 2002-03-08
+ (unless (or (type-might-contain-other-types-p complement-type1)
+ (type-might-contain-other-types-p type2))
+ ;; Because of the way our types which don't contain
+ ;; other types are disjoint subsets of the space of
+ ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when
+ ;; AA and B are simple (and B is not T, as checked above).
+ (return (values nil t)))
+ ;; The old (TYPE= TYPE1 TYPE2) branch would never be
+ ;; taken, as TYPE1 and TYPE2 will only be equal if
+ ;; they're both NOT types, and then the
+ ;; :SIMPLE-SUBTYPEP method would be used instead.
+ ;; But a CSUBTYPEP relationship might still hold:
+ (multiple-value-bind (equal certain)
+ (csubtypep complement-type1 type2)
+ ;; If a is a subtype of b, ~a is not a subtype of b
+ ;; (unless b=T, which was excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ (multiple-value-bind (equal certain)
+ (csubtypep type2 complement-type1)
+ ;; If b is a subtype of a, ~a is not a subtype of b.
+ ;; (FIXME: That's not true if a=T. Do we know at
+ ;; this point that a is not T?)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; old CSR comment ca. 0.7.2, now obsoleted by the
+ ;; SIMPLE-CTYPE? KLUDGE case above:
+ ;; Other cases here would rely on being able to catch
+ ;; all possible cases, which the fragility of this
+ ;; type system doesn't inspire me; for instance, if a
+ ;; is type= to ~b, then we want T, T; if this is not
+ ;; the case and the types are disjoint (have an
+ ;; intersection of *empty-type*) then we want NIL, T;
+ ;; else if the union of a and b is the
+ ;; *universal-type* then we want T, T. So currently we
+ ;; still claim to be unsure about e.g. (subtypep '(not
+ ;; fixnum) 'single-float).
+ )))
+ (t
+ (values nil nil)))))
projects / sbcl.git / blobdiff