;;; than the precise result.
;;;
;;; The return convention seems to be analogous to
-;;; TYPES-INTERSECT. -- WHN 19990910.
+;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910.
(defun-cached (values-type-union :hash-function type-cache-hash
:hash-bits 8
:default nil
#'max
(specifier-type 'null)))))
-;;; This is like TYPES-INTERSECT, except that it sort of works on
-;;; VALUES types. Note that due to the semantics of
+;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
+;;; works on VALUES types. Note that due to the semantics of
;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
-;;; there isn't really any intersection (?).
-;;;
-;;; The return convention seems to be analogous to
-;;; TYPES-INTERSECT. -- WHN 19990910.
-(defun values-types-intersect (type1 type2)
+;;; there isn't really any intersection.
+(defun values-types-equal-or-intersect (type1 type2)
(cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
- (values 't t))
+ (values t t))
((or (values-type-p type1) (values-type-p type2))
(multiple-value-bind (res win) (values-type-intersection type1 type2)
(values (not (eq res *empty-type*))
win)))
(t
- (types-intersect type1 type2))))
+ (types-equal-or-intersect type1 type2))))
;;; a SUBTYPEP-like operation that can be used on any types, including
;;; VALUES types
(cond ((eq type2 *wild-type*) (values t t))
((eq type1 *wild-type*)
(values (eq type2 *universal-type*) t))
- ((not (values-types-intersect type1 type2))
+ ((not (values-types-equal-or-intersect type1 type2))
(values nil t))
(t
(if (or (values-type-p type1) (values-type-p type2))
((hairy-type-p type1) type2)
(t type1)))
-;;; The first value is true unless the types don't intersect. The
-;;; second value is true if the first value is definitely correct. NIL
-;;; is considered to intersect with any type. If T is a subtype of
-;;; either type, then we also return T, T. This way we recognize
-;;; that hairy types might intersect with T.
+;;; a test useful for checking whether a derived type matches a
+;;; declared type
;;;
-;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT,
-;;; and rename VALUES-TYPES-INTERSECT the same way.
-(defun types-intersect (type1 type2)
+;;; The first value is true unless the types don't intersect and
+;;; aren't equal. The second value is true if the first value is
+;;; definitely correct. NIL is considered to intersect with any type.
+;;; If T is a subtype of either type, then we also return T, T. This
+;;; way we recognize that hairy types might intersect with T.
+(defun types-equal-or-intersect (type1 type2)
(declare (type ctype type1 type2))
(if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
(values t t)
(aver (not (hairy-type-p type2)))
;; Besides the old CMU CL assertion above, we also need to avoid
;; compound types, else we could get into trouble with
- ;; (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR)))
;; or
- ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))).
+ ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))).
(aver (not (compound-type-p type2)))
;; Then, since TYPE2 is reasonably tractable, we're good to go.
(values (eq type1 *empty-type*) t))
\f
;;;; numeric types
-#!+negative-zero-is-not-zero
-(defun make-numeric-type (&key class format (complexp :real) low high
- enumerable)
- (flet ((canonicalise-low-bound (x)
- ;; Canonicalise a low bound of (-0.0) to 0.0.
- (if (and (consp x) (floatp (car x)) (zerop (car x))
- (minusp (float-sign (car x))))
- (float 0.0 (car x))
- x))
- (canonicalise-high-bound (x)
- ;; Canonicalise a high bound of (+0.0) to -0.0.
- (if (and (consp x) (floatp (car x)) (zerop (car x))
- (plusp (float-sign (car x))))
- (float -0.0 (car x))
- x)))
- (%make-numeric-type :class class
- :format format
- :complexp complexp
- :low (canonicalise-low-bound low)
- :high (canonicalise-high-bound high)
- :enumerable enumerable)))
-
(!define-type-class number)
(!define-type-method (number :simple-=) (type1 type2)
(when (eq (numeric-type-complexp component-type) :complex)
(error "The component type for COMPLEX is complex: ~S"
typespec))
- (let ((result (copy-numeric-type component-type)))
- (setf (numeric-type-complexp result) :complex)
- result)))
+ (modified-numeric-type component-type :complexp :complex)))
(let ((type (specifier-type typespec)))
(typecase type
;; This is all that CMU CL handled.
nil))
;;; Handle the case of type intersection on two numeric types. We use
-;;; TYPES-INTERSECT to throw out the case of types with no
+;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no
;;; intersection. If an attribute in TYPE1 is unspecified, then we use
;;; TYPE2's attribute, which must be at least as restrictive. If the
;;; types intersect, then the only attributes that can be specified
;;; subtype of the MEMBER type.
(!define-type-method (member :complex-subtypep-arg2) (type1 type2)
(cond ((not (type-enumerable type1)) (values nil t))
- ((types-intersect type1 type2) (values nil nil))
+ ((types-equal-or-intersect type1 type2) (values nil nil))
(t (values nil t))))
(!define-type-method (member :simple-intersection2) (type1 type2)
(multiple-value-bind (val win) (csubtypep x-type y-type)
(unless win (return-from type-difference nil))
(when val (return))
- (when (types-intersect x-type y-type)
+ (when (types-equal-or-intersect x-type y-type)
(return-from type-difference nil))))))
(let ((y-mem (find-if #'member-type-p y-types)))
(when y-mem
:element-type (specifier-type element-type)
:complexp nil)))
\f
+;;;; utilities shared between cross-compiler and target system
+
+;;; Does the type derived from compilation of an actual function
+;;; definition satisfy declarations of a function's type?
+(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype)
+ (declare (type ctype defined-ftype declared-ftype))
+ (flet ((is-built-in-class-function-p (ctype)
+ (and (built-in-class-p ctype)
+ (eq (built-in-class-%name ctype) 'function))))
+ (cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
+ ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
+ (is-built-in-class-function-p declared-ftype)
+ ;; In that case, any definition satisfies the declaration.
+ t)
+ (;; It's not clear whether or how DEFINED-FTYPE might be
+ ;; #<BUILT-IN-CLASS FUNCTION>, but it's not obviously
+ ;; invalid, so let's handle that case too, just in case.
+ (is-built-in-class-function-p defined-ftype)
+ ;; No matter what DECLARED-FTYPE might be, we can't prove
+ ;; that an object of type FUNCTION doesn't satisfy it, so
+ ;; we return success no matter what.
+ t)
+ (;; Otherwise both of them must be FUNCTION-TYPE objects.
+ t
+ ;; FIXME: For now we only check compatibility of the return
+ ;; type, not argument types, and we don't even check the
+ ;; return type very precisely (as per bug 94a). It would be
+ ;; good to do a better job. Perhaps to check the
+ ;; compatibility of the arguments, we should (1) redo
+ ;; VALUES-TYPES-EQUAL-OR-INTERSECT as
+ ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to
+ ;; the ARGS-TYPE slices of the FUNCTION-TYPEs. (ARGS-TYPE
+ ;; is a base class both of VALUES-TYPE and of FUNCTION-TYPE.)
+ (values-types-equal-or-intersect
+ (function-type-returns defined-ftype)
+ (function-type-returns declared-ftype))))))
+
+;;; This messy case of CTYPE for NUMBER is shared between the
+;;; cross-compiler and the target system.
+(defun ctype-of-number (x)
+ (let ((num (if (complexp x) (realpart x) x)))
+ (multiple-value-bind (complexp low high)
+ (if (complexp x)
+ (let ((imag (imagpart x)))
+ (values :complex (min num imag) (max num imag)))
+ (values :real num num))
+ (make-numeric-type :class (etypecase num
+ (integer 'integer)
+ (rational 'rational)
+ (float 'float))
+ :format (and (floatp num) (float-format-name num))
+ :complexp complexp
+ :low low
+ :high high))))
+\f
(!defun-from-collected-cold-init-forms !late-type-cold-init)
(/show0 "late-type.lisp end of file")