+
+;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish
+;;; to revisit this, perhaps by implementing a COMPLEMENT type
+;;; (analogous to UNION and INTERSECTION) to take the logic out of the
+;;; HAIRY domain.
+(assert-nil-t (subtypep 'atom 'cons))
+(assert-nil-t (subtypep 'cons 'atom))
+;;; These two are desireable but not necessary for ANSI conformance;
+;;; maintenance work on other parts of the system broke them in
+;;; sbcl-0.7.13.11 -- CSR
+#+nil
+(assert-nil-t (subtypep '(not list) 'cons))
+#+nil
+(assert-nil-t (subtypep '(not float) 'single-float))
+(assert-t-t (subtypep '(not atom) 'cons))
+(assert-t-t (subtypep 'cons '(not atom)))
+;;; ANSI requires that SUBTYPEP relationships among built-in primitive
+;;; types never be uncertain, i.e. never return NIL as second value.
+;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here
+;;; (because it's a negation type, implemented as a HAIRY-TYPE, and
+;;; CMU CL's HAIRY-TYPE logic punted a lot).
+(assert-t-t (subtypep 'integer 'atom))
+(assert-t-t (subtypep 'function 'atom))
+(assert-nil-t (subtypep 'list 'atom))
+(assert-nil-t (subtypep 'atom 'integer))
+(assert-nil-t (subtypep 'atom 'function))
+(assert-nil-t (subtypep 'atom 'list))
+;;; ATOM is equivalent to (NOT CONS):
+(assert-t-t (subtypep 'integer '(not cons)))
+(assert-nil-t (subtypep 'list '(not cons)))
+(assert-nil-t (subtypep '(not cons) 'integer))
+(assert-nil-t (subtypep '(not cons) 'list))
+;;; And we'd better check that all the named types are right. (We also
+;;; do some more tests on ATOM here, since once CSR experimented with
+;;; making it a named type.)
+(assert-t-t (subtypep 'nil 'nil))
+(assert-t-t (subtypep 'nil 'atom))
+(assert-t-t (subtypep 'nil 't))
+(assert-nil-t (subtypep 'atom 'nil))
+(assert-t-t (subtypep 'atom 'atom))
+(assert-t-t (subtypep 'atom 't))
+(assert-nil-t (subtypep 't 'nil))
+(assert-nil-t (subtypep 't 'atom))
+(assert-t-t (subtypep 't 't))
+;;; Also, LIST is now somewhat special, in that (NOT LIST) should be
+;;; recognized as a subtype of ATOM:
+(assert-t-t (subtypep '(not list) 'atom))
+(assert-nil-t (subtypep 'atom '(not list)))
+;;; These used to fail, because when the two arguments to subtypep are
+;;; of different specifier-type types (e.g. HAIRY and UNION), there
+;;; are two applicable type methods -- in this case
+;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and
+;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but
+;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of
+;;; them returns NIL, NIL (indicating uncertainty) it should try the
+;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish
+;;; logic in those type methods fixed it.
+(assert-nil-t (subtypep '(not cons) 'list))
+(assert-nil-t (subtypep '(not single-float) 'float))
+;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish
+;;; logic in SUBTYPEP type methods) we fixed bug 58 too:
+(assert-t-t (subtypep '(and zilch integer) 'zilch))
+(assert-t-t (subtypep '(and integer zilch) 'zilch))
+
+;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at
+;;; special-casing calls to subtypep involving *EMPTY-TYPE*,
+;;; corresponding to the NIL type-specifier; we were bogusly returning
+;;; NIL, T (indicating surety) for the following:
+(assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil))
+
+;;; It turns out that, as of sbcl-0.7.2, we require to be able to
+;;; detect this to compile src/compiler/node.lisp (and in particular,
+;;; the definition of the component structure). Since it's a sensible
+;;; thing to want anyway, let's test for it here:
+(assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead))
+ '(or some-undefined-type (member :no-ir2-yet :dead))))
+;;; BUG 158 (failure to compile loops with vector references and
+;;; increments of greater than 1) was a symptom of type system
+;;; uncertainty, to wit:
+(assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912)))
+ '(mod 536870911))) ; aka SB-INT:INDEX.
+;;; floating point types can be tricky.
+(assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0)))
+(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0)))
+(assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0)))
+(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0)))
+(assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0)))
+(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0)))
+(assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0)))
+(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0)))
+
+(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0)))
+(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0)))
+(assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0)))
+(assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0)))
+(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0)))
+(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0)))
+(assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0)))
+(assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0)))
+
+(assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0)))
+(assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0)))
+(assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0)))
+(assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0)))
+
+(assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0))))
+(assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0))))
+
+(assert-t-t (subtypep '(float -0.0) '(float 0.0)))
+(assert-t-t (subtypep '(float 0.0) '(float -0.0)))
+(assert-t-t (subtypep '(float (0.0)) '(float (-0.0))))
+(assert-t-t (subtypep '(float (-0.0)) '(float (0.0))))