(defun simplified-compound-types (input-types %compound-type-p simplify2)
(let ((simplified-types (make-array (length input-types)
:fill-pointer 0
+ :adjustable t
:element-type 'ctype
;; (This INITIAL-ELEMENT shouldn't
;; matter, but helps avoid type
(t
(values nil nil)))))
-(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
+ (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))))
+ ;; This (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.
+ ;; ((type= type1 type2) (values t t))
+ (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))))
+ ;; 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)))))
+
+(!define-type-method (hairy :complex-=) (type1 type2)
(declare (ignore type1 type2))
(values nil nil))
;; Check legality of arguments.
(destructuring-bind (not typespec) whole
(declare (ignore not))
- (specifier-type typespec)) ; must be legal typespec
- ;; Create object.
- (make-hairy-type :specifier whole))
+ (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec
+ (if (and (listp spec) (eq (car spec) 'not))
+ ;; canonicalize (not (not foo))
+ (specifier-type (cadr spec))
+ (make-hairy-type :specifier whole)))))
(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
`(unsigned-byte ,high-length))
(t
`(mod ,(1+ high)))))
- ((and (= low sb!vm:*target-most-negative-fixnum*)
- (= high sb!vm:*target-most-positive-fixnum*))
+ ((and (= low sb!xc:most-negative-fixnum)
+ (= high sb!xc:most-positive-fixnum))
'fixnum)
((and (= low (lognot high))
(= high-count high-length)
(if (eq typespec '*)
(make-numeric-type :complexp :complex)
(labels ((not-numeric ()
- ;; FIXME: should probably be TYPE-ERROR
(error "The component type for COMPLEX is not numeric: ~S"
typespec))
+ (not-real ()
+ (error "The component type for COMPLEX is not real: ~S"
+ typespec))
(complex1 (component-type)
(unless (numeric-type-p component-type)
- ;; FIXME: As per the FIXME below, ANSI says we're
- ;; supposed to handle any subtype of REAL, not only
- ;; those which can be represented as NUMERIC-TYPE.
(not-numeric))
(when (eq (numeric-type-complexp component-type) :complex)
- (error "The component type for COMPLEX is complex: ~S"
- typespec))
- (modified-numeric-type component-type :complexp :complex)))
- (let ((type (specifier-type typespec)))
- (typecase type
- ;; This is all that CMU CL handled.
- (numeric-type (complex1 type))
- ;; We need to handle UNION-TYPEs in order to deal with
- ;; REAL and FLOAT being represented as UNION-TYPEs of more
- ;; primitive types.
+ (not-real))
+ (modified-numeric-type component-type :complexp :complex))
+ (complex-union (component)
+ (unless (numberp component)
+ (not-numeric))
+ ;; KLUDGE: This TYPECASE more or less does
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
+ ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
+ ;; but uses logic cut and pasted from the DEFUN of
+ ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
+ ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
+ ;; would tend to break the code here. Unfortunately,
+ ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
+ ;; would cause another kind of fragility, because
+ ;; ANSI's definition of TYPE-OF is so weak that e.g.
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
+ ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
+ ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
+ ;; So using TYPE-OF would mean that ANSI-conforming
+ ;; maintenance changes in TYPE-OF could break the code here.
+ ;; It's not clear how best to fix this. -- WHN 2002-01-21,
+ ;; trying to summarize CSR's concerns in his patch
+ (typecase component
+ (complex (error "The component type for COMPLEX (EQL X) ~
+ is complex: ~S"
+ component))
+ ((eql 0) (specifier-type nil)) ; as required by ANSI
+ (single-float (specifier-type '(complex single-float)))
+ (double-float (specifier-type '(complex double-float)))
+ #!+long-float
+ (long-float (specifier-type '(complex long-float)))
+ (rational (specifier-type '(complex rational)))
+ (t (specifier-type '(complex real))))))
+ (let ((ctype (specifier-type typespec)))
+ (typecase ctype
+ (numeric-type (complex1 ctype))
(union-type (apply #'type-union
+ ;; FIXME: This code could suffer from
+ ;; (admittedly very obscure) cases of
+ ;; bug 145 e.g. when TYPE is
+ ;; (OR (AND INTEGER (SATISFIES ODDP))
+ ;; (AND FLOAT (SATISFIES FOO))
+ ;; and not even report the problem very well.
(mapcar #'complex1
- (union-type-types type))))
- ;; FIXME: ANSI just says that TYPESPEC is a subtype of type
- ;; REAL, not necessarily a NUMERIC-TYPE. E.g. TYPESPEC could
- ;; legally be (AND REAL (SATISFIES ODDP))! But like the old
- ;; CMU CL code, we're still not nearly that general.
- (t (not-numeric)))))))
+ (union-type-types ctype))))
+ ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
+ ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
+ ;; ANSI, equal to type NIL, the empty set.
+ (member-type (apply #'type-union
+ (mapcar #'complex-union
+ (member-type-members ctype))))
+ (t
+ (multiple-value-bind (subtypep certainly)
+ (csubtypep ctype (specifier-type 'real))
+ (if (and (not subtypep) certainly)
+ (not-real)
+ ;; ANSI just says that TYPESPEC is any subtype of
+ ;; type REAL, not necessarily a NUMERIC-TYPE. In
+ ;; particular, at this point TYPESPEC could legally be
+ ;; an intersection type like (AND REAL (SATISFIES ODDP)),
+ ;; in which case we fall through the logic above and
+ ;; end up here, stumped.
+ (bug "~@<(known bug #145): The type ~S is too hairy to be
+ used for a COMPLEX component.~:@>"
+ typespec)))))))))
;;; If X is *, return NIL, otherwise return the bound, which must be a
;;; member of TYPE or a one-element list of a member of TYPE.