;;;
;;; RATIO and BIGNUM are not recognized as numeric types.
-;;; FIXME: It seems to me that this should be set to NIL by default,
-;;; and perhaps not even optionally set to T.
-(defvar *use-implementation-types* t
+;;; FIXME: This really should go away. Alas, it doesn't seem to be so
+;;; simple to make it go away.. (See bug 123 in BUGS file.)
+(defvar *use-implementation-types* t ; actually initialized in cold init
#!+sb-doc
"*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
restrictive we are in determining type membership. If two types are the
this switch is on. When it is off, we try to be as restrictive as the
language allows, allowing us to detect more errors. Currently, this only
affects array types.")
-
(!cold-init-forms (setq *use-implementation-types* t))
;;; These functions are used as method for types which need a complex
;;; 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 key (not necessarily a keyword in ANSI Common Lisp)
+ (name (missing-arg) :type symbol)
;; the type of the argument value
- (type (required-argument) :type ctype))
+ (type (missing-arg) :type ctype))
(!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
(type1 type2)
;;; 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
;;; can pass to TYPEP.
-(defvar *unparse-function-type-simplify*)
-(!cold-init-forms (setq *unparse-function-type-simplify* nil))
+(defvar *unparse-fun-type-simplify*)
+(!cold-init-forms (setq *unparse-fun-type-simplify* nil))
(!define-type-method (function :unparse) (type)
- (if *unparse-function-type-simplify*
+ (if *unparse-fun-type-simplify*
'function
(list 'function
- (if (function-type-wild-args type)
+ (if (fun-type-wild-args type)
'*
(unparse-args-types type))
(type-specifier
- (function-type-returns type)))))
+ (fun-type-returns type)))))
;;; Since all function types are equivalent to FUNCTION, they are all
;;; subtypes of each other.
(!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-intersection2) (type1 type2)
(!define-type-class constant :inherits values)
(!define-type-method (constant :unparse) (type)
- `(constant-argument ,(type-specifier (constant-type-type type))))
+ `(constant-arg ,(type-specifier (constant-type-type type))))
(!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-arg (type)
(make-constant-type :type (specifier-type type)))
;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
(result)))
(!def-type-translator function (&optional (args '*) (result '*))
- (let ((res (make-function-type
- :returns (values-specifier-type result))))
+ (let ((res (make-fun-type :returns (values-specifier-type result))))
(if (eq args '*)
- (setf (function-type-wild-args res) t)
+ (setf (fun-type-wild-args res) t)
(parse-args-types args res))
res))
(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)
+(defun fun-type-nargs (type)
(declare (type ctype type))
- (if (function-type-p type)
+ (if (fun-type-p type)
(let ((fixed (length (args-type-required type))))
(if (or (args-type-rest type)
(args-type-keyp type)
(defun fixed-values-op (types1 types2 rest2 operation)
(declare (list types1 types2) (type ctype rest2) (type function operation))
(let ((exact t))
- (values (mapcar #'(lambda (t1 t2)
- (multiple-value-bind (res win)
- (funcall operation t1 t2)
- (unless win
- (setq exact nil))
- res))
+ (values (mapcar (lambda (t1 t2)
+ (multiple-value-bind (res win)
+ (funcall operation t1 t2)
+ (unless win
+ (setq exact nil))
+ res))
types1
(append types2
(make-list (- (length types1) (length types2))
;;; 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
;;; 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))
(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-or-something (list type1 type2))))
- (res)
- (t
- (make-union-type-or-something (list type1 type2)))))))
+ (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)
(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
((or (intersection-type-p type1)
(intersection-type-p type2))
;; Intersections of INTERSECTION-TYPE should have the
- ;; INTERSECTION-TYPE-TYPES objects broken out and intersected
+ ;; 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))
((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 t) types))
+ (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
+;;; 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-VECTOR is short.
+;;; 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 t) types))
+ (declare (type (vector ctype) types))
(declare (type ctype identity))
(case (length types)
(0 identity)
- (1 (the ctype (aref types 0)))
- (t (funcall constructor enumerable (coerce types 'list)))))
+ (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 (;; components of our result, accumulated as a vector
- (simplified-types (make-array (length input-types) :fill-pointer 0)))
- (flet ((accumulate (type)
- (accumulate-compound-type type
- simplified-types
- #'type-intersection2)))
- (declare (inline accumulate))
- (dolist (type input-types)
- (if (intersection-type-p type)
- (map nil #'accumulate (intersection-type-types type))
- (accumulate type)))
- ;; 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*)))))
-
-;;; FIXME: Define TYPE-UNION similar to TYPE-INTERSECTION.
+ (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
(defvar *wild-type*)
(defvar *empty-type*)
(defvar *universal-type*)
-
+(defvar *universal-fun-type*)
(!cold-init-forms
(macrolet ((frob (name var)
`(progn
;; Ts and *UNIVERSAL-TYPE*s.
(frob * *wild-type*)
(frob nil *empty-type*)
- (frob t *universal-type*)))
+ (frob t *universal-type*))
+ (setf *universal-fun-type*
+ (make-fun-type :wild-args t
+ :returns *wild-type*)))
(!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.
- ;;(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.
+ ;;(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
(declare (ignore type1 type2))
nil)
-(!define-type-method (hairy :complex-union) (type1 type2)
- (make-union-type-or-something (list type1 type2)))
-
(!define-type-method (hairy :simple-=) (type1 type2)
(if (equal (hairy-type-specifier type1)
(hairy-type-specifier type2))
(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
- ;; Check legality of arguments of arguments.
+ ;; 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
+ :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
-#!+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
;;;
;;; ### 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 ()
+ (error "The component type for COMPLEX is not numeric: ~S"
+ typespec))
+ (not-real ()
+ (error "The component type for COMPLEX is not real: ~S"
+ typespec))
+ (complex1 (component-type)
+ (unless (numeric-type-p component-type)
+ (not-numeric))
+ (when (eq (numeric-type-complexp component-type) :complex)
+ (not-real))
+ (modified-numeric-type component-type :complexp :complex))
+ (complex-union (component)
+ (unless (numberp component)
+ (not-numeric))
+ ;; KLUDGE: This TYPECASE more or less does
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
+ ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
+ ;; but uses logic cut and pasted from the DEFUN of
+ ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
+ ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
+ ;; would tend to break the code here. Unfortunately,
+ ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
+ ;; would cause another kind of fragility, because
+ ;; ANSI's definition of TYPE-OF is so weak that e.g.
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
+ ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
+ ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
+ ;; So using TYPE-OF would mean that ANSI-conforming
+ ;; maintenance changes in TYPE-OF could break the code here.
+ ;; It's not clear how best to fix this. -- WHN 2002-01-21,
+ ;; trying to summarize CSR's concerns in his patch
+ (typecase component
+ (complex (error "The component type for COMPLEX (EQL X) ~
+ is complex: ~S"
+ component))
+ ((eql 0) (specifier-type nil)) ; as required by ANSI
+ (single-float (specifier-type '(complex single-float)))
+ (double-float (specifier-type '(complex double-float)))
+ #!+long-float
+ (long-float (specifier-type '(complex long-float)))
+ (rational (specifier-type '(complex rational)))
+ (t (specifier-type '(complex real))))))
+ (let ((ctype (specifier-type typespec)))
+ (typecase ctype
+ (numeric-type (complex1 ctype))
+ (union-type (apply #'type-union
+ ;; FIXME: This code could suffer from
+ ;; (admittedly very obscure) cases of
+ ;; bug 145 e.g. when TYPE is
+ ;; (OR (AND INTEGER (SATISFIES ODDP))
+ ;; (AND FLOAT (SATISFIES FOO))
+ ;; and not even report the problem very well.
+ (mapcar #'complex1
+ (union-type-types ctype))))
+ ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
+ ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
+ ;; ANSI, equal to type NIL, the empty set.
+ (member-type (apply #'type-union
+ (mapcar #'complex-union
+ (member-type-members ctype))))
+ (t
+ (multiple-value-bind (subtypep certainly)
+ (csubtypep ctype (specifier-type 'real))
+ (if (and (not subtypep) certainly)
+ (not-real)
+ ;; ANSI just says that TYPESPEC is any subtype of
+ ;; type REAL, not necessarily a NUMERIC-TYPE. In
+ ;; particular, at this point TYPESPEC could legally be
+ ;; an intersection type like (AND REAL (SATISFIES ODDP)),
+ ;; in which case we fall through the logic above and
+ ;; end up here, stumped.
+ (bug "~@<(known bug #145): The type ~S is too hairy to be
+ used for a COMPLEX component.~:@>"
+ typespec)))))))))
;;; If X is *, return NIL, otherwise return the bound, which must be a
;;; member of TYPE or a one-element list of a member of TYPE.
(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
;; See whether dimensions are compatible.
(cond ((not (or (eq dims1 '*) (eq dims2 '*)
(and (= (length dims1) (length dims2))
- (every #'(lambda (x y)
- (or (eq x '*) (eq y '*) (= x y)))
+ (every (lambda (x y)
+ (or (eq x '*) (eq y '*) (= x y)))
dims1 dims2))))
(values nil t))
;; See whether complexpness is compatible.
;;; 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)
(t
(make-member-type :members (members))))))))
-;;; We don't need a :COMPLEX-UNION, since the only interesting case is
+;;; 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-union) (type1 type2)
+(!define-type-method (member :simple-union2) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
(cond ((subsetp mem1 mem2) 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
(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)))
+(defun %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)))
\f
;;;; union types
-;;; Make a union type from the specifier types, setting ENUMERABLE in
-;;; the result if all are enumerable; or take the easy way out if we
-;;; recognize a special case which can be represented more simply.
-(defun make-union-type-or-something (types)
- (declare (list types))
- (cond ((null types)
- *empty-type*)
- ((null (cdr types))
- (first types))
- (t
- (%make-union-type (every #'type-enumerable types) types))))
-
(!define-type-class union)
;;; The LIST type has a special name. Other union types just get
;;; 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)
(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
(union-complex-subtypep-arg2 type1 type2))
-(!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-or-something (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-intersection2 :complex-intersection2)
(type1 type2)
;; The CSUBTYPEP clauses here let us simplify e.g.
((union-complex-subtypep-arg1 type2 type1)
type2)
(t
- (let (;; a component of TYPE2 whose intersection with TYPE1
- ;; is nonempty
- (nontriv-t2 nil))
- (dolist (t2 (union-type-types type2) (or nontriv-t2 *empty-type*))
- (unless (eq *empty-type* (type-intersection type1 t2))
- (if nontriv-t2 ; if this is second nonempty intersection
- (return nil) ; too many: can't find nice result
- (setf nontriv-t2 t2))))))))
+ ;; 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)
- (reduce #'type-union
- (mapcar #'specifier-type type-specifiers)
- :initial-value *empty-type*))
+ (apply #'type-union
+ (mapcar #'specifier-type
+ type-specifiers)))
\f
;;;; CONS types
;;; Give up if a precise type is not possible, to avoid returning
;;; overly general types.
-(!define-type-method (cons :simple-union) (type1 type2)
+(!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))
(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-or-something (res)))))))
+ (apply #'type-union (res)))))
\f
(!def-type-translator array (&optional (element-type '*)
(dimensions '*))
:element-type (specifier-type element-type)
:complexp nil)))
\f
-(!defun-from-collected-cold-init-forms !late-type-cold-init)
+;;;; 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 FUN-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 FUN-TYPEs. (ARGS-TYPE
+ ;; is a base class both of VALUES-TYPE and of FUN-TYPE.)
+ (values-types-equal-or-intersect
+ (fun-type-returns defined-ftype)
+ (fun-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
+(locally
+ ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type
+ ;; checking for declarations in structure accessors. Otherwise we
+ ;; can get caught in a chicken-and-egg bootstrapping problem, whose
+ ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal
+ ;; instruction trap. I haven't tracked it down, but I'm guessing it
+ ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set
+ ;; yet. -- WHN
+ (declare (optimize (safety 0)))
+ (!defun-from-collected-cold-init-forms !late-type-cold-init))
(/show0 "late-type.lisp end of file")
projects / sbcl.git / blobdiff