(in-package "SB!KERNEL")
+(/show0 "late-type.lisp 19")
+
(!begin-collecting-cold-init-forms)
;;; ### Remaining incorrectnesses:
(if subtypep-arg1
(funcall subtypep-arg1 type1 type2)
(values nil t))))
-(defun delegate-complex-intersection (type1 type2)
- (let ((method (type-class-complex-intersection (type-class-info type1))))
- (if (and method (not (eq method #'delegate-complex-intersection)))
+(defun delegate-complex-intersection2 (type1 type2)
+ (let ((method (type-class-complex-intersection2 (type-class-info type1))))
+ (if (and method (not (eq method #'delegate-complex-intersection2)))
(funcall method type2 type1)
- (vanilla-intersection type1 type2))))
-
-;;; This is used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
-;;; method. INFO is a list of conses (SUPERCLASS-CLASS .
-;;; {GUARD-TYPE-SPECIFIER | NIL}). This will never be called with a
-;;; hairy type as TYPE2, since the hairy type TYPE2 method gets first
-;;; crack.
-;;;
-;;; FIXME: Declare this as INLINE, since it's only used in one place.
-(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info)
+ (hierarchical-intersection2 type1 type2))))
+
+;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
+;;; method. INFO is a list of conses
+;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
+;;; This will never be called with a hairy type as TYPE2, since the
+;;; hairy type TYPE2 method gets first crack.
+(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info)
(values
(and (sb!xc:typep type2 'sb!xc:class)
(dolist (x info nil)
;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))).
;;;
;;; WHEN controls when the forms are executed.
-(defmacro define-superclasses (type-class-name specs when)
+(defmacro !define-superclasses (type-class-name specs when)
(let ((type-class (gensym "TYPE-CLASS-"))
(info (gensym "INFO")))
`(,when
',specs)))
(setf (type-class-complex-subtypep-arg1 ,type-class)
(lambda (type1 type2)
- (has-superclasses-complex-subtypep-arg1 type1 type2 ,info)))
+ (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info)))
(setf (type-class-complex-subtypep-arg2 ,type-class)
#'delegate-complex-subtypep-arg2)
- (setf (type-class-complex-intersection ,type-class)
- #'delegate-complex-intersection)))))
+ (setf (type-class-complex-intersection2 ,type-class)
+ #'delegate-complex-intersection2)))))
\f
;;;; FUNCTION and VALUES types
;;;;
;;;; -- Many of the places that can be annotated with real types can
;;;; also be annotated with function or values types.
-;;; the description of a keyword argument
-(defstruct (key-info #-sb-xc-host (:pure t))
- ;; the keyword
- (name (required-argument) :type keyword)
+;;; the description of a &KEY argument
+(defstruct (key-info #-sb-xc-host (:pure t)
+ (:copier nil))
+ ;; the key (not necessarily a keyword in ANSI)
+ (name (required-argument) :type symbol)
;; the type of the argument value
(type (required-argument) :type ctype))
-(define-type-method (values :simple-subtypep :complex-subtypep-arg1)
- (type1 type2)
+(!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
+ (type1 type2)
(declare (ignore type2))
- (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1)))
+ ;; FIXME: should be TYPE-ERROR, here and in next method
+ (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1)))
-(define-type-method (values :complex-subtypep-arg2)
- (type1 type2)
+(!define-type-method (values :complex-subtypep-arg2)
+ (type1 type2)
(declare (ignore type1))
- (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2)))
+ (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2)))
-(define-type-method (values :unparse) (type)
+(!define-type-method (values :unparse) (type)
(cons 'values (unparse-args-types type)))
;;; Return true if LIST1 and LIST2 have the same elements in the same
(unless val
(return (values nil t))))))
-(define-type-method (values :simple-=) (type1 type2)
+(!define-type-method (values :simple-=) (type1 type2)
(let ((rest1 (args-type-rest type1))
(rest2 (args-type-rest type2)))
(cond ((or (args-type-keyp type1) (args-type-keyp type2)
(values-type-optional type2))
(values (and req-val opt-val) (and req-win opt-win))))))))
-(define-type-class function)
+(!define-type-class function)
;;; a flag that we can bind to cause complex function types to be
;;; unparsed as FUNCTION. This is useful when we want a type that we
(defvar *unparse-function-type-simplify*)
(!cold-init-forms (setq *unparse-function-type-simplify* nil))
-(define-type-method (function :unparse) (type)
+(!define-type-method (function :unparse) (type)
(if *unparse-function-type-simplify*
'function
(list 'function
;;; Since all function types are equivalent to FUNCTION, they are all
;;; subtypes of each other.
-(define-type-method (function :simple-subtypep) (type1 type2)
+(!define-type-method (function :simple-subtypep) (type1 type2)
(declare (ignore type1 type2))
(values t t))
-(define-superclasses function ((function)) !cold-init-forms)
+(!define-superclasses function ((function)) !cold-init-forms)
;;; The union or intersection of two FUNCTION types is FUNCTION.
-(define-type-method (function :simple-union) (type1 type2)
+(!define-type-method (function :simple-union2) (type1 type2)
(declare (ignore type1 type2))
(specifier-type 'function))
-(define-type-method (function :simple-intersection) (type1 type2)
+(!define-type-method (function :simple-intersection2) (type1 type2)
(declare (ignore type1 type2))
- (values (specifier-type 'function) t))
+ (specifier-type 'function))
;;; ### Not very real, but good enough for redefining transforms
;;; according to type:
-(define-type-method (function :simple-=) (type1 type2)
+(!define-type-method (function :simple-=) (type1 type2)
(values (equalp type1 type2) t))
-(define-type-class constant :inherits values)
+(!define-type-class constant :inherits values)
-(define-type-method (constant :unparse) (type)
+(!define-type-method (constant :unparse) (type)
`(constant-argument ,(type-specifier (constant-type-type type))))
-(define-type-method (constant :simple-=) (type1 type2)
+(!define-type-method (constant :simple-=) (type1 type2)
(type= (constant-type-type type1) (constant-type-type type2)))
-(def-type-translator constant-argument (type)
+(!def-type-translator constant-argument (type)
(make-constant-type :type (specifier-type type)))
;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
(multiple-value-bind (required optional restp rest keyp keys allowp aux)
(parse-lambda-list lambda-list)
(when aux
- (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
+ (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
(setf (args-type-required result) (mapcar #'specifier-type required))
(setf (args-type-optional result) (mapcar #'specifier-type optional))
(setf (args-type-rest result) (if restp (specifier-type rest) nil))
(error "Keyword type description is not a two-list: ~S." key))
(let ((kwd (first key)))
(when (find kwd (key-info) :key #'key-info-name)
- (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
+ (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
+ kwd lambda-list))
(key-info (make-key-info :name kwd
:type (specifier-type (second key))))))
(setf (args-type-keywords result) (key-info)))
(result)))
-(def-type-translator function (&optional (args '*) (result '*))
+(!def-type-translator function (&optional (args '*) (result '*))
(let ((res (make-function-type
:returns (values-specifier-type result))))
(if (eq args '*)
(parse-args-types args res))
res))
-(def-type-translator values (&rest values)
+(!def-type-translator values (&rest values)
(let ((res (make-values-type)))
(parse-args-types values res)
res))
;;;; We provide a few special operations that can be meaningfully used
;;;; on VALUES types (as well as on any other type).
-;;; Return the type of the first value indicated by Type. This is used
-;;; by people who don't want to have to deal with values types.
-
-;;; MNA: fix-instance-typep-call patch
+;;; Return the type of the first value indicated by TYPE. This is used
+;;; by people who don't want to have to deal with VALUES types.
#!-sb-fluid (declaim (freeze-type values-type))
; (inline single-value-type))
(defun single-value-type (type)
(cond ((values-type-p type)
(or (car (args-type-required type))
(if (args-type-optional type)
- (type-union (car (args-type-optional type)) (specifier-type 'null)))
+ (type-union (car (args-type-optional type))
+ (specifier-type 'null)))
(args-type-rest type)
(specifier-type 'null)))
((eq type *wild-type*)
(t
type)))
-;;; Return the minmum number of arguments that a function can be
+;;; Return the minimum number of arguments that a function can be
;;; called with, and the maximum number or NIL. If not a function
;;; type, return NIL, NIL.
(defun function-type-nargs (type)
(values fixed (+ fixed (length (args-type-optional type))))))
(values nil nil)))
-;;; Determine if Type corresponds to a definite number of values. The
-;;; first value is a list of the types for each value, and the second
-;;; value is the number of values. If the number of values is not
-;;; fixed, then return NIL and :Unknown.
+;;; Determine whether TYPE corresponds to a definite number of values.
+;;; The first value is a list of the types for each value, and the
+;;; second value is the number of values. If the number of values is
+;;; not fixed, then return NIL and :UNKNOWN.
(defun values-types (type)
(declare (type ctype type))
(cond ((eq type *wild-type*)
(values (mapcar #'single-value-type req) (length req))))))
;;; Return two values:
-;;; MNA: fix-instance-typep-call patch
;;; 1. A list of all the positional (fixed and optional) types.
-;;; 2] The rest type (if any). If keywords allowed, *universal-type*.
-;;; If no keywords or rest then the default-type.
+;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
+;;; If no keywords or &REST, then the DEFAULT-TYPE.
(defun values-type-types (type &optional (default-type *empty-type*))
(declare (type values-type type))
(values (append (args-type-required type)
(cond ((args-type-keyp type) *universal-type*)
((args-type-rest type))
(t
- ;; MNA: fix-instance-typep-call patch
- default-type))))
+ default-type))))
;;; Return a list of OPERATION applied to the types in TYPES1 and
;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
;;; This has the virtue of always keeping the VALUES type specifier
;;; outermost, and retains all of the information that is really
;;; useful for static type analysis. We want to know what is always
-;;; true of each value independently. It is worthless to know that IF
+;;; true of each value independently. It is worthless to know that if
;;; the first value is B0 then the second will be B1.
;;;
;;; If the VALUES count signatures differ, then we produce a result with
;;; OPERATION returned true as its second value each time we called
;;; it. Since we approximate the intersection of VALUES types, the
;;; second value being true doesn't mean the result is exact.
-;;; MNA: fix-instance-typep-call patch
(defun args-type-op (type1 type2 operation nreq default-type)
- ;;; MNA: fix-instance-typep-call patch
(declare (type ctype type1 type2 default-type)
(type function operation nreq))
(if (or (values-type-p type1) (values-type-p type2))
(let ((type1 (coerce-to-values type1))
(type2 (coerce-to-values type2)))
(multiple-value-bind (types1 rest1)
- ;;; MNA: fix-instance-typep-call patch
(values-type-types type1 default-type)
(multiple-value-bind (types2 rest2)
- ;;; MNA: fix-instance-typep-call patch
(values-type-types type2 default-type)
(multiple-value-bind (rest rest-exact)
(funcall operation rest1 rest2)
:optional (if opt-last
(subseq opt 0 (1+ opt-last))
())
- ;; MNA fix-instance-typep-call patch
:rest (if (eq rest default-type) nil rest))
(and rest-exact res-exact)))))))))
(funcall operation type1 type2)))
;;; 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
((eq type1 *empty-type*) type2)
((eq type2 *empty-type*) type1)
(t
- ;;; MNA: fix-instance-typep-call patch
(values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
-;;;
(defun-cached (values-type-intersection :hash-function type-cache-hash
:hash-bits 8
:values 2
(cond ((eq type1 *wild-type*) (values type2 t))
((eq type2 *wild-type*) (values type1 t))
(t
- (args-type-op type1 type2 #'type-intersection #'max (specifier-type 'null)))))
+ (args-type-op type1 type2
+ #'type-intersection
+ #'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))
(eq type2 *empty-type*))
(values nil t))
(t
- (invoke-type-method :simple-subtypep :complex-subtypep-arg2
- type1 type2
- :complex-arg1 :complex-subtypep-arg1))))
+ (!invoke-type-method :simple-subtypep :complex-subtypep-arg2
+ type1 type2
+ :complex-arg1 :complex-subtypep-arg1))))
;;; Just parse the type specifiers and call CSUBTYPE.
(defun sb!xc:subtypep (type1 type2)
(declare (type ctype type1 type2))
(if (eq type1 type2)
(values t t)
- (invoke-type-method :simple-= :complex-= type1 type2)))
+ (!invoke-type-method :simple-= :complex-= type1 type2)))
;;; Not exactly the negation of TYPE=, since when the relationship is
;;; uncertain, we still return NIL, NIL. This is useful in cases where
(values (not res) t)
(values nil nil))))
+;;; the type method dispatch case of TYPE-UNION2
+(defun %type-union2 (type1 type2)
+ ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give
+ ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike
+ ;; %TYPE-INTERSECTION2, though, I don't have a specific case which
+ ;; demonstrates this is actually necessary. Also unlike
+ ;; %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)
+ (!invoke-type-method :simple-union2 :complex-union2
+ x y
+ :default nil)))
+ (declare (inline 1way))
+ (or (1way type1 type2)
+ (1way type2 type1))))
+
;;; Find a type which includes both types. Any inexactness is
;;; represented by the fuzzy element types; we return a single value
;;; that is precise to the best of our knowledge. This result is
-;;; simplified into the canonical form, thus is not a UNION type
-;;; unless there is no other way to represent the result.
-(defun-cached (type-union :hash-function type-cache-hash
- :hash-bits 8
- :init-wrapper !cold-init-forms)
+;;; simplified into the canonical form, thus is not a UNION-TYPE
+;;; unless we find no other way to represent the result.
+(defun-cached (type-union2 :hash-function type-cache-hash
+ :hash-bits 8
+ :init-wrapper !cold-init-forms)
((type1 eq) (type2 eq))
+ ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And
+ ;; Paste technique of programming. If it stays around (as opposed to
+ ;; e.g. fading away in favor of some CLOS solution) the shared logic
+ ;; should probably become shared code. -- WHN 2001-03-16
(declare (type ctype type1 type2))
- (if (eq type1 type2)
- type1
- (let ((res (invoke-type-method :simple-union :complex-union
- type1 type2
- :default :vanilla)))
- (cond ((eq res :vanilla)
- (or (vanilla-union type1 type2)
- (make-union-type (list type1 type2))))
- (res)
- (t
- (make-union-type (list type1 type2)))))))
-
-;;; Return as restrictive a type as we can discover that is no more
-;;; restrictive than the intersection of Type1 and Type2. The second
-;;; value is true if the result is exact. At worst, we randomly return
-;;; one of the arguments as the first value (trying not to return a
-;;; hairy type).
-(defun-cached (type-intersection :hash-function type-cache-hash
- :hash-bits 8
- :values 2
- :default (values nil :empty)
- :init-wrapper !cold-init-forms)
+ (cond ((eq type1 type2)
+ type1)
+ ((or (union-type-p type1)
+ (union-type-p type2))
+ ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES
+ ;; values broken out and united separately. The full TYPE-UNION
+ ;; function knows how to do this, so let it handle it.
+ (type-union type1 type2))
+ (t
+ ;; the ordinary case: we dispatch to type methods
+ (%type-union2 type1 type2))))
+
+;;; the type method dispatch case of TYPE-INTERSECTION2
+(defun %type-intersection2 (type1 type2)
+ ;; We want to give both argument orders a chance at
+ ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type
+ ;; methods could give noncommutative results, e.g.
+ ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE)
+ ;; => NIL, NIL
+ ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*)
+ ;; => #<NAMED-TYPE NIL>, T
+ ;; We also need to distinguish between the case where we found a
+ ;; type method, and it returned NIL, and the case where we fell
+ ;; through without finding any type method. An example of the first
+ ;; case is the intersection of a HAIRY-TYPE with some ordinary type.
+ ;; An example of the second case is the intersection of two
+ ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and
+ ;; ARRAY.
+ ;;
+ ;; (Why yes, CLOS probably *would* be nicer..)
+ (flet ((1way (x y)
+ (!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)
+ (let ((yx (1way type2 type1)))
+ (or (and (not (eql yx :no-type-method-found)) yx)
+ (cond ((and (eql xy :no-type-method-found)
+ (eql yx :no-type-method-found))
+ *empty-type*)
+ (t
+ (aver (and (not xy) (not yx))) ; else handled above
+ nil))))))))
+
+(defun-cached (type-intersection2 :hash-function type-cache-hash
+ :hash-bits 8
+ :values 1
+ :default nil
+ :init-wrapper !cold-init-forms)
((type1 eq) (type2 eq))
(declare (type ctype type1 type2))
- (if (eq type1 type2)
- (values type1 t)
- (invoke-type-method :simple-intersection :complex-intersection
- type1 type2
- :default (values *empty-type* t))))
-
-;;; 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 consider hairy
-;;; types to intersect with T.
-(defun types-intersect (type1 type2)
+ (cond ((eq type1 type2)
+ type1)
+ ((or (intersection-type-p type1)
+ (intersection-type-p type2))
+ ;; Intersections of INTERSECTION-TYPE should have the
+ ;; INTERSECTION-TYPE-TYPES values broken out and intersected
+ ;; separately. The full TYPE-INTERSECTION function knows how
+ ;; to do that, so let it handle it.
+ (type-intersection type1 type2))
+ (t
+ ;; the ordinary case: we dispatch to type methods
+ (%type-intersection2 type1 type2))))
+
+;;; Return as restrictive and simple a type as we can discover that is
+;;; no more restrictive than the intersection of TYPE1 and TYPE2. At
+;;; worst, we arbitrarily return one of the arguments as the first
+;;; value (trying not to return a hairy type).
+(defun type-approx-intersection2 (type1 type2)
+ (cond ((type-intersection2 type1 type2))
+ ((hairy-type-p type1) type2)
+ (t type1)))
+
+;;; a test useful for checking whether a derived type matches a
+;;; declared type
+;;;
+;;; 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)
- (multiple-value-bind (val winp) (type-intersection type1 type2)
- (cond ((not winp)
+ (let ((intersection2 (type-intersection2 type1 type2)))
+ (cond ((not intersection2)
(if (or (csubtypep *universal-type* type1)
(csubtypep *universal-type* type2))
(values t t)
(values t nil)))
- ((eq val *empty-type*) (values nil t))
+ ((eq intersection2 *empty-type*) (values nil t))
(t (values t t))))))
;;; Return a Common Lisp type specifier corresponding to the TYPE
;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
;;; early-type.lisp by WHN ca. 19990201.)
-;;; Take a list of type specifiers, compute the translation and define
-;;; it as a builtin type.
+;;; Take a list of type specifiers, computing the translation of each
+;;; specifier and defining it as a builtin type.
(declaim (ftype (function (list) (values)) precompute-types))
(defun precompute-types (specs)
(dolist (spec specs)
(setf (info :type :kind spec) :primitive))))
(values))
\f
+;;;; general TYPE-UNION and TYPE-INTERSECTION operations
+;;;;
+;;;; These are fully general operations on CTYPEs: they'll always
+;;;; return a CTYPE representing the result.
+
+;;; shared logic for unions and intersections: Stuff TYPE into the
+;;; vector TYPES, finding pairs of types which can be simplified by
+;;; 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))
+ ;; 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
+;;; types representing the same types as INPUT-TYPES, but with
+;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
+;;; component types, and with any SIMPLY2 simplifications applied.
+(defun simplified-compound-types (input-types %compound-type-p simplify2)
+ (let ((simplified-types (make-array (length input-types)
+ :fill-pointer 0
+ :element-type 'ctype
+ ;; (This INITIAL-ELEMENT shouldn't
+ ;; matter, but helps avoid type
+ ;; warnings at compile time.)
+ :initial-element *empty-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
+;;; object whose components are the types in TYPES, or skip to special
+;;; cases when TYPES is short.
+(defun make-compound-type-or-something (constructor types enumerable identity)
+ (declare (type function constructor))
+ (declare (type (vector ctype) types))
+ (declare (type ctype identity))
+ (case (length types)
+ (0 identity)
+ (1 (aref types 0))
+ (t (funcall constructor
+ enumerable
+ ;; FIXME: This should be just (COERCE TYPES 'LIST), but as
+ ;; of sbcl-0.6.11.17 the COERCE optimizer is really
+ ;; brain-dead, so that would generate a full call to
+ ;; SPECIFIER-TYPE at runtime, so we get into bootstrap
+ ;; problems in cold init because 'LIST is a compound
+ ;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING
+ ;; before we know what 'LIST is. Once the COERCE
+ ;; optimizer is less brain-dead, we can make this
+ ;; (COERCE TYPES 'LIST) again.
+ #+sb-xc-host (coerce types 'list)
+ #-sb-xc-host (coerce-to-list types)))))
+
+(defun type-intersection (&rest input-types)
+ (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
+ ;; always achieve that by the distributive rule. But we don't want
+ ;; to just apply the distributive rule, since it would be too easy
+ ;; to end up with unreasonably huge type expressions. So instead
+ ;; we punt to HAIRY-TYPE when this comes up.
+ (if (and (> (length simplified-types) 1)
+ (some #'union-type-p simplified-types))
+ (make-hairy-type
+ :specifier `(and ,@(map 'list #'type-specifier simplified-types)))
+ (make-compound-type-or-something #'%make-intersection-type
+ simplified-types
+ (some #'type-enumerable
+ simplified-types)
+ *universal-type*))))
+
+(defun type-union (&rest input-types)
+ (let ((simplified-types (simplified-compound-types input-types
+ #'union-type-p
+ #'type-union2)))
+ (make-compound-type-or-something #'%make-union-type
+ simplified-types
+ (every #'type-enumerable simplified-types)
+ *empty-type*)))
+\f
;;;; built-in types
-(define-type-class named)
+(!define-type-class named)
(defvar *wild-type*)
(defvar *empty-type*)
(frob nil *empty-type*)
(frob t *universal-type*)))
-(define-type-method (named :simple-=) (type1 type2)
+(!define-type-method (named :simple-=) (type1 type2)
+ ;; 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.
+ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
-(define-type-method (named :simple-subtypep) (type1 type2)
+(!define-type-method (named :simple-subtypep) (type1 type2)
+ (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 (hairy-type-p type2)))
+(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
+ (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..)
+ (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)))
+ ;; or
+ ;; (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)
- (if (hairy-type-p type1)
- (values nil nil)
- (values (not (eq type2 *empty-type*)) t)))
-
-(define-type-method (named :complex-intersection) (type1 type2)
- (vanilla-intersection type1 type2))
-
-(define-type-method (named :unparse) (x)
+(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
+ (aver (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type2 *universal-type*)
+ (values t t))
+ ((hairy-type-p type1)
+ (values nil nil))
+ (t
+ ;; FIXME: This seems to rely on there only being 2 or 3
+ ;; HAIRY-TYPE values, and the exclusion of various
+ ;; possibilities above. It would be good to explain it and/or
+ ;; rewrite it so that it's clearer.
+ (values (not (eq type2 *empty-type*)) t))))
+
+(!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.
+ ;;(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.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (hierarchical-union2 type1 type2))
+
+(!define-type-method (named :unparse) (x)
(named-type-name x))
\f
;;;; hairy and unknown types
-(define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
+(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
-(define-type-method (hairy :simple-subtypep) (type1 type2)
+(!define-type-method (hairy :simple-subtypep) (type1 type2)
(let ((hairy-spec1 (hairy-type-specifier type1))
(hairy-spec2 (hairy-type-specifier type2)))
(cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
(t
(values nil nil)))))
-(define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
+(!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
(let ((hairy-spec (hairy-type-specifier type2)))
(cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
- (multiple-value-bind (val win)
- (type-intersection type1 (specifier-type (cadr hairy-spec)))
- (if win
- (values (eq val *empty-type*) t)
+ (let* ((complement-type2 (specifier-type (cadr hairy-spec)))
+ (intersection2 (type-intersection2 type1
+ complement-type2)))
+ (if intersection2
+ (values (eq intersection2 *empty-type*) t)
(values nil nil))))
(t
(values nil nil)))))
-(define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
(declare (ignore type1 type2))
(values nil nil))
-(define-type-method (hairy :simple-intersection :complex-intersection)
- (type1 type2)
- (declare (ignore type2))
- (values type1 nil))
-
-(define-type-method (hairy :complex-union) (type1 type2)
- (make-union-type (list type1 type2)))
+(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ (declare (ignore type1 type2))
+ nil)
-(define-type-method (hairy :simple-=) (type1 type2)
+(!define-type-method (hairy :simple-=) (type1 type2)
(if (equal (hairy-type-specifier type1)
(hairy-type-specifier type2))
(values t t)
(values nil nil)))
-(def-type-translator not (&whole whole type)
+(!def-type-translator not (&whole whole type)
(declare (ignore type))
+ ;; 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))
-(def-type-translator satisfies (&whole whole fun)
+(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
+ ;; Check legality of arguments.
+ (destructuring-bind (satisfies predicate-name) whole
+ (declare (ignore satisfies))
+ (unless (symbolp predicate-name)
+ (error 'simple-type-error
+ :datum predicate-name
+ :expected-type 'symbol
+ :format-control "~S is not a symbol."
+ :format-arguments (list predicate-name))))
+ ;; Create object.
(make-hairy-type :specifier whole))
\f
;;;; numeric types
-;;; A list of all the float formats, in order of decreasing precision.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant float-formats
- '(long-float double-float single-float short-float)))
-
-;;; The type of a float format.
-(deftype float-format () `(member ,@float-formats))
+(!define-type-class number)
-#!+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)
+(!define-type-method (number :simple-=) (type1 type2)
(values
(and (eq (numeric-type-class type1) (numeric-type-class type2))
(eq (numeric-type-format type1) (numeric-type-format type2))
(equal (numeric-type-high type1) (numeric-type-high type2)))
t))
-(define-type-method (number :unparse) (type)
+(!define-type-method (number :unparse) (type)
(let* ((complexp (numeric-type-complexp type))
(low (numeric-type-low type))
(high (numeric-type-high type))
'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
(if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
(if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
-(define-type-method (number :simple-subtypep) (type1 type2)
+(!define-type-method (number :simple-subtypep) (type1 type2)
(let ((class1 (numeric-type-class type1))
(class2 (numeric-type-class type2))
(complexp2 (numeric-type-complexp type2))
(t
(values nil t)))))
-(define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((generic-number)) !cold-init-forms)
;;; If the high bound of LOW is adjacent to the low bound of HIGH,
;;; then return true, otherwise NIL.
;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
;;;
-;;; ### Note: we give up early, so keep from dropping lots of information on
+;;; ### Note: we give up early to keep from dropping lots of information on
;;; the floor by returning overly general types.
-(define-type-method (number :simple-union) (type1 type2)
+(!define-type-method (number :simple-union2) (type1 type2)
(declare (type numeric-type type1 type2))
(cond ((csubtypep type1 type2) type2)
((csubtypep type2 type1) type1)
(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 "Component type for Complex is not numeric: ~S." spec))
- (when (eq (numeric-type-complexp type) :complex)
- (error "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.
type
bound))))
-(def-type-translator integer (&optional (low '*) (high '*))
+(!def-type-translator integer (&optional (low '*) (high '*))
(let* ((l (canonicalized-bound low 'integer))
(lb (if (consp l) (1+ (car l)) l))
(h (canonicalized-bound high 'integer))
:low lb
:high hb)))
-(defmacro def-bounded-type (type class format)
- `(def-type-translator ,type (&optional (low '*) (high '*))
+(defmacro !def-bounded-type (type class format)
+ `(!def-type-translator ,type (&optional (low '*) (high '*))
(let ((lb (canonicalized-bound low ',type))
(hb (canonicalized-bound high ',type)))
(unless (numeric-bound-test* lb hb <= <)
(error "Lower bound ~S is not less than upper bound ~S." low high))
(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)
-
-(defmacro define-float-format (f)
- `(def-bounded-type ,f float ,f))
-
-(define-float-format short-float)
-(define-float-format single-float)
-(define-float-format double-float)
-(define-float-format long-float)
+(!def-bounded-type rational rational 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))
+
+(!define-float-format short-float)
+(!define-float-format single-float)
+(!define-float-format double-float)
+(!define-float-format long-float)
(defun numeric-types-intersect (type1 type2)
(declare (type numeric-type type1 type2))
(if (consp x) (list res) res)))))
nil))
-;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use
-;;; TYPES-INTERSECT to throw out the case of types with no
+;;; Handle the case of type intersection on two numeric types. We use
+;;; 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
;;; appropriate numeric type before maximizing. This avoids possible
;;; confusion due to mixed-type comparisons (but I think the result is
;;; the same).
-(define-type-method (number :simple-intersection) (type1 type2)
+(!define-type-method (number :simple-intersection2) (type1 type2)
(declare (type numeric-type type1 type2))
(if (numeric-types-intersect type1 type2)
(let* ((class1 (numeric-type-class type1))
'rational))))
(format (or (numeric-type-format type1)
(numeric-type-format type2))))
- (values
- (make-numeric-type
- :class class
- :format format
- :complexp (or (numeric-type-complexp type1)
- (numeric-type-complexp type2))
- :low (numeric-bound-max
- (round-numeric-bound (numeric-type-low type1)
- class format t)
- (round-numeric-bound (numeric-type-low type2)
- class format t)
- > >= nil)
- :high (numeric-bound-max
- (round-numeric-bound (numeric-type-high type1)
- class format nil)
- (round-numeric-bound (numeric-type-high type2)
- class format nil)
- < <= nil))
- t))
- (values *empty-type* t)))
+ (make-numeric-type
+ :class class
+ :format format
+ :complexp (or (numeric-type-complexp type1)
+ (numeric-type-complexp type2))
+ :low (numeric-bound-max
+ (round-numeric-bound (numeric-type-low type1)
+ class format t)
+ (round-numeric-bound (numeric-type-low type2)
+ class format t)
+ > >= nil)
+ :high (numeric-bound-max
+ (round-numeric-bound (numeric-type-high type1)
+ class format nil)
+ (round-numeric-bound (numeric-type-high type2)
+ class format nil)
+ < <= nil)))
+ *empty-type*))
;;; Given two float formats, return the one with more precision. If
;;; either one is null, return NIL.
(defun float-format-max (f1 f2)
(when (and f1 f2)
- (dolist (f float-formats (error "Bad float format: ~S." f1))
+ (dolist (f *float-formats* (error "bad float format: ~S" f1))
(when (or (eq f f1) (eq f f2))
(return f)))))
-;;; Return the result of an operation on Type1 and Type2 according to
+;;; Return the result of an operation on TYPE1 and TYPE2 according to
;;; the rules of numeric contagion. This is always NUMBER, some float
;;; format (possibly complex) or RATIONAL. Due to rational
;;; canonicalization, there isn't much we can do here with integers or
;;; rational complex numbers.
;;;
-;;; If either argument is not a Numeric-Type, then return NUMBER. This
+;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This
;;; is useful mainly for allowing types that are technically numbers,
-;;; but not a Numeric-Type.
+;;; but not a NUMERIC-TYPE.
(defun numeric-contagion (type1 type2)
(if (and (numeric-type-p type1) (numeric-type-p type2))
(let ((class1 (numeric-type-class type1))
\f
;;;; array types
-(define-type-class array)
+(!define-type-class array)
;;; What this does depends on the setting of the
;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
(array-type-specialized-element-type type)
(array-type-element-type type)))
-(define-type-method (array :simple-=) (type1 type2)
+(!define-type-method (array :simple-=) (type1 type2)
(values (and (equal (array-type-dimensions type1)
(array-type-dimensions type2))
(eq (array-type-complexp type1)
(specialized-element-type-maybe type2)))
t))
-(define-type-method (array :unparse) (type)
+(!define-type-method (array :unparse) (type)
(let ((dims (array-type-dimensions type))
(eltype (type-specifier (array-type-element-type type)))
(complexp (array-type-complexp type)))
`(array ,eltype ,dims)
`(simple-array ,eltype ,dims))))))
-(define-type-method (array :simple-subtypep) (type1 type2)
+(!define-type-method (array :simple-subtypep) (type1 type2)
(let ((dims1 (array-type-dimensions type1))
(dims2 (array-type-dimensions type2))
(complexp2 (array-type-complexp type2)))
- ;; See whether dimensions are compatible.
- (cond ((not (or (eq dims2 '*)
+ (cond (;; not subtypep unless dimensions are compatible
+ (not (or (eq dims2 '*)
(and (not (eq dims1 '*))
;; (sbcl-0.6.4 has trouble figuring out that
;; DIMS1 and DIMS2 must be lists at this
(the list dims1)
(the list dims2)))))
(values nil t))
- ;; See whether complexpness is compatible.
+ ;; not subtypep unless complexness is compatible
((not (or (eq complexp2 :maybe)
(eq (array-type-complexp type1) complexp2)))
(values nil t))
- ;; If the TYPE2 eltype is wild, we win. Otherwise, the types
- ;; must be identical.
- ((or (eq (array-type-element-type type2) *wild-type*)
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
+ ;; Since we didn't fail any of the tests above, we win
+ ;; if the TYPE2 element type is wild.
+ ((eq (array-type-element-type type2) *wild-type*)
(values t t))
- (t
- (values nil t)))))
-
-(define-superclasses array
+ (;; Since we didn't match any of the special cases above, we
+ ;; can't give a good answer unless both the element types
+ ;; have been defined.
+ (or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (values nil nil))
+ (;; Otherwise, the subtype relationship holds iff the
+ ;; types are equal, and they're equal iff the specialized
+ ;; element types are identical.
+ t
+ (values (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2))
+ t)))))
+
+(!define-superclasses array
((string string)
(vector vector)
(array))
(t
(values nil t)))))
-(define-type-method (array :simple-intersection) (type1 type2)
+(!define-type-method (array :simple-intersection2) (type1 type2)
(declare (type array-type type1 type2))
(if (array-types-intersect type1 type2)
(let ((dims1 (array-type-dimensions type1))
(complexp2 (array-type-complexp type2))
(eltype1 (array-type-element-type type1))
(eltype2 (array-type-element-type type2)))
- (values
- (specialize-array-type
- (make-array-type
- :dimensions (cond ((eq dims1 '*) dims2)
- ((eq dims2 '*) dims1)
- (t
- (mapcar (lambda (x y) (if (eq x '*) y x))
- dims1 dims2)))
- :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
- :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))
- t))
- (values *empty-type* t)))
+ (specialize-array-type
+ (make-array-type
+ :dimensions (cond ((eq dims1 '*) dims2)
+ ((eq dims2 '*) dims1)
+ (t
+ (mapcar (lambda (x y) (if (eq x '*) y x))
+ dims1 dims2)))
+ :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
+ :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
+ *empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,
;;; and return it in canonical form (as either '* or a list).
\f
;;;; MEMBER types
-(define-type-class member)
+(!define-type-class member)
-(define-type-method (member :unparse) (type)
+(!define-type-method (member :unparse) (type)
(let ((members (member-type-members type)))
(if (equal members '(nil))
'null
`(member ,@members))))
-(define-type-method (member :simple-subtypep) (type1 type2)
+(!define-type-method (member :simple-subtypep) (type1 type2)
(values (subsetp (member-type-members type1) (member-type-members type2))
t))
-(define-type-method (member :complex-subtypep-arg1) (type1 type2)
- (block PUNT
- (values (every-type-op ctypep type2 (member-type-members type1)
- :list-first t)
- t)))
+(!define-type-method (member :complex-subtypep-arg1) (type1 type2)
+ (every/type (swapped-args-fun #'ctypep)
+ type2
+ (member-type-members type1)))
;;; We punt if the odd type is enumerable and intersects with the
;;; MEMBER type. If not enumerable, then it is definitely not a
;;; subtype of the MEMBER type.
-(define-type-method (member :complex-subtypep-arg2) (type1 type2)
+(!define-type-method (member :complex-subtypep-arg2) (type1 type2)
(cond ((not (type-enumerable type1)) (values nil t))
- ((types-intersect type1 type2) (values nil nil))
- (t
- (values nil t))))
+ ((types-equal-or-intersect type1 type2) (values nil nil))
+ (t (values nil t))))
-(define-type-method (member :simple-intersection) (type1 type2)
+(!define-type-method (member :simple-intersection2) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
- (values (cond ((subsetp mem1 mem2) type1)
- ((subsetp mem2 mem1) type2)
- (t
- (let ((res (intersection mem1 mem2)))
- (if res
- (make-member-type :members res)
- *empty-type*))))
- t)))
+ (cond ((subsetp mem1 mem2) type1)
+ ((subsetp mem2 mem1) type2)
+ (t
+ (let ((res (intersection mem1 mem2)))
+ (if res
+ (make-member-type :members res)
+ *empty-type*))))))
-(define-type-method (member :complex-intersection) (type1 type2)
- (block PUNT
+(!define-type-method (member :complex-intersection2) (type1 type2)
+ (block punt
(collect ((members))
(let ((mem2 (member-type-members type2)))
- (dolist (member mem2)
+ (dolist (member mem2)
(multiple-value-bind (val win) (ctypep member type1)
(unless win
- (return-from PUNT (values type2 nil)))
+ (return-from punt nil))
(when val (members member))))
+ (cond ((subsetp mem2 (members)) type2)
+ ((null (members)) *empty-type*)
+ (t
+ (make-member-type :members (members))))))))
- (values (cond ((subsetp mem2 (members)) type2)
- ((null (members)) *empty-type*)
- (t
- (make-member-type :members (members))))
- t)))))
-
-;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
-;;; type, and the member/union interaction is handled by the union type
-;;; method.
-(define-type-method (member :simple-union) (type1 type2)
+;;; We don't need a :COMPLEX-UNION2, since the only interesting case is
+;;; a union type, and the member/union interaction is handled by the
+;;; union type method.
+(!define-type-method (member :simple-union2) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
(cond ((subsetp mem1 mem2) type2)
(t
(make-member-type :members (union mem1 mem2))))))
-(define-type-method (member :simple-=) (type1 type2)
+(!define-type-method (member :simple-=) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
- (values (and (subsetp mem1 mem2) (subsetp mem2 mem1))
+ (values (and (subsetp mem1 mem2)
+ (subsetp mem2 mem1))
t)))
-(define-type-method (member :complex-=) (type1 type2)
+(!define-type-method (member :complex-=) (type1 type2)
(if (type-enumerable type1)
(multiple-value-bind (val win) (csubtypep type2 type1)
(if (or val (not win))
(values nil t)))
(values nil t)))
-(def-type-translator member (&rest members)
+(!def-type-translator member (&rest members)
(if members
(make-member-type :members (remove-duplicates members))
*empty-type*))
\f
-;;;; union types
+;;;; intersection types
+;;;;
+;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach
+;;;; of punting on all AND types, not just the unreasonably complicated
+;;;; ones. The change was motivated by trying to get the KEYWORD type
+;;;; to behave sensibly:
+;;;; ;; reasonable definition
+;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
+;;;; ;; reasonable behavior
+;;;; (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
+;;;; not so good..)
+;;;;
+;;;; We still follow the example of CMU CL to some extent, by punting
+;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
+;;;; involving AND.
+
+(!define-type-class intersection)
+
+;;; A few intersection types have special names. The others just get
+;;; mechanically unparsed.
+(!define-type-method (intersection :unparse) (type)
+ (declare (type ctype type))
+ (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
+ `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
+
+;;; shared machinery for type equality: true if every type in the set
+;;; TYPES1 matches a type in the set TYPES2 and vice versa
+(defun type=-set (types1 types2)
+ (flet (;; true if every type in the set X matches a type in the set Y
+ (type<=-set (x y)
+ (declare (type list x y))
+ (every (lambda (xelement)
+ (position xelement y :test #'type=))
+ x)))
+ (values (and (type<=-set types1 types2)
+ (type<=-set types2 types1))
+ t)))
-;;; Make a union type from the specifier types, setting ENUMERABLE in
-;;; the result if all are enumerable.
-(defun make-union-type (types)
- (declare (list types))
- (%make-union-type (every #'type-enumerable types) types))
+;;; Two intersection types are equal if their subtypes are equal sets.
+;;;
+;;; FIXME: Might it be better to use
+;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
+;;; instead, since SUBTYPEP is the usual relationship that we care
+;;; most about, so it would be good to leverage any ingenuity there
+;;; in this more obscure method?
+(!define-type-method (intersection :simple-=) (type1 type2)
+ (type=-set (intersection-type-types type1)
+ (intersection-type-types type2)))
+
+(flet ((intersection-complex-subtypep-arg1 (type1 type2)
+ (any/type (swapped-args-fun #'csubtypep)
+ type2
+ (intersection-type-types type1))))
+ (!define-type-method (intersection :simple-subtypep) (type1 type2)
+ (every/type #'intersection-complex-subtypep-arg1
+ type1
+ (intersection-type-types type2)))
+ (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
+ (intersection-complex-subtypep-arg1 type1 type2)))
+
+(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+ (every/type #'csubtypep type1 (intersection-type-types type2)))
+
+(!def-type-translator and (&whole whole &rest type-specifiers)
+ (apply #'type-intersection
+ (mapcar #'specifier-type
+ type-specifiers)))
+\f
+;;;; union types
-(define-type-class union)
+(!define-type-class union)
-;;; If LIST, then return that, otherwise the OR of the component types.
-(define-type-method (union :unparse) (type)
+;;; The LIST type has a special name. Other union types just get
+;;; mechanically unparsed.
+(!define-type-method (union :unparse) (type)
(declare (type ctype type))
(if (type= type (specifier-type 'list))
'list
`(or ,@(mapcar #'type-specifier (union-type-types type)))))
-;;; Two union types are equal if every type in one is equal to some
-;;; type in the other.
-(define-type-method (union :simple-=) (type1 type2)
- (block PUNT
- (let ((types1 (union-type-types type1))
- (types2 (union-type-types type2)))
- (values (and (dolist (type1 types1 t)
- (unless (any-type-op type= type1 types2)
- (return nil)))
- (dolist (type2 types2 t)
- (unless (any-type-op type= type2 types1)
- (return nil))))
- t))))
+;;; Two union types are equal if their subtypes are equal sets.
+(!define-type-method (union :simple-=) (type1 type2)
+ (type=-set (union-type-types type1)
+ (union-type-types type2)))
;;; Similarly, a union type is a subtype of another if every element
;;; of TYPE1 is a subtype of some element of TYPE2.
-(define-type-method (union :simple-subtypep) (type1 type2)
- (block PUNT
- (let ((types2 (union-type-types type2)))
- (values (dolist (type1 (union-type-types type1) t)
- (unless (any-type-op csubtypep type1 types2)
- (return nil)))
- t))))
-
-(define-type-method (union :complex-subtypep-arg1) (type1 type2)
- (block PUNT
- (values (every-type-op csubtypep type2 (union-type-types type1)
- :list-first t)
- t)))
-
-(define-type-method (union :complex-subtypep-arg2) (type1 type2)
- (block PUNT
- (values (any-type-op csubtypep type1 (union-type-types type2)) t)))
-
-(define-type-method (union :complex-union) (type1 type2)
- (let* ((class1 (type-class-info type1)))
- (collect ((res))
- (let ((this-type type1))
- (dolist (type (union-type-types type2)
- (if (res)
- (make-union-type (cons this-type (res)))
- this-type))
- (cond ((eq (type-class-info type) class1)
- (let ((union (funcall (type-class-simple-union class1)
- this-type type)))
- (if union
- (setq this-type union)
- (res type))))
- ((csubtypep type this-type))
- ((csubtypep type1 type) (return type2))
- (t
- (res type))))))))
-
-;;; For the union of union types, we let the :COMPLEX-UNION method do
-;;; the work.
-(define-type-method (union :simple-union) (type1 type2)
- (let ((res type1))
- (dolist (t2 (union-type-types type2) res)
- (setq res (type-union res t2)))))
-
-(define-type-method (union :simple-intersection :complex-intersection)
- (type1 type2)
- (let ((res *empty-type*)
- (win t))
- (dolist (type (union-type-types type2) (values res win))
- (multiple-value-bind (int w) (type-intersection type1 type)
- (setq res (type-union res int))
- (unless w (setq win nil))))))
-
-(def-type-translator or (&rest types)
- (reduce #'type-union
- (mapcar #'specifier-type types)
- :initial-value *empty-type*))
-
-;;; We don't actually have intersection types, since the result of
-;;; reasonable type intersections is always describable as a union of
-;;; simple types. If something is too hairy to fit this mold, then we
-;;; make a hairy type.
-(def-type-translator and (&whole spec &rest types)
- (let ((res *wild-type*))
- (dolist (type types res)
- (let ((ctype (specifier-type type)))
- (multiple-value-bind (int win) (type-intersection res ctype)
- (unless win
- (return (make-hairy-type :specifier spec)))
- (setq res int))))))
+(!define-type-method (union :simple-subtypep) (type1 type2)
+ (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)
+ type2
+ (union-type-types type1)))
+(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
+ (union-complex-subtypep-arg1 type1 type2))
+
+(defun union-complex-subtypep-arg2 (type1 type2)
+ (any/type #'csubtypep type1 (union-type-types type2)))
+(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
+ (union-complex-subtypep-arg2 type1 type2))
+
+(!define-type-method (union :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ ;; The CSUBTYPEP clauses here let us simplify e.g.
+ ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST)
+ ;; (SPECIFIER-TYPE '(OR LIST VECTOR)))
+ ;; (where LIST is (OR CONS NULL)).
+ ;;
+ ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice
+ ;; versa, but it's important that we pre-expand them into
+ ;; specialized operations on individual elements of
+ ;; UNION-TYPE-TYPES, instead of using the ordinary call to
+ ;; CSUBTYPEP, in order to avoid possibly invoking any methods which
+ ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
+ ;; cause infinite recursion.
+ (cond ((union-complex-subtypep-arg2 type1 type2)
+ type1)
+ ((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 (because
+ ;; TYPE-UNION2 was unable to give us a simple result)
+ (unless accumulator
+ (return nil)))))))
+
+(!def-type-translator or (&rest type-specifiers)
+ (apply #'type-union
+ (mapcar #'specifier-type
+ type-specifiers)))
\f
+;;;; CONS types
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
+(!define-type-class cons)
-; (define-type-class cons)
+(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
+ (make-cons-type (specifier-type car-type-spec)
+ (specifier-type cdr-type-spec)))
-; (def-type-translator cons (&optional car-type cdr-type)
-; (make-cons-type :car-type (specifier-type car-type)
-; :cdr-type (specifier-type cdr-type)))
+(!define-type-method (cons :unparse) (type)
+ (let ((car-eltype (type-specifier (cons-type-car-type type)))
+ (cdr-eltype (type-specifier (cons-type-cdr-type type))))
+ (if (and (member car-eltype '(t *))
+ (member cdr-eltype '(t *)))
+ 'cons
+ `(cons ,car-eltype ,cdr-eltype))))
-; (define-type-method (cons :unparse) (type)
-; (let ((car-eltype (type-specifier (cons-type-car-type type)))
-; (cdr-eltype (type-specifier (cons-type-cdr-type type))))
-; (cond ((and (eq car-eltype '*) (eq cdr-eltype '*))
-; 'cons)
-; (t
-; `(cons ,car-eltype ,cdr-eltype)))))
+(!define-type-method (cons :simple-=) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
+ (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
-; (define-type-method (cons :simple-=) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
-; (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+(!define-type-method (cons :simple-subtypep) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (multiple-value-bind (val-car win-car)
+ (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
+ (multiple-value-bind (val-cdr win-cdr)
+ (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))))))
-; (define-type-method (cons :simple-subtypep) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (multiple-value-bind (val-car win-car)
-; (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
-; (multiple-value-bind (val-cdr win-cdr)
-; (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))))))
-
-; ;;; CONS :simple-union method -- Internal
-; ;;;
-; ;;; Give up if a precise type in not possible, to avoid returning overly
-; ;;; general types.
-; ;;;
-; (define-type-method (cons :simple-union) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (let ((car-type1 (cons-type-car-type type1))
-; (car-type2 (cons-type-car-type type2))
-; (cdr-type1 (cons-type-cdr-type type1))
-; (cdr-type2 (cons-type-cdr-type type2)))
-; (cond ((type= car-type1 car-type2)
-; (make-cons-type :car-type car-type1
-; :cdr-type (type-union cdr-type1 cdr-type2)))
-; ((type= cdr-type1 cdr-type2)
-; (make-cons-type :car-type (type-union cdr-type1 cdr-type2)
-; :cdr-type cdr-type1)))))
-
-; (define-type-method (cons :simple-intersection) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (multiple-value-bind (int-car win-car)
-; (type-intersection (cons-type-car-type type1) (cons-type-car-type type2))
-; (multiple-value-bind (int-cdr win-cdr)
-; (type-intersection (cons-type-cdr-type type1) (cons-type-cdr-type type2))
-; (values (make-cons-type :car-type int-car :cdr-type int-cdr)
-; (and win-car win-cdr)))))
-
-
-
+;;; Give up if a precise type is not possible, to avoid returning
+;;; overly general types.
+(!define-type-method (cons :simple-union2) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (let ((car-type1 (cons-type-car-type type1))
+ (car-type2 (cons-type-car-type type2))
+ (cdr-type1 (cons-type-cdr-type type1))
+ (cdr-type2 (cons-type-cdr-type type2)))
+ (cond ((type= car-type1 car-type2)
+ (make-cons-type car-type1
+ (type-union cdr-type1 cdr-type2)))
+ ((type= cdr-type1 cdr-type2)
+ (make-cons-type (type-union cdr-type1 cdr-type2)
+ cdr-type1)))))
+
+(!define-type-method (cons :simple-intersection2) (type1 type2)
+ (declare (type cons-type type1 type2))
+ (let (car-int2
+ cdr-int2)
+ (and (setf car-int2 (type-intersection2 (cons-type-car-type type1)
+ (cons-type-car-type type2)))
+ (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2)))
+ (make-cons-type car-int2 cdr-int2))))
+\f
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
;;;
(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
(let ((members (member-type-members y-mem)))
(multiple-value-bind (val win) (ctypep member x-type)
(when (or (not win) val)
(return-from type-difference nil)))))))))
-
- (cond ((null (res)) *empty-type*)
- ((null (rest (res))) (first (res)))
- (t
- (make-union-type (res)))))))
+ (apply #'type-union (res)))))
\f
-(def-type-translator array (&optional (element-type '*)
- (dimensions '*))
+(!def-type-translator array (&optional (element-type '*)
+ (dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
:element-type (specifier-type element-type))))
-(def-type-translator simple-array (&optional (element-type '*)
- (dimensions '*))
+(!def-type-translator simple-array (&optional (element-type '*)
+ (dimensions '*))
(specialize-array-type
(make-array-type :dimensions (canonical-array-dimensions dimensions)
: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")