;;;
;;; 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
;;; 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)
- (when (or (not (cdr x))
- (csubtypep type1 (specifier-type (cdr x))))
- (return
- (or (eq type2 (car x))
- (let ((inherits (layout-inherits (class-layout (car x)))))
- (dotimes (i (length inherits) nil)
- (when (eq type2 (layout-class (svref inherits i)))
- (return t)))))))))
- t))
+ ;; If TYPE2 might be concealing something related to our class
+ ;; hierarchy
+ (if (type-might-contain-other-types? type2)
+ ;; too confusing, gotta punt
+ (values nil nil)
+ ;; ordinary case expected by old CMU CL code, where the taxonomy
+ ;; of TYPE2's representation accurately reflects the taxonomy of
+ ;; the underlying set
+ (values
+ ;; FIXME: This old CMU CL code probably deserves a comment
+ ;; explaining to us mere mortals how it works...
+ (and (sb!xc:typep type2 'sb!xc:class)
+ (dolist (x info nil)
+ (when (or (not (cdr x))
+ (csubtypep type1 (specifier-type (cdr x))))
+ (return
+ (or (eq type2 (car x))
+ (let ((inherits (layout-inherits (class-layout (car x)))))
+ (dotimes (i (length inherits) nil)
+ (when (eq type2 (layout-class (svref inherits i)))
+ (return t)))))))))
+ t)))
;;; This function takes a list of specs, each of the form
;;; (SUPERCLASS-NAME &OPTIONAL GUARD).
;;; 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-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))
;;; 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))
;;; 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))
(eq type1 *empty-type*)
(eq type2 *wild-type*))
(values t t))
- ((or (eq type1 *wild-type*)
- (eq type2 *empty-type*))
+ ((eq type1 *wild-type*)
(values nil t))
(t
(!invoke-type-method :simple-subtypep :complex-subtypep-arg2
(eql yx :no-type-method-found))
*empty-type*)
(t
- (assert (and (not xy) (not yx))) ; else handled above
+ (aver (and (not xy) (not yx))) ; else handled above
nil))))))))
(defun-cached (type-intersection2 :hash-function type-cache-hash
((hairy-type-p type1) type2)
(t type1)))
-;;; The first value is true unless the types don't intersect. The
-;;; second value is true if the first value is definitely correct. NIL
-;;; is considered to intersect with any type. If T is a subtype of
-;;; either type, then we also return T, T. This way we recognize
-;;; that hairy types might intersect with T.
+;;; a test useful for checking whether a derived type matches a
+;;; declared type
;;;
-;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT,
-;;; and rename VALUES-TYPES-INTERSECT the same way.
-(defun types-intersect (type1 type2)
+;;; The first value is true unless the types don't intersect and
+;;; aren't equal. The second value is true if the first value is
+;;; definitely correct. NIL is considered to intersect with any type.
+;;; If T is a subtype of either type, then we also return T, T. This
+;;; way we recognize that hairy types might intersect with T.
+(defun types-equal-or-intersect (type1 type2)
(declare (type ctype type1 type2))
(if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
(values t t)
(declare (type function simplify2))
;; Any input object satisfying %COMPOUND-TYPE-P should've been
;; broken into components before it reached us.
- (assert (not (funcall %compound-type-p type)))
+ (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
(defun simplified-compound-types (input-types %compound-type-p simplify2)
(let ((simplified-types (make-array (length input-types)
:fill-pointer 0
+ :adjustable t
:element-type 'ctype
;; (This INITIAL-ELEMENT shouldn't
;; matter, but helps avoid type
(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.
- ;; 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)))
- ;; 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))).
- (assert (not (compound-type-p type2)))
- ;; Then, since TYPE2 is reasonably tractable, we're good to go.
- (values (eq type1 *empty-type*) t))
+ (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type1 *empty-type*)
+ t)
+ (;; When TYPE2 might be the universal type in disguise
+ (type-might-contain-other-types? type2)
+ ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods
+ ;; can delegate to us (more or less as CALL-NEXT-METHOD) when
+ ;; they're uncertain, we can't just barf on COMPOUND-TYPE and
+ ;; HAIRY-TYPEs as we used to. Instead we deal with the
+ ;; problem (where at least part of the problem is cases like
+ ;; (SUBTYPEP T '(SATISFIES FOO))
+ ;; or
+ ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR)))
+ ;; where the second type is a hairy type like SATISFIES, or
+ ;; is a compound type which might contain a hairy type) by
+ ;; returning uncertainty.
+ (values nil nil))
+ (t
+ ;; By elimination, TYPE1 is the universal type.
+ (aver (eq type1 *universal-type*))
+ ;; This case would have been picked off by the SIMPLE-SUBTYPEP
+ ;; method, and so shouldn't appear here.
+ (aver (not (eq type2 *universal-type*)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the
+ ;; universal type in disguise, TYPE2 is not a superset of TYPE1.
+ (values nil 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)
- (values nil nil))
+ (invoke-complex-subtypep-arg1-method type1 type2))
(t
;; FIXME: This seems to rely on there only being 2 or 3
;; HAIRY-TYPE values, and the exclusion of various
(!define-type-method (named :complex-intersection2) (type1 type2)
;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
;; Perhaps when bug 85 is fixed it can be reenabled.
- ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(hierarchical-intersection2 type1 type2))
(!define-type-method (named :complex-union2) (type1 type2)
;; Perhaps when bug 85 is fixed this can be reenabled.
- ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(hierarchical-union2 type1 type2))
(!define-type-method (named :unparse) (x)
complement-type2)))
(if intersection2
(values (eq intersection2 *empty-type*) t)
- (values nil nil))))
+ (invoke-complex-subtypep-arg1-method type1 type2))))
(t
- (values nil nil)))))
+ (invoke-complex-subtypep-arg1-method type1 type2)))))
+
+(!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
+ ;; "Incrementally extended heuristic algorithms tend inexorably toward the
+ ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
+ (let ((hairy-spec (hairy-type-specifier type1)))
+ (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
+ ;; You may not believe this. I couldn't either. But then I
+ ;; sat down and drew lots of Venn diagrams. Comments
+ ;; involving a and b refer to the call (subtypep '(not a)
+ ;; 'b) -- CSR, 2002-02-27.
+ (block nil
+ ;; (Several logical truths in this block are true as
+ ;; long as b/=T. As of sbcl-0.7.1.28, it seems
+ ;; impossible to construct a case with b=T where we
+ ;; actually reach this type method, but we'll test for
+ ;; and exclude this case anyway, since future
+ ;; maintenance might make it possible for it to end up
+ ;; in this code.)
+ (multiple-value-bind (equal certain)
+ (type= type2 (specifier-type t))
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values t t))))
+ (let ((complement-type1 (specifier-type (cadr hairy-spec))))
+ ;; Do the special cases first, in order to give us a
+ ;; chance if subtype/supertype relationships are hairy.
+ (multiple-value-bind (equal certain)
+ (type= complement-type1 type2)
+ ;; If a = b, ~a is not a subtype of b (unless b=T,
+ ;; which was excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; KLUDGE: ANSI requires that the SUBTYPEP result
+ ;; between any two built-in atomic type specifiers
+ ;; never be uncertain. This is hard to do cleanly for
+ ;; the built-in types whose definitions include
+ ;; (NOT FOO), i.e. CONS and RATIO. However, we can do
+ ;; it with this hack, which uses our global knowledge
+ ;; that our implementation of the type system uses
+ ;; disjoint implementation types to represent disjoint
+ ;; sets (except when types are contained in other types).
+ ;; (This is a KLUDGE because it's fragile. Various
+ ;; changes in internal representation in the type
+ ;; system could make it start confidently returning
+ ;; incorrect results.) -- WHN 2002-03-08
+ (unless (or (type-might-contain-other-types? complement-type1)
+ (type-might-contain-other-types? type2))
+ ;; Because of the way our types which don't contain
+ ;; other types are disjoint subsets of the space of
+ ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when
+ ;; AA and B are simple (and B is not T, as checked above).
+ (return (values nil t)))
+ ;; The old (TYPE= TYPE1 TYPE2) branch would never be
+ ;; taken, as TYPE1 and TYPE2 will only be equal if
+ ;; they're both NOT types, and then the
+ ;; :SIMPLE-SUBTYPEP method would be used instead.
+ ;; But a CSUBTYPEP relationship might still hold:
+ (multiple-value-bind (equal certain)
+ (csubtypep complement-type1 type2)
+ ;; If a is a subtype of b, ~a is not a subtype of b
+ ;; (unless b=T, which was excluded above).
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ (multiple-value-bind (equal certain)
+ (csubtypep type2 complement-type1)
+ ;; If b is a subtype of a, ~a is not a subtype of b.
+ ;; (FIXME: That's not true if a=T. Do we know at
+ ;; this point that a is not T?)
+ (unless certain
+ (return (values nil nil)))
+ (when equal
+ (return (values nil t))))
+ ;; old CSR comment ca. 0.7.2, now obsoleted by the
+ ;; SIMPLE-CTYPE? KLUDGE case above:
+ ;; Other cases here would rely on being able to catch
+ ;; all possible cases, which the fragility of this
+ ;; type system doesn't inspire me; for instance, if a
+ ;; is type= to ~b, then we want T, T; if this is not
+ ;; the case and the types are disjoint (have an
+ ;; intersection of *empty-type*) then we want NIL, T;
+ ;; else if the union of a and b is the
+ ;; *universal-type* then we want T, T. So currently we
+ ;; still claim to be unsure about e.g. (subtypep '(not
+ ;; fixnum) 'single-float).
+ )))
+ (t
+ (values nil nil)))))
-(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+(!define-type-method (hairy :complex-=) (type1 type2)
(declare (ignore type1 type2))
(values nil nil))
;; 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))
+ (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec
+ (if (and (listp spec) (eq (car spec) 'not))
+ ;; canonicalize (not (not foo))
+ (specifier-type (cadr spec))
+ (make-hairy-type :specifier whole)))))
(!def-type-translator satisfies (&whole whole fun)
(declare (ignore fun))
\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)
`(unsigned-byte ,high-length))
(t
`(mod ,(1+ high)))))
- ((and (= low sb!vm:*target-most-negative-fixnum*)
- (= high sb!vm:*target-most-positive-fixnum*))
+ ((and (= low sb!xc:most-negative-fixnum)
+ (= high sb!xc:most-positive-fixnum))
'fixnum)
((and (= low (lognot high))
(= high-count high-length)
'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 (eq typespec '*)
(make-numeric-type :complexp :complex)
(labels ((not-numeric ()
- ;; FIXME: should probably be TYPE-ERROR
(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)
- ;; 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))
- (let ((result (copy-numeric-type component-type)))
- (setf (numeric-type-complexp result) :complex)
- result)))
- (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.
+ (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 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)))))))
+ (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.
(lb (if (consp l) (1+ (car l)) l))
(h (canonicalized-bound high 'integer))
(hb (if (consp h) (1- (car h)) h)))
- (when (and hb lb (< hb lb))
- (error "Lower bound ~S is greater than upper bound ~S." l h))
- (make-numeric-type :class 'integer
- :complexp :real
- :enumerable (not (null (and l h)))
- :low lb
- :high hb)))
+ (if (and hb lb (< hb lb))
+ ;; previously we threw an error here:
+ ;; (error "Lower bound ~S is greater than upper bound ~S." l h))
+ ;; but ANSI doesn't say anything about that, so:
+ (specifier-type 'nil)
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :enumerable (not (null (and l h)))
+ :low lb
+ :high hb))))
(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))))
+ (if (not (numeric-bound-test* lb hb <= <))
+ ;; as above, previously we did
+ ;; (error "Lower bound ~S is not less than upper bound ~S." low high))
+ ;; but it is correct to do
+ (specifier-type 'nil)
+ (make-numeric-type :class ',class :format ',format :low lb :high hb)))))
(!def-bounded-type rational rational nil)
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)
+ (invoke-complex-subtypep-arg1-method type1 type2))
(t (values nil t))))
(!define-type-method (member :simple-intersection2) (type1 type2)
;;;; ;; reasonable definition
;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
;;;; ;; reasonable behavior
-;;;; (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
+;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL))
;;;; Without understanding a little about the semantics of AND, we'd
;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
(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)))
(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.
-;;;
-;;; 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
+;;; Similarly, a union type is a subtype of another if and only if
+;;; every element of TYPE1 is a subtype of TYPE2.
(!define-type-method (union :simple-subtypep) (type1 type2)
- (dolist (t1 (union-type-types type1) (values t t))
- (multiple-value-bind (subtypep validp)
- (union-complex-subtypep-arg2 t1 type2)
- (cond ((not validp)
- (return (values nil nil)))
- ((not subtypep)
- (return (values nil t)))))))
+ (every/type (swapped-args-fun #'union-complex-subtypep-arg2)
+ type2
+ (union-type-types type1)))
(defun union-complex-subtypep-arg1 (type1 type2)
(every/type (swapped-args-fun #'csubtypep)
(union-complex-subtypep-arg1 type1 type2))
(defun union-complex-subtypep-arg2 (type1 type2)
- (any/type #'csubtypep type1 (union-type-types type2)))
+ (multiple-value-bind (sub-value sub-certain?)
+ (any/type #'csubtypep type1 (union-type-types type2))
+ (if sub-certain?
+ (values sub-value sub-certain?)
+ ;; The ANY/TYPE expression above is a sufficient condition for
+ ;; subsetness, but not a necessary one, so we might get a more
+ ;; certain answer by this CALL-NEXT-METHOD-ish step when the
+ ;; ANY/TYPE expression is uncertain.
+ (invoke-complex-subtypep-arg1-method type1 type2))))
(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
(union-complex-subtypep-arg2 type1 type2))
(multiple-value-bind (val win) (csubtypep x-type y-type)
(unless win (return-from type-difference nil))
(when val (return))
- (when (types-intersect x-type y-type)
+ (when (types-equal-or-intersect x-type y-type)
(return-from type-difference nil))))))
(let ((y-mem (find-if #'member-type-p y-types)))
(when y-mem
:element-type (specifier-type element-type)
:complexp nil)))
\f
-(!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