X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=0e284b08757796f1c4ef681d7ccd46ebf9241595;hb=a682f4c392bc874a6a898632889319ebdd8821fc;hp=08adf4daadfd9596803308412ac4ad3b1d1bf4b4;hpb=bb471853b088e65a3e7821b6ab23494c4fe67af3;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 08adf4d..0e284b0 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -30,18 +30,6 @@ (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 @@ -804,19 +792,25 @@ ;; 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) @@ -1148,13 +1142,19 @@ (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((or (type-might-contain-other-types-p type1) - ;; some CONS types can conceal danger - (and (cons-type-p type1) - (cons-type-might-be-empty-type type1))) + ;; 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 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) @@ -1167,7 +1167,7 @@ (values nil t)) ((eq type1 (find-classoid 'function)) (values nil t)) - ((or (basic-structure-classoid-p type1) + ((or (structure-classoid-p type1) #+nil (condition-classoid-p type1)) (values t t)) @@ -1193,31 +1193,39 @@ ;;(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 (find (classoid-layout (find-classoid 'function)) - (layout-inherits (classoid-layout type1))))) - type1 - *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)) - type1 - 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 (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) @@ -2118,7 +2126,8 @@ used for a COMPLEX component.~:@>" nil)) (t (if (<= most-negative-single-float cx most-positive-single-float) - (coerce cx format) + ;; FIXME: bug #389 + (coerce cx (or format 'single-float)) nil))))) (if (consp x) (list res) res))))) nil)) @@ -2235,33 +2244,26 @@ used for a COMPLEX component.~:@>" (!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 @@ -2333,25 +2335,25 @@ used for a COMPLEX component.~:@>" ;; 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) @@ -2394,13 +2396,43 @@ used for a COMPLEX component.~:@>" ;; 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) @@ -2409,19 +2441,27 @@ used for a COMPLEX component.~:@>" (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, @@ -2616,7 +2656,7 @@ used for a COMPLEX component.~:@>" ;;; 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 @@ -2808,40 +2848,40 @@ used for a COMPLEX component.~:@>" (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 @@ -2950,8 +2990,23 @@ used for a COMPLEX component.~:@>" (!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)) @@ -3034,6 +3089,8 @@ used for a COMPLEX component.~:@>" (type-intersection (cons-type-car-type type1) (cons-type-car-type type2)) cdr-int2))))) + +(!define-superclasses cons ((cons)) !cold-init-forms) ;;;; CHARACTER-SET types @@ -3046,29 +3103,29 @@ used for a COMPLEX component.~:@>" (!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