(define-condition parse-unknown-type (condition)
((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
-;;; 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
- same in the implementation, then we will consider them them the same when
- 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
;;; subtypep method to handle some superclasses, but cover a subtree
;;; of the type graph (i.e. there is no simple way for any other type
(!cold-init-forms (setq *unparse-fun-type-simplify* nil))
(!define-type-method (function :negate) (type)
- (error "NOT FUNCTION too confusing on ~S" (type-specifier type)))
+ (make-negation-type :type type))
(!define-type-method (function :unparse) (type)
(if *unparse-fun-type-simplify*
;; 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))
- (cond ((eq type1 type2)
- type1)
- ((csubtypep type1 type2) type2)
- ((csubtypep type2 type1) 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))))
+ (let ((t2 nil))
+ (cond ((eq type1 type2)
+ type1)
+ ;; CSUBTYPEP for array-types answers questions about the
+ ;; specialized type, yet for union we want to take the
+ ;; expressed type in account too.
+ ((and (not (and (array-type-p type1) (array-type-p type2)))
+ (or (setf t2 (csubtypep type1 type2))
+ (csubtypep type2 type1)))
+ (if t2 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 :call-other-method))
*empty-type*)
(t
- (aver (and (not xy) (not yx))) ; else handled above
nil))))))))
(defun-cached (type-intersection2 :hash-function type-cache-hash
;; In SBCL it also used to denote universal VALUES type.
(frob * *wild-type*)
(frob nil *empty-type*)
- (frob t *universal-type*))
+ (frob t *universal-type*)
+ ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that
+ ;; view of them was incompatible with requirements on the MOP
+ ;; metaobject class hierarchy: the INSTANCE and
+ ;; FUNCALLABLE-INSTANCE types are disjoint (instances have
+ ;; instance-pointer-lowtag; funcallable-instances have
+ ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is
+ ;; required to be a subclass of STANDARD-OBJECT. -- CSR,
+ ;; 2005-09-09
+ (frob instance *instance-type*)
+ (frob funcallable-instance *funcallable-instance-type*)
+ ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
+ ;; extended sequence hierarchy. (Might be removed later if we use
+ ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)
+ (frob extended-sequence *extended-sequence-type*))
(setf *universal-fun-type*
(make-fun-type :wild-args t
:returns *wild-type*)))
;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
+(defun cons-type-might-be-empty-type (type)
+ (declare (type cons-type type))
+ (let ((car-type (cons-type-car-type type))
+ (cdr-type (cons-type-cdr-type type)))
+ (or
+ (if (cons-type-p car-type)
+ (cons-type-might-be-empty-type car-type)
+ (multiple-value-bind (yes surep)
+ (type= car-type *empty-type*)
+ (aver (not yes))
+ (not surep)))
+ (if (cons-type-p cdr-type)
+ (cons-type-might-be-empty-type cdr-type)
+ (multiple-value-bind (yes surep)
+ (type= cdr-type *empty-type*)
+ (aver (not yes))
+ (not surep))))))
+
(!define-type-method (named :complex-=) (type1 type2)
(cond
((and (eq type2 *empty-type*)
- (intersection-type-p type1)
- ;; not allowed to be unsure on these... FIXME: keep the list
- ;; of CL types that are intersection types once and only
- ;; once.
- (not (or (type= type1 (specifier-type 'ratio))
- (type= type1 (specifier-type 'keyword)))))
+ (or (and (intersection-type-p type1)
+ ;; not allowed to be unsure on these... FIXME: keep
+ ;; the list of CL types that are intersection types
+ ;; once and only once.
+ (not (or (type= type1 (specifier-type 'ratio))
+ (type= type1 (specifier-type 'keyword)))))
+ (and (cons-type-p type1)
+ (cons-type-might-be-empty-type type1))))
;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
;; STREAM) can get here. In general, we can't really tell
;; whether these are equal to NIL or not, so
(!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))
+ (aver (not (eq type1 type2)))
+ (values (or (eq type1 *empty-type*)
+ (eq type2 *wild-type*)
+ (eq type2 *universal-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
;; This AVER causes problems if we write accurate methods for the
;; is a compound type which might contain a hairy type) by
;; returning uncertainty.
(values nil nil))
+ ((eq type1 *funcallable-instance-type*)
+ (values (eq type2 (specifier-type 'function)) t))
(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.
+ (aver (not (named-type-p type2)))
+ ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another
+ ;; named type in disguise, TYPE2 is not a superset of TYPE1.
(values nil t))))
(!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))
+ ;; some CONS types can conceal danger
+ ((and (cons-type-p type1) (cons-type-might-be-empty-type type1))
+ (values nil nil))
((type-might-contain-other-types-p type1)
- ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
- ;; disguise. So we'd better delegate.
+ ;; those types can be other types in disguise. So we'd
+ ;; better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (or (eq type2 *instance-type*)
+ (eq type2 *funcallable-instance-type*))
+ (member-type-p type1))
+ ;; member types can be subtypep INSTANCE and
+ ;; FUNCALLABLE-INSTANCE in surprising ways.
+ (invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (eq type2 *extended-sequence-type*) (classoid-p type1))
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (sequencep (find (classoid-layout (find-classoid 'sequence))
+ inherits)))
+ (values (if sequencep t nil) t)))
+ ((and (eq type2 *instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (cond
+ (functionp
+ (values nil t))
+ ((eq type1 (find-classoid 'function))
+ (values nil t))
+ ((or (structure-classoid-p type1)
+ #+nil
+ (condition-classoid-p type1))
+ (values t t))
+ (t (values nil nil))))))
+ ((and (eq type2 *funcallable-instance-type*) (classoid-p type1))
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ (values nil t)
+ (let* ((layout (classoid-layout type1))
+ (inherits (layout-inherits layout))
+ (functionp (find (classoid-layout (find-classoid 'function))
+ inherits)))
+ (values (if functionp t nil) t))))
(t
- ;; FIXME: This seems to rely on there only being 2 or 3
+ ;; FIXME: This seems to rely on there only being 4 or 5
;; NAMED-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))))
+ (values nil 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))
+ (cond
+ ((eq type2 *extended-sequence-type*)
+ (typecase type1
+ (structure-classoid *empty-type*)
+ (classoid
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'sequence))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ nil)))
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ ((eq type2 *instance-type*)
+ (typecase type1
+ (structure-classoid type1)
+ (classoid
+ (if (and (not (member type1 *non-instance-classoid-types*
+ :key #'find-classoid))
+ (not (eq type1 (find-classoid 'function)))
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ *empty-type*))
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ ((eq type2 *funcallable-instance-type*)
+ (typecase type1
+ (structure-classoid *empty-type*)
+ (classoid
+ (if (member type1 *non-instance-classoid-types* :key #'find-classoid)
+ *empty-type*
+ (if (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))
+ type1
+ (if (type= type1 (find-classoid 'function))
+ type2
+ nil))))
+ (fun-type nil)
+ (t
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
+ nil
+ *empty-type*))))
+ (t (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))
+ (cond
+ ((eq type2 *extended-sequence-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'sequence))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ type2)
+ nil))
+ ((eq type2 *instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1))))
+ nil
+ type2)
+ nil))
+ ((eq type2 *funcallable-instance-type*)
+ (if (classoid-p type1)
+ (if (or (member type1 *non-instance-classoid-types*
+ :key #'find-classoid)
+ (not (find (classoid-layout (find-classoid 'function))
+ (layout-inherits (classoid-layout type1)))))
+ nil
+ (if (eq type1 (specifier-type 'function))
+ type1
+ type2))
+ nil))
+ (t (hierarchical-union2 type1 type2))))
(!define-type-method (named :negate) (x)
(aver (not (eq x *wild-type*)))
(cond
((eq x *universal-type*) *empty-type*)
((eq x *empty-type*) *universal-type*)
- (t (bug "NAMED type not universal, wild or empty: ~S" x))))
+ ((or (eq x *instance-type*)
+ (eq x *funcallable-instance-type*)
+ (eq x *extended-sequence-type*))
+ (make-negation-type :type x))
+ (t (bug "NAMED type unexpected: ~S" x))))
(!define-type-method (named :unparse) (x)
(named-type-name x))
(if (csubtypep component-type (specifier-type '(eql 0)))
*empty-type*
(modified-numeric-type component-type
- :complexp :complex))))
+ :complexp :complex)))
+ (do-complex (ctype)
+ (cond
+ ((eq ctype *empty-type*) *empty-type*)
+ ((eq ctype *universal-type*) (not-real))
+ ((typep ctype 'numeric-type) (complex1 ctype))
+ ((typep ctype 'union-type)
+ (apply #'type-union
+ (mapcar #'do-complex (union-type-types ctype))))
+ ((typep ctype 'member-type)
+ (apply #'type-union
+ (mapcar (lambda (x) (do-complex (ctype-of x)))
+ (member-type-members ctype))))
+ ((and (typep ctype 'intersection-type)
+ ;; FIXME: This is very much a
+ ;; not-quite-worst-effort, but we are required to do
+ ;; something here because of our representation of
+ ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
+ ;; allow users to ask about (COMPLEX RATIO). This
+ ;; will of course fail to work right on such types
+ ;; as (AND INTEGER (SATISFIES ZEROP))...
+ (let ((numbers (remove-if-not
+ #'numeric-type-p
+ (intersection-type-types ctype))))
+ (and (car numbers)
+ (null (cdr numbers))
+ (eq (numeric-type-complexp (car numbers)) :real)
+ (complex1 (car numbers))))))
+ (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 a hairy type like (AND NUMBER (SATISFIES
+ ;; REALP) (SATISFIES ZEROP)), 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)))))))
(let ((ctype (specifier-type typespec)))
- (cond
- ((eq ctype *empty-type*) *empty-type*)
- ((eq ctype *universal-type*) (not-real))
- ((typep ctype 'numeric-type) (complex1 ctype))
- ((typep 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))))
- ((typep ctype 'member-type)
- (apply #'type-union
- (mapcar (lambda (x) (complex1 (ctype-of x)))
- (member-type-members ctype))))
- ((and (typep ctype 'intersection-type)
- ;; FIXME: This is very much a
- ;; not-quite-worst-effort, but we are required to do
- ;; something here because of our representation of
- ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must
- ;; allow users to ask about (COMPLEX RATIO). This
- ;; will of course fail to work right on such types
- ;; as (AND INTEGER (SATISFIES ZEROP))...
- (let ((numbers (remove-if-not
- #'numeric-type-p
- (intersection-type-types ctype))))
- (and (car numbers)
- (null (cdr numbers))
- (eq (numeric-type-complexp (car numbers)) :real)
- (complex1 (car numbers))))))
- (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 a hairy type like (AND NUMBER (SATISFIES
- ;; REALP) (SATISFIES ZEROP)), 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)))))))))
+ (do-complex ctype)))))
;;; 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.
(if up-p (1+ cx) (1- cx))
(if up-p (ceiling cx) (floor cx))))
(float
- (let ((res (if format (coerce cx format) (float cx))))
+ (let ((res
+ (cond
+ ((and format (subtypep format 'double-float))
+ (if (<= most-negative-double-float cx most-positive-double-float)
+ (coerce cx format)
+ nil))
+ (t
+ (if (<= most-negative-single-float cx most-positive-single-float)
+ ;; FIXME: bug #389
+ (coerce cx (or format 'single-float))
+ nil)))))
(if (consp x) (list res) res)))))
nil))
(!define-type-class array)
-;;; What this does depends on the setting of the
-;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
-;;; element type, otherwise return the original element type.
-(defun specialized-element-type-maybe (type)
- (declare (type array-type type))
- (if *use-implementation-types*
- (array-type-specialized-element-type type)
- (array-type-element-type type)))
-
(!define-type-method (array :simple-=) (type1 type2)
- (if (or (unknown-type-p (array-type-element-type type1))
- (unknown-type-p (array-type-element-type type2)))
- (multiple-value-bind (equalp certainp)
- (type= (array-type-element-type type1)
- (array-type-element-type type2))
- ;; By its nature, the call to TYPE= should never return NIL,
- ;; T, as we don't know what the UNKNOWN-TYPE will grow up to
- ;; be. -- CSR, 2002-08-19
- (aver (not (and (not equalp) certainp)))
- (values equalp certainp))
- (values (and (equal (array-type-dimensions type1)
+ (cond ((not (and (equal (array-type-dimensions type1)
(array-type-dimensions type2))
(eq (array-type-complexp type1)
- (array-type-complexp type2))
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
- t)))
+ (array-type-complexp type2))))
+ (values nil t))
+ ((or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (multiple-value-bind (equalp certainp)
+ (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ ;; By its nature, the call to TYPE= should never return
+ ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow
+ ;; up to be. -- CSR, 2002-08-19
+ (aver (not (and (not equalp) certainp)))
+ (values equalp certainp)))
+ (t
+ (values (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2))
+ t))))
(!define-type-method (array :negate) (type)
;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
;; if the TYPE2 element type is wild.
((eq (array-type-element-type type2) *wild-type*)
(values t t))
- (;; 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.
+ (;; Since we didn't match any of the special cases above, if
+ ;; either element type is unknown we can only give a good
+ ;; answer if they are the same.
(or (unknown-type-p (array-type-element-type type1))
(unknown-type-p (array-type-element-type type2)))
- (values nil nil))
+ (if (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ (values t t)
+ (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))
+ (values (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2))
t)))))
-;;; FIXME: is this dead?
(!define-superclasses array
- ((base-string base-string)
- (vector vector)
- (array))
+ ((vector vector) (array))
!cold-init-forms)
(defun array-types-intersect (type1 type2)
;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
((or (eq (array-type-specialized-element-type type1) *wild-type*)
(eq (array-type-specialized-element-type type2) *wild-type*)
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
+ (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2)))
(values t t))
(t
(values nil t)))))
+(!define-type-method (array :simple-union2) (type1 type2)
+ (let* ((dims1 (array-type-dimensions type1))
+ (dims2 (array-type-dimensions type2))
+ (complexp1 (array-type-complexp type1))
+ (complexp2 (array-type-complexp type2))
+ (eltype1 (array-type-element-type type1))
+ (eltype2 (array-type-element-type type2))
+ (stype1 (array-type-specialized-element-type type1))
+ (stype2 (array-type-specialized-element-type type2))
+ (wild1 (eq eltype1 *wild-type*))
+ (wild2 (eq eltype2 *wild-type*))
+ (e2 nil))
+ (when (or wild1 wild2
+ (and (or (setf e2 (csubtypep eltype1 eltype2))
+ (csubtypep eltype2 eltype1))
+ (type= stype1 stype2)))
+ (make-array-type
+ :dimensions (cond ((or (eq dims1 '*) (eq dims2 '*))
+ '*)
+ ((equal dims1 dims2)
+ dims1)
+ ((= (length dims1) (length dims2))
+ (mapcar (lambda (x y) (if (eq x y) x '*))
+ dims1 dims2))
+ (t
+ '*))
+ :complexp (if (eq complexp1 complexp2) complexp1 :maybe)
+ :element-type (if (or wild2 e2) eltype2 eltype1)
+ :specialized-element-type (if wild2 stype2 stype1)))))
+
(!define-type-method (array :simple-intersection2) (type1 type2)
(declare (type array-type type1 type2))
(if (array-types-intersect type1 type2)
(complexp1 (array-type-complexp type1))
(complexp2 (array-type-complexp type2))
(eltype1 (array-type-element-type type1))
- (eltype2 (array-type-element-type type2)))
- (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 (cond
- ((eq eltype1 *wild-type*) eltype2)
- ((eq eltype2 *wild-type*) eltype1)
- (t (type-intersection eltype1 eltype2))))))
+ (eltype2 (array-type-element-type type2))
+ (stype1 (array-type-specialized-element-type type1))
+ (stype2 (array-type-specialized-element-type type2)))
+ (flet ((intersect ()
+ (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 (cond
+ ((eq eltype1 *wild-type*) eltype2)
+ ((eq eltype2 *wild-type*) eltype1)
+ (t (type-intersection eltype1 eltype2))))))
+ (if (or (eq stype1 *wild-type*) (eq stype2 *wild-type*))
+ (specialize-array-type (intersect))
+ (let ((type (intersect)))
+ (aver (type= stype1 stype2))
+ (setf (array-type-specialized-element-type type) stype1)
+ type))))
*empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(declare (type ctype type))
- (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
+ (or (find type '(ratio keyword compiled-function) :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
(union-complex-subtypep-arg1 type1 type2))
(defun union-complex-subtypep-arg2 (type1 type2)
+ ;; At this stage, we know that type2 is a union type and type1
+ ;; isn't. We might as well check this, though:
+ (aver (union-type-p type2))
+ (aver (not (union-type-p type1)))
+ ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which
+ ;; turns out to be too restrictive, causing bug 91.
+ ;;
+ ;; the following reimplementation might look dodgy. It is dodgy. It
+ ;; depends on the union :complex-= method not doing very much work
+ ;; -- certainly, not using subtypep. Reasoning:
+ ;;
+ ;; A is a subset of (B1 u B2)
+ ;; <=> A n (B1 u B2) = A
+ ;; <=> (A n B1) u (A n B2) = A
+ ;;
+ ;; But, we have to be careful not to delegate this type= to
+ ;; something that could invoke subtypep, which might get us back
+ ;; here -> stack explosion. We therefore ensure that the second type
+ ;; (which is the one that's dispatched on) is either a union type
+ ;; (where we've ensured that the complex-= method will not call
+ ;; subtypep) or something with no union types involved, in which
+ ;; case we'll never come back here.
+ ;;
+ ;; If we don't do this, then e.g.
+ ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; would loop infinitely, as the member :complex-= method is
+ ;; implemented in terms of subtypep.
+ ;;
+ ;; Ouch. - CSR, 2002-04-10
(multiple-value-bind (sub-value sub-certain?)
- ;; was: (any/type #'csubtypep type1 (union-type-types type2)),
- ;; which turns out to be too restrictive, causing bug 91.
- ;;
- ;; the following reimplementation might look dodgy. It is
- ;; dodgy. It depends on the union :complex-= method not doing
- ;; very much work -- certainly, not using subtypep. Reasoning:
- (progn
- ;; At this stage, we know that type2 is a union type and type1
- ;; isn't. We might as well check this, though:
- (aver (union-type-p type2))
- (aver (not (union-type-p type1)))
- ;; A is a subset of (B1 u B2)
- ;; <=> A n (B1 u B2) = A
- ;; <=> (A n B1) u (A n B2) = A
- ;;
- ;; But, we have to be careful not to delegate this type= to
- ;; something that could invoke subtypep, which might get us
- ;; back here -> stack explosion. We therefore ensure that the
- ;; second type (which is the one that's dispatched on) is
- ;; either a union type (where we've ensured that the complex-=
- ;; method will not call subtypep) or something with no union
- ;; types involved, in which case we'll never come back here.
- ;;
- ;; If we don't do this, then e.g.
- ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR)))
- ;; would loop infinitely, as the member :complex-= method is
- ;; implemented in terms of subtypep.
- ;;
- ;; Ouch. - CSR, 2002-04-10
- (type= type1
- (apply #'type-union
- (mapcar (lambda (x) (type-intersection type1 x))
- (union-type-types type2)))))
+ (type= type1
+ (apply #'type-union
+ (mapcar (lambda (x) (type-intersection type1 x))
+ (union-type-types type2))))
(if sub-certain?
(values sub-value sub-certain?)
;; The ANY/TYPE expression above is a sufficient condition for
(!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))))
+ (multiple-value-bind (car-match car-win)
+ (type= (cons-type-car-type type1) (cons-type-car-type type2))
+ (multiple-value-bind (cdr-match cdr-win)
+ (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+ (cond ((and car-match cdr-match)
+ (aver (and car-win cdr-win))
+ (values t t))
+ (t
+ (values nil
+ ;; FIXME: Ideally we would like to detect and handle
+ ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T
+ ;; but just returning a secondary true on (and car-win cdr-win)
+ ;; unfortunately breaks other things. --NS 2006-08-16
+ (and (or (and (not car-match) car-win)
+ (and (not cdr-match) cdr-win))
+ (not (and (cons-type-might-be-empty-type type1)
+ (cons-type-might-be-empty-type type2))))))))))
(!define-type-method (cons :simple-subtypep) (type1 type2)
(declare (type cons-type type1 type2))
(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))))))
+ (values nil (or (and (not val-car) win-car)
+ (and (not val-cdr) win-cdr)))))))
;;; Give up if a precise type is not possible, to avoid returning
;;; overly general types.
;; more general case of the above, but harder to compute
((progn
(setf car-not1 (type-negation car-type1))
- (not (csubtypep car-type2 car-not1)))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type2 car-not1)
+ (and (not yes) win)))
(frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
((progn
(setf car-not2 (type-negation car-type2))
- (not (csubtypep car-type1 car-not2)))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type1 car-not2)
+ (and (not yes) win)))
(frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
;; Don't put these in -- consider the effect of taking the
;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
(type-intersection (cons-type-car-type type1)
(cons-type-car-type type2))
cdr-int2)))))
+
+(!define-superclasses cons ((cons)) !cold-init-forms)
\f
;;;; CHARACTER-SET types
(!define-type-method (character-set :negate) (type)
(let ((pairs (character-set-type-pairs type)))
(if (and (= (length pairs) 1)
- (= (caar pairs) 0)
- (= (cdar pairs) (1- sb!xc:char-code-limit)))
- (make-negation-type :type type)
- (let ((not-character
- (make-negation-type
- :type (make-character-set-type
- :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
- (type-union
- not-character
- (make-character-set-type
- :pairs (let (not-pairs)
- (when (> (caar pairs) 0)
- (push (cons 0 (1- (caar pairs))) not-pairs))
- (do* ((tail pairs (cdr tail))
- (high1 (cdar tail))
- (low2 (caadr tail)))
- ((null (cdr tail))
- (when (< (cdar tail) (1- sb!xc:char-code-limit))
- (push (cons (1+ (cdar tail))
- (1- sb!xc:char-code-limit))
- not-pairs))
- (nreverse not-pairs))
- (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
+ (= (caar pairs) 0)
+ (= (cdar pairs) (1- sb!xc:char-code-limit)))
+ (make-negation-type :type type)
+ (let ((not-character
+ (make-negation-type
+ :type (make-character-set-type
+ :pairs '((0 . #.(1- sb!xc:char-code-limit)))))))
+ (type-union
+ not-character
+ (make-character-set-type
+ :pairs (let (not-pairs)
+ (when (> (caar pairs) 0)
+ (push (cons 0 (1- (caar pairs))) not-pairs))
+ (do* ((tail pairs (cdr tail))
+ (high1 (cdar tail) (cdar tail))
+ (low2 (caadr tail) (caadr tail)))
+ ((null (cdr tail))
+ (when (< (cdar tail) (1- sb!xc:char-code-limit))
+ (push (cons (1+ (cdar tail))
+ (1- sb!xc:char-code-limit))
+ not-pairs))
+ (nreverse not-pairs))
+ (push (cons (1+ high1) (1- low2)) not-pairs)))))))))
(!define-type-method (character-set :unparse) (type)
(cond
(!define-type-method (character-set :simple-intersection2) (type1 type2)
;; KLUDGE: brute force.
+#|
(let (pairs)
(dolist (pair1 (character-set-type-pairs type1)
(make-character-set-type
((<= (car pair1) (car pair2) (cdr pair1))
(push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs))
((<= (car pair2) (car pair1) (cdr pair2))
- (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs)))))))
+ (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs))))))
+|#
+ (make-character-set-type
+ :pairs (intersect-type-pairs
+ (character-set-type-pairs type1)
+ (character-set-type-pairs type2))))
+
+;;;
+;;; Intersect two ordered lists of pairs
+;;; Each list is of the form ((start1 . end1) ... (startn . endn)),
+;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn.
+;;; Each pair represents the integer interval start..end.
+;;;
+(defun intersect-type-pairs (alist1 alist2)
+ (if (and alist1 alist2)
+ (let ((res nil)
+ (pair1 (pop alist1))
+ (pair2 (pop alist2)))
+ (loop
+ (when (> (car pair1) (car pair2))
+ (rotatef pair1 pair2)
+ (rotatef alist1 alist2))
+ (let ((pair1-cdr (cdr pair1)))
+ (cond
+ ((> (car pair2) pair1-cdr)
+ ;; No over lap -- discard pair1
+ (unless alist1 (return))
+ (setq pair1 (pop alist1)))
+ ((<= (cdr pair2) pair1-cdr)
+ (push (cons (car pair2) (cdr pair2)) res)
+ (cond
+ ((= (cdr pair2) pair1-cdr)
+ (unless alist1 (return))
+ (unless alist2 (return))
+ (setq pair1 (pop alist1)
+ pair2 (pop alist2)))
+ (t ;; (< (cdr pair2) pair1-cdr)
+ (unless alist2 (return))
+ (setq pair1 (cons (1+ (cdr pair2)) pair1-cdr))
+ (setq pair2 (pop alist2)))))
+ (t ;; (> (cdr pair2) (cdr pair1))
+ (push (cons (car pair2) pair1-cdr) res)
+ (unless alist1 (return))
+ (setq pair2 (cons (1+ pair1-cdr) (cdr pair2)))
+ (setq pair1 (pop alist1))))))
+ (nreverse res))
+ nil))
+
\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.
projects / sbcl.git / blobdiff