+;;;; negation types
+
+(!define-type-method (negation :unparse) (x)
+ `(not ,(type-specifier (negation-type-type x))))
+
+(!define-type-method (negation :simple-subtypep) (type1 type2)
+ (csubtypep (negation-type-type type2) (negation-type-type type1)))
+
+(!define-type-method (negation :complex-subtypep-arg2) (type1 type2)
+ (let* ((complement-type2 (negation-type-type type2))
+ (intersection2 (type-intersection2 type1
+ complement-type2)))
+ (if intersection2
+ ;; FIXME: if uncertain, maybe try arg1?
+ (type= intersection2 *empty-type*)
+ (invoke-complex-subtypep-arg1-method type1 type2))))
+
+(!define-type-method (negation :complex-subtypep-arg1) (type1 type2)
+ ;; "Incrementally extended heuristic algorithms tend inexorably toward the
+ ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
+ ;;
+ ;; 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 *universal-type*)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values t t))))
+ (let ((complement-type1 (negation-type-type type1)))
+ ;; 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).
+ ;;
+ ;; OTOH we might still get here:
+ (values nil nil))))
+
+(!define-type-method (negation :complex-=) (type1 type2)
+ ;; (NOT FOO) isn't equivalent to anything that's not a negation
+ ;; type, except possibly a type that might contain it in disguise.
+ (declare (ignore type2))
+ (if (type-might-contain-other-types-p type1)
+ (values nil nil)
+ (values nil t)))
+
+(!define-type-method (negation :simple-intersection2) (type1 type2)
+ (let ((not1 (negation-type-type type1))
+ (not2 (negation-type-type type2)))
+ (cond
+ ((csubtypep not1 not2) type2)
+ ((csubtypep not2 not1) type1)
+ ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
+ ;; method, below? The clause would read
+ ;;
+ ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
+ ;;
+ ;; but with proper canonicalization of negation types, there's
+ ;; no way of constructing two negation types with union of their
+ ;; negations being the universal type.
+ (t
+ (aver (not (eq (type-union not1 not2) *universal-type*)))
+ nil))))
+
+(!define-type-method (negation :complex-intersection2) (type1 type2)
+ (cond
+ ((csubtypep type1 (negation-type-type type2)) *empty-type*)
+ ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+ type1)
+ (t nil)))
+
+(!define-type-method (negation :simple-union2) (type1 type2)
+ (let ((not1 (negation-type-type type1))
+ (not2 (negation-type-type type2)))
+ (cond
+ ((csubtypep not1 not2) type1)
+ ((csubtypep not2 not1) type2)
+ ((eq (type-intersection not1 not2) *empty-type*)
+ *universal-type*)
+ (t nil))))
+
+(!define-type-method (negation :complex-union2) (type1 type2)
+ (cond
+ ((csubtypep (negation-type-type type2) type1) *universal-type*)
+ ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+ type2)
+ (t nil)))
+
+(!define-type-method (negation :simple-=) (type1 type2)
+ (type= (negation-type-type type1) (negation-type-type type2)))
+
+(!def-type-translator not (typespec)
+ (let* ((not-type (specifier-type typespec))
+ (spec (type-specifier not-type)))
+ (cond
+ ;; canonicalize (NOT (NOT FOO))
+ ((and (listp spec) (eq (car spec) 'not))
+ (specifier-type (cadr spec)))
+ ;; canonicalize (NOT NIL) and (NOT T)
+ ((eq not-type *empty-type*) *universal-type*)
+ ((eq not-type *universal-type*) *empty-type*)
+ ((and (numeric-type-p not-type)
+ (null (numeric-type-low not-type))
+ (null (numeric-type-high not-type)))
+ (make-negation-type :type not-type))
+ ((numeric-type-p not-type)
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type not-type :low nil :high nil))
+ (cond
+ ((null (numeric-type-low not-type))
+ (modified-numeric-type
+ not-type
+ :low (let ((h (numeric-type-high not-type)))
+ (if (consp h) (car h) (list h)))
+ :high nil))
+ ((null (numeric-type-high not-type))
+ (modified-numeric-type
+ not-type
+ :low nil
+ :high (let ((l (numeric-type-low not-type)))
+ (if (consp l) (car l) (list l)))))
+ (t (type-union
+ (modified-numeric-type
+ not-type
+ :low nil
+ :high (let ((l (numeric-type-low not-type)))
+ (if (consp l) (car l) (list l))))
+ (modified-numeric-type
+ not-type
+ :low (let ((h (numeric-type-high not-type)))
+ (if (consp h) (car h) (list h)))
+ :high nil))))))
+ ((intersection-type-p not-type)
+ (apply #'type-union
+ (mapcar #'(lambda (x)
+ (specifier-type `(not ,(type-specifier x))))
+ (intersection-type-types not-type))))
+ ((union-type-p not-type)
+ (apply #'type-intersection
+ (mapcar #'(lambda (x)
+ (specifier-type `(not ,(type-specifier x))))
+ (union-type-types not-type))))
+ ((member-type-p not-type)
+ (let ((members (member-type-members not-type)))
+ (if (some #'floatp members)
+ (let (floats)
+ (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
+ (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
+ (when (member (car pair) members)
+ (aver (not (member (cdr pair) members)))
+ (push (cdr pair) floats)
+ (setf members (remove (car pair) members)))
+ (when (member (cdr pair) members)
+ (aver (not (member (car pair) members)))
+ (push (car pair) floats)
+ (setf members (remove (cdr pair) members))))
+ (apply #'type-intersection
+ (if (null members)
+ *universal-type*
+ (make-negation-type
+ :type (make-member-type :members members)))
+ (mapcar
+ (lambda (x)
+ (let ((type (ctype-of x)))
+ (type-union
+ (make-negation-type
+ :type (modified-numeric-type type
+ :low nil :high nil))
+ (modified-numeric-type type
+ :low nil :high (list x))
+ (make-member-type :members (list x))
+ (modified-numeric-type type
+ :low (list x) :high nil))))
+ floats)))
+ (make-negation-type :type not-type))))
+ ((and (cons-type-p not-type)
+ (eq (cons-type-car-type not-type) *universal-type*)
+ (eq (cons-type-cdr-type not-type) *universal-type*))
+ (make-negation-type :type not-type))
+ ((cons-type-p not-type)
+ (type-union
+ (make-negation-type :type (specifier-type 'cons))
+ (cond
+ ((and (not (eq (cons-type-car-type not-type) *universal-type*))
+ (not (eq (cons-type-cdr-type not-type) *universal-type*)))
+ (type-union
+ (make-cons-type
+ (specifier-type `(not ,(type-specifier
+ (cons-type-car-type not-type))))
+ *universal-type*)
+ (make-cons-type
+ *universal-type*
+ (specifier-type `(not ,(type-specifier
+ (cons-type-cdr-type not-type)))))))
+ ((not (eq (cons-type-car-type not-type) *universal-type*))
+ (make-cons-type
+ (specifier-type `(not ,(type-specifier
+ (cons-type-car-type not-type))))
+ *universal-type*))
+ ((not (eq (cons-type-cdr-type not-type) *universal-type*))
+ (make-cons-type
+ *universal-type*
+ (specifier-type `(not ,(type-specifier
+ (cons-type-cdr-type not-type))))))
+ (t (bug "Weird CONS type ~S" not-type)))))
+ (t (make-negation-type :type not-type)))))
+\f