(!cold-init-forms (setq *unparse-fun-type-simplify* nil))
(!define-type-method (function :negate) (type)
- (error "NOT FUNCTION too confusing on ~S" (type-specifier type)))
+ (make-negation-type :type type))
(!define-type-method (function :unparse) (type)
(if *unparse-fun-type-simplify*
;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
+(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*)
- (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)))))
+ (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
(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond ((eq type2 *universal-type*)
(values t t))
- ((type-might-contain-other-types-p type1)
+ ((or (type-might-contain-other-types-p type1)
+ (and (cons-type-p type1)
+ (cons-type-might-be-empty-type type1)))
;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
;; disguise. So we'd better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
(if (csubtypep component-type (specifier-type '(eql 0)))
*empty-type*
(modified-numeric-type component-type
- :complexp :complex))))
+ :complexp :complex)))
+ (do-complex (ctype)
+ (cond
+ ((eq ctype *empty-type*) *empty-type*)
+ ((eq ctype *universal-type*) (not-real))
+ ((typep ctype 'numeric-type) (complex1 ctype))
+ ((typep ctype 'union-type)
+ (apply #'type-union
+ (mapcar #'do-complex (union-type-types ctype))))
+ ((typep ctype 'member-type)
+ (apply #'type-union
+ (mapcar (lambda (x) (do-complex (ctype-of x)))
+ (member-type-members ctype))))
+ ((and (typep ctype 'intersection-type)
+ ;; FIXME: This is very much a
+ ;; not-quite-worst-effort, but we are required to do
+ ;; something here because of our representation of
+ ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
+ ;; allow users to ask about (COMPLEX RATIO). This
+ ;; will of course fail to work right on such types
+ ;; as (AND INTEGER (SATISFIES ZEROP))...
+ (let ((numbers (remove-if-not
+ #'numeric-type-p
+ (intersection-type-types ctype))))
+ (and (car numbers)
+ (null (cdr numbers))
+ (eq (numeric-type-complexp (car numbers)) :real)
+ (complex1 (car numbers))))))
+ (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 a hairy type like (AND NUMBER (SATISFIES
+ ;; REALP) (SATISFIES ZEROP)), 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)))))))
(let ((ctype (specifier-type typespec)))
- (cond
- ((eq ctype *empty-type*) *empty-type*)
- ((eq ctype *universal-type*) (not-real))
- ((typep ctype 'numeric-type) (complex1 ctype))
- ((typep 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 ctype))))
- ((typep ctype 'member-type)
- (apply #'type-union
- (mapcar (lambda (x) (complex1 (ctype-of x)))
- (member-type-members ctype))))
- ((and (typep ctype 'intersection-type)
- ;; FIXME: This is very much a
- ;; not-quite-worst-effort, but we are required to do
- ;; something here because of our representation of
- ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
- ;; allow users to ask about (COMPLEX RATIO). This
- ;; will of course fail to work right on such types
- ;; as (AND INTEGER (SATISFIES ZEROP))...
- (let ((numbers (remove-if-not
- #'numeric-type-p
- (intersection-type-types ctype))))
- (and (car numbers)
- (null (cdr numbers))
- (eq (numeric-type-complexp (car numbers)) :real)
- (complex1 (car numbers))))))
- (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 a hairy type like (AND NUMBER (SATISFIES
- ;; REALP) (SATISFIES ZEROP)), 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)))))))))
+ (do-complex ctype)))))
;;; 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.
(if up-p (1+ cx) (1- cx))
(if up-p (ceiling cx) (floor cx))))
(float
- (let ((res (if format (coerce cx format) (float cx))))
+ (let ((res
+ (cond
+ ((and format (subtypep format 'double-float))
+ (if (<= most-negative-double-float cx most-positive-double-float)
+ (coerce cx format)
+ nil))
+ (t
+ (if (<= most-negative-single-float cx most-positive-single-float)
+ (coerce cx format)
+ nil)))))
(if (consp x) (list res) res)))))
nil))
(csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
(if (and val-car val-cdr)
(values t (and win-car win-cdr))
- (values nil (or win-car win-cdr))))))
+ (values nil (or (and (not val-car) win-car)
+ (and (not val-cdr) win-cdr)))))))
;;; Give up if a precise type is not possible, to avoid returning
;;; overly general types.
projects / sbcl.git / blobdiff