X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=007950a4e5f06f8f070d29a2e2464428b013fe5e;hb=6fa968aaa8051da23cc3153a1c0e67addbea85f6;hp=785749f56631e5f0250faf828f04257fce8dc628;hpb=4c4635c16dc6fb5fcc6adbaea9fba756083c04a2;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 785749f..007950a 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) @@ -849,7 +843,6 @@ (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 @@ -1048,7 +1041,21 @@ ;; 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*))) @@ -1096,7 +1103,10 @@ (!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 @@ -1122,50 +1132,172 @@ ;; 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)) - ((or (type-might-contain-other-types-p type1) - (and (cons-type-p type1) - (cons-type-might-be-empty-type type1))) - ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in - ;; disguise. So we'd better delegate. + ;; 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 *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)) @@ -2026,13 +2158,12 @@ used for a COMPLEX component.~:@>" ((and format (subtypep format 'double-float)) (if (<= most-negative-double-float cx most-positive-double-float) (coerce cx format) - (if (< x most-negative-double-float) - most-negative-double-float most-positive-double-float))) + nil)) (t (if (<= most-negative-single-float cx most-positive-single-float) - (coerce cx format) - (if (< x most-negative-single-float) - most-negative-single-float most-positive-single-float)))))) + ;; FIXME: bug #389 + (coerce cx (or format 'single-float)) + nil))))) (if (consp x) (list res) res))))) nil)) @@ -2148,33 +2279,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 @@ -2246,25 +2370,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) @@ -2307,13 +2431,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) @@ -2322,19 +2476,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, @@ -2529,7 +2691,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 @@ -2721,40 +2883,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 @@ -2863,8 +3025,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)) @@ -2911,11 +3088,15 @@ used for a COMPLEX component.~:@>" ;; 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 @@ -2943,6 +3124,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 @@ -2955,29 +3138,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