;;; 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))
;; %TYPE-INTERSECTION2, there seems to be no need to distinguish
;; between not finding a method and having a method return NIL.
(flet ((1way (x y)
- (let ((result (!invoke-type-method :simple-union2 :complex-union2
- x y
- :default nil)))
- ;; UNION2 type methods are supposed to return results
- ;; which are better than just brute-forcibly smashing the
- ;; terms together into UNION-TYPEs. But they're derived
- ;; from old CMU CL UNION type methods which played by
- ;; somewhat different rules. Here we check to make sure
- ;; we don't get ambushed by diehard old-style code.
- (assert (not (union-type-p result)))
- result)))
+ (!invoke-type-method :simple-union2 :complex-union2
+ x y
+ :default nil)))
(declare (inline 1way))
(or (1way type1 type2)
(1way type2 type1))))
;;
;; (Why yes, CLOS probably *would* be nicer..)
(flet ((1way (x y)
- (let ((result
- (!invoke-type-method :simple-intersection2
- :complex-intersection2
- x y
- :default :no-type-method-found)))
- ;; INTERSECTION2 type methods are supposed to return
- ;; results which are better than just brute-forcibly
- ;; smashing the terms together into INTERSECTION-TYPEs.
- ;; But they're derived from old CMU CL INTERSECTION type
- ;; methods which played by somewhat different rules. Here
- ;; we check to make sure we don't get ambushed by diehard
- ;; old-style code.
- (assert (not (intersection-type-p result)))
- result)))
+ (!invoke-type-method :simple-intersection2 :complex-intersection2
+ x y
+ :default :no-type-method-found)))
(declare (inline 1way))
(let ((xy (1way type1 type2)))
(or (and (not (eql xy :no-type-method-found)) xy)
(eql yx :no-type-method-found))
*empty-type*)
(t
- (assert (and (not xy) (not yx))) ; else handled above
+ (aver (and (not xy) (not yx))) ; else handled above
nil))))))))
(defun-cached (type-intersection2 :hash-function type-cache-hash
((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)
;;; shared logic for unions and intersections: Stuff TYPE into the
;;; vector TYPES, finding pairs of types which can be simplified by
-;;; SIMPLIFY2 and replacing them by their simplified forms.
-(defun accumulate-compound-type (type types simplify2)
+;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
+;;; by their simplified forms.
+(defun accumulate1-compound-type (type types %compound-type-p simplify2)
(declare (type ctype type))
(declare (type (vector ctype) types))
(declare (type function simplify2))
+ ;; Any input object satisfying %COMPOUND-TYPE-P should've been
+ ;; broken into components before it reached us.
+ (aver (not (funcall %compound-type-p type)))
(dotimes (i (length types) (vector-push-extend type types))
(let ((simplified2 (funcall simplify2 type (aref types i))))
(when simplified2
;; Discard the old (AREF TYPES I).
(setf (aref types i) (vector-pop types))
- ;; Add the new SIMPLIFIED2 to TYPES, by tail recursing.
+ ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
+ ;; (Note that the tail recursion is indirect: we go through
+ ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
+ ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
(return (accumulate-compound-type simplified2
types
+ %compound-type-p
simplify2)))))
+ ;; Voila.
+ (values))
+
+;;; shared logic for unions and intersections: Use
+;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
+;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
+;;; component by component.
+(defun accumulate-compound-type (type types %compound-type-p simplify2)
+ (declare (type function %compound-type-p simplify2))
+ (flet ((accumulate1 (x)
+ (accumulate1-compound-type x types %compound-type-p simplify2)))
+ (declare (inline accumulate1))
+ (if (funcall %compound-type-p type)
+ (map nil #'accumulate1 (compound-type-types type))
+ (accumulate1 type)))
(values))
;;; shared logic for unions and intersections: Return a vector of
;; matter, but helps avoid type
;; warnings at compile time.)
:initial-element *empty-type*)))
- (flet ((accumulate (type)
- (accumulate-compound-type type simplified-types simplify2)))
- (declare (inline accumulate))
- (dolist (type input-types)
- (if (funcall %compound-type-p type)
- (map nil #'accumulate (compound-type-types type))
- (accumulate type))))
+ (dolist (input-type input-types)
+ (accumulate-compound-type input-type
+ simplified-types
+ %compound-type-p
+ simplify2))
simplified-types))
;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
(let ((simplified-types (simplified-compound-types input-types
#'intersection-type-p
#'type-intersection2)))
+ (declare (type (vector ctype) simplified-types))
;; We want to have a canonical representation of types (or failing
;; that, punt to HAIRY-TYPE). Canonical representation would have
;; intersections inside unions but not vice versa, since you can
;; FIXME: BUG 85: This assertion failed when I added it in
;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
;; just commented out.
- ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
(!define-type-method (named :simple-subtypep) (type1 type2)
- (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
- (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)
- (assert (not (hairy-type-p type2)))
+ (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))).
- (assert (not (compound-type-p type2)))
+ ;; (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))
(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
- (assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond ((eq type2 *universal-type*)
(values t t))
((hairy-type-p type1)
(!define-type-method (named :complex-intersection2) (type1 type2)
;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
;; Perhaps when bug 85 is fixed it can be reenabled.
- ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(hierarchical-intersection2 type1 type2))
(!define-type-method (named :complex-union2) (type1 type2)
;; Perhaps when bug 85 is fixed this can be reenabled.
- ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(hierarchical-union2 type1 type2))
(!define-type-method (named :unparse) (x)
\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)
'complex
`(complex ,base+bounds)))
((nil)
- (assert (eq base+bounds 'real))
+ (aver (eq base+bounds 'real))
'number)))))
;;; Return true if X is "less than or equal" to Y, taking open bounds
(setf (info :type :builtin 'number)
(make-numeric-type :complexp nil)))
-(!def-type-translator complex (&optional (spec '*))
- (if (eq spec '*)
+(!def-type-translator complex (&optional (typespec '*))
+ (if (eq typespec '*)
(make-numeric-type :complexp :complex)
- (let ((type (specifier-type spec)))
- (unless (numeric-type-p type)
- (error "The component type for COMPLEX is not numeric: ~S" spec))
- (when (eq (numeric-type-complexp type) :complex)
- (error "The component type for COMPLEX is complex: ~S" spec))
- (let ((res (copy-numeric-type type)))
- (setf (numeric-type-complexp res) :complex)
- res))))
+ (labels ((not-numeric ()
+ ;; FIXME: should probably be TYPE-ERROR
+ (error "The component type for COMPLEX is not numeric: ~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.
+ (union-type (apply #'type-union
+ (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)))))))
;;; 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.
(make-numeric-type :class ',class :format ',format :low lb :high hb))))
(!def-bounded-type rational rational nil)
-(!def-bounded-type float float nil)
-(!def-bounded-type real nil nil)
+
+;;; Unlike CMU CL, we represent the types FLOAT and REAL as
+;;; UNION-TYPEs of more primitive types, in order to make
+;;; type representation more unique, avoiding problems in the
+;;; simplification of things like
+;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1))
+;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0)))
+;;; When we allowed REAL to remain as a separate NUMERIC-TYPE,
+;;; it was too easy for the first argument to be simplified to
+;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified
+;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the
+;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because
+;;; the first argument can't be seen to be a subtype of any of the
+;;; terms in the second argument.
+;;;
+;;; The old CMU CL way was:
+;;; (!def-bounded-type float float nil)
+;;; (!def-bounded-type real nil nil)
+;;;
+;;; FIXME: If this new way works for a while with no weird new
+;;; problems, we can go back and rip out support for separate FLOAT
+;;; and REAL flavors of NUMERIC-TYPE. The new way was added in
+;;; sbcl-0.6.11.22, 2001-03-21.
+;;;
+;;; FIXME: It's probably necessary to do something to fix the
+;;; analogous problem with INTEGER and RATIONAL types. Perhaps
+;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER).
+(defun coerce-bound (bound type inner-coerce-bound-fun)
+ (declare (type function inner-coerce-bound-fun))
+ (cond ((eql bound '*)
+ bound)
+ ((consp bound)
+ (destructuring-bind (inner-bound) bound
+ (list (funcall inner-coerce-bound-fun inner-bound type))))
+ (t
+ (funcall inner-coerce-bound-fun bound type))))
+(defun inner-coerce-real-bound (bound type)
+ (ecase type
+ (rational (rationalize bound))
+ (float (if (floatp bound)
+ bound
+ ;; Coerce to the widest float format available, to
+ ;; avoid unnecessary loss of precision:
+ (coerce bound 'long-float)))))
+(defun coerced-real-bound (bound type)
+ (coerce-bound bound type #'inner-coerce-real-bound))
+(defun coerced-float-bound (bound type)
+ (coerce-bound bound type #'coerce))
+(!def-type-translator real (&optional (low '*) (high '*))
+ (specifier-type `(or (float ,(coerced-real-bound low 'float)
+ ,(coerced-real-bound high 'float))
+ (rational ,(coerced-real-bound low 'rational)
+ ,(coerced-real-bound high 'rational)))))
+(!def-type-translator float (&optional (low '*) (high '*))
+ (specifier-type
+ `(or (single-float ,(coerced-float-bound low 'single-float)
+ ,(coerced-float-bound high 'single-float))
+ (double-float ,(coerced-float-bound low 'double-float)
+ ,(coerced-float-bound high 'double-float))
+ #!+long-float ,(error "stub: no long float support yet"))))
(defmacro !define-float-format (f)
`(!def-bounded-type ,f float ,f))
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)
;;;; ;; reasonable definition
;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
;;;; ;; reasonable behavior
-;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
+;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL))
;;;; Without understanding a little about the semantics of AND, we'd
;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
;;; Similarly, a union type is a subtype of another if every element
;;; of TYPE1 is a subtype of some element of TYPE2.
-;;;
-;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and
-;;; similarly in INTERSECTION-TYPE, with the logic in the
-;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2
-;;; methods. Ideally there's probably some way to make the
-;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO
-;;; methods in such a way that this definition could go away, but I
-;;; don't grok the system well enough to tell whether it's simple to
-;;; arrange this. -- WHN 2000-02-03
(!define-type-method (union :simple-subtypep) (type1 type2)
- (dolist (t1 (union-type-types type1) (values t t))
- (multiple-value-bind (subtypep validp)
- (union-complex-subtypep-arg2 t1 type2)
- (cond ((not validp)
- (return (values nil nil)))
- ((not subtypep)
- (return (values nil t)))))))
+ (every/type (swapped-args-fun #'union-complex-subtypep-arg2)
+ type2
+ (union-type-types type1)))
(defun union-complex-subtypep-arg1 (type1 type2)
(every/type (swapped-args-fun #'csubtypep)
((union-complex-subtypep-arg1 type2 type1)
type2)
(t
+ ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2
+ ;; operations in a particular order, and gives up if any of
+ ;; the sub-unions turn out not to be simple. In other cases
+ ;; ca. sbcl-0.6.11.15, that approach to taking a union was a
+ ;; bad idea, since it can overlook simplifications which
+ ;; might occur if the terms were accumulated in a different
+ ;; order. It's possible that that will be a problem here too.
+ ;; However, I can't think of a good example to demonstrate
+ ;; it, and without an example to demonstrate it I can't write
+ ;; test cases, and without test cases I don't want to
+ ;; complicate the code to address what's still a hypothetical
+ ;; problem. So I punted. -- WHN 2001-03-20
(let ((accumulator *empty-type*))
(dolist (t2 (union-type-types type2) accumulator)
(setf accumulator
(type-union2 accumulator
(type-intersection type1 t2)))
- ;; When our result isn't simple any more
- (when (or
- ;; (TYPE-UNION2 couldn't find a sufficiently simple
- ;; result, so we can't either.)
- (null accumulator)
- ;; (A result containing an intersection isn't
- ;; sufficiently simple for us. FIXME: Maybe it
- ;; should be sufficiently simple for us?
- ;; UNION-TYPEs aren't supposed to be nested inside
- ;; INTERSECTION-TYPEs, so if we punt with NIL,
- ;; we're condemning the expression to become a
- ;; HAIRY-TYPE. If it were possible for us to
- ;; return an INTERSECTION-TYPE, then the
- ;; INTERSECTION-TYPE-TYPES could be merged into
- ;; the outer INTERSECTION-TYPE which may be under
- ;; construction. E.g. if this function could
- ;; return an intersection type, and the calling
- ;; functions were smart enough to handle it, then
- ;; we could simplify (AND (OR FIXNUM KEYWORD)
- ;; SYMBOL) to KEYWORD, even though KEYWORD
- ;; is an intersection type.)
- (intersection-type-p accumulator))
+ ;; When our result isn't simple any more (because
+ ;; TYPE-UNION2 was unable to give us a simple result)
+ (unless accumulator
(return nil)))))))
(!def-type-translator or (&rest type-specifiers)
(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")