(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
;; 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)
;; 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 *instance-type*) (classoid-p type1))
(if (member type1 *non-instance-classoid-types* :key #'find-classoid)
(values nil t)
;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
(cond
((eq type2 *instance-type*)
- (if (classoid-p type1)
- (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)))))
- (if (or (structure-classoid-p type1)
- (and (not (eq type1 (find-classoid 'stream)))
- (not (find (classoid-layout (find-classoid 'stream))
- (layout-inherits (classoid-layout type1))))))
- type1
- nil)
- *empty-type*)
- (if (type-might-contain-other-types-p type1)
- nil
- *empty-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*)
- (if (classoid-p type1)
- (if (and (not (member type1 *non-instance-classoid-types*
- :key #'find-classoid))
- (find (classoid-layout (find-classoid 'function))
- (layout-inherits (classoid-layout type1))))
- type1
- (if (type= type1 (find-classoid 'function))
- type2
- nil))
- (if (fun-type-p type1)
- nil
- (if (type-might-contain-other-types-p type1)
- nil
- *empty-type*))))
+ (typecase type1
+ (structure-classoid *empty-type*)
+ (classoid
+ (if (and (not (member type1 *non-instance-classoid-types*
+ :key #'find-classoid))
+ (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)
(!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)
(cond ((not (and (equal (array-type-dimensions type1)
(array-type-dimensions type2))
(aver (not (and (not equalp) certainp)))
(values equalp certainp)))
(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))))
(!define-type-method (array :negate) (type)
;; 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?
;; 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))