X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=190c42bb47992179229cf248b00a073d8fd91be1;hb=3893e84021b2466d34e44e97340b96c6325a4b8d;hp=aaf42133265641175117396696648d39c8b565b9;hpb=5ec5d0e068ab2b6435e0c841d686a95dbd58cbc4;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index aaf4213..190c42b 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 @@ -370,17 +358,80 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (make-fun-type :args args - :returns (coerce-to-values (values-specifier-type result)))) + (let ((result (coerce-to-values (values-specifier-type result)))) + (if (eq args '*) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result)) + (multiple-value-bind (required optional rest keyp keywords allowp) + (parse-args-types args) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not keyp)) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result)) + (make-fun-type :required required + :optional optional + :rest rest + :keyp keyp + :keywords keywords + :allowp allowp + :returns result)))))) (!def-type-translator values (&rest values) - (make-values-type :args values)) + (if (eq values '*) + *wild-type* + (multiple-value-bind (required optional rest keyp keywords allowp llk-p) + (parse-args-types values) + (declare (ignore keywords)) + (cond (keyp + (error "&KEY appeared in a VALUES type specifier ~S." + `(values ,@values))) + (llk-p + (make-values-type :required required + :optional optional + :rest rest + :allowp allowp)) + (t + (make-short-values-type required)))))) ;;;; VALUES types interfaces ;;;; ;;;; We provide a few special operations that can be meaningfully used ;;;; on VALUES types (as well as on any other type). +;;; Return the minimum number of values possibly matching VALUES type +;;; TYPE. +(defun values-type-min-value-count (type) + (etypecase type + (named-type + (ecase (named-type-name type) + ((t *) 0) + ((nil) 0))) + (values-type + (length (values-type-required type))))) + +;;; Return the maximum number of values possibly matching VALUES type +;;; TYPE. +(defun values-type-max-value-count (type) + (etypecase type + (named-type + (ecase (named-type-name type) + ((t *) call-arguments-limit) + ((nil) 0))) + (values-type + (if (values-type-rest type) + call-arguments-limit + (+ (length (values-type-optional type)) + (length (values-type-required type))))))) + +(defun values-type-may-be-single-value-p (type) + (<= (values-type-min-value-count type) + 1 + (values-type-max-value-count type))) + (defun type-single-value-p (type) (and (values-type-p type) (not (values-type-rest type)) @@ -804,19 +855,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) @@ -1057,7 +1114,11 @@ ;; required to be a subclass of STANDARD-OBJECT. -- CSR, ;; 2005-09-09 (frob instance *instance-type*) - (frob funcallable-instance *funcallable-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*))) @@ -1148,10 +1209,10 @@ (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)) @@ -1161,6 +1222,12 @@ ;; 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) @@ -1198,46 +1265,70 @@ ;; Perhaps when bug 85 is fixed it can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (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*) - (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 (or (type-might-contain-other-types-p type1) - (member-type-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 (or (type-might-contain-other-types-p type1) - (member-type-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) ;; Perhaps when bug 85 is fixed this can be reenabled. ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. (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* @@ -1266,7 +1357,8 @@ ((eq x *universal-type*) *empty-type*) ((eq x *empty-type*) *universal-type*) ((or (eq x *instance-type*) - (eq x *funcallable-instance-type*)) + (eq x *funcallable-instance-type*) + (eq x *extended-sequence-type*)) (make-negation-type :type x)) (t (bug "NAMED type unexpected: ~S" x)))) @@ -1290,7 +1382,15 @@ (values nil nil))))) (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) - (invoke-complex-subtypep-arg1-method type1 type2)) + (let ((specifier (hairy-type-specifier type2))) + (cond + ((and (consp specifier) (eql (car specifier) 'satisfies)) + (case (cadr specifier) + ((keywordp) (if (type= type1 (specifier-type 'symbol)) + (values nil t) + (invoke-complex-subtypep-arg1-method type1 type2))) + (t (invoke-complex-subtypep-arg1-method type1 type2)))) + (t (invoke-complex-subtypep-arg1-method type1 type2))))) (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2) (declare (ignore type1 type2)) @@ -1472,11 +1572,26 @@ (aver (not (eq (type-union not1 not2) *universal-type*))) nil)))) +(defun maybe-complex-array-refinement (type1 type2) + (let* ((ntype (negation-type-type type2)) + (ndims (array-type-dimensions ntype)) + (ncomplexp (array-type-complexp ntype)) + (nseltype (array-type-specialized-element-type ntype)) + (neltype (array-type-element-type ntype))) + (if (and (eql ndims '*) (null ncomplexp) + (eql neltype *wild-type*) (eql nseltype *wild-type*)) + (make-array-type :dimensions (array-type-dimensions type1) + :complexp t + :element-type (array-type-element-type type1) + :specialized-element-type (array-type-specialized-element-type type1))))) + (!define-type-method (negation :complex-intersection2) (type1 type2) (cond ((csubtypep type1 (negation-type-type type2)) *empty-type*) ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) type1) + ((and (array-type-p type1) (array-type-p (negation-type-type type2))) + (maybe-complex-array-refinement type1 type2)) (t nil))) (!define-type-method (negation :simple-union2) (type1 type2) @@ -1853,8 +1968,9 @@ (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)))) + (mapcar-member-type-members + (lambda (x) (do-complex (ctype-of x))) + ctype))) ((and (typep ctype 'intersection-type) ;; FIXME: This is very much a ;; not-quite-worst-effort, but we are required to do @@ -2250,15 +2366,6 @@ 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) (cond ((not (and (equal (array-type-dimensions type1) (array-type-dimensions type2)) @@ -2276,8 +2383,8 @@ used for a COMPLEX component.~:@>" (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) @@ -2292,21 +2399,31 @@ used for a COMPLEX component.~:@>" (complexp (array-type-complexp type))) (cond ((eq dims '*) (if (eq eltype '*) - (if complexp 'array 'simple-array) - (if complexp `(array ,eltype) `(simple-array ,eltype)))) + (ecase complexp + ((t) '(and array (not simple-array))) + ((:maybe) 'array) + ((nil) 'simple-array)) + (ecase complexp + ((t) `(and (array ,eltype) (not simple-array))) + ((:maybe) `(array ,eltype)) + ((nil) `(simple-array ,eltype))))) ((= (length dims) 1) (if complexp - (if (eq (car dims) '*) - (case eltype - (bit 'bit-vector) - ((base-char #!-sb-unicode character) 'base-string) - (* 'vector) - (t `(vector ,eltype))) - (case eltype - (bit `(bit-vector ,(car dims))) - ((base-char #!-sb-unicode character) - `(base-string ,(car dims))) - (t `(vector ,eltype ,(car dims))))) + (let ((answer + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((base-char #!-sb-unicode character) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((base-char #!-sb-unicode character) + `(base-string ,(car dims))) + (t `(vector ,eltype ,(car dims))))))) + (if (eql complexp :maybe) + answer + `(and ,answer (not simple-array)))) (if (eq (car dims) '*) (case eltype (bit 'simple-bit-vector) @@ -2320,9 +2437,10 @@ used for a COMPLEX component.~:@>" ((t) `(simple-vector ,(car dims))) (t `(simple-array ,eltype ,dims)))))) (t - (if complexp - `(array ,eltype ,dims) - `(simple-array ,eltype ,dims)))))) + (ecase complexp + ((t) `(and (array ,eltype ,dims) (not simple-array))) + ((:maybe) `(array ,eltype ,dims)) + ((nil) `(simple-array ,eltype ,dims))))))) (!define-type-method (array :simple-subtypep) (type1 type2) (let ((dims1 (array-type-dimensions type1)) @@ -2363,15 +2481,12 @@ used for a COMPLEX component.~:@>" ;; 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) @@ -2414,13 +2529,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) @@ -2429,19 +2574,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, @@ -2473,39 +2626,28 @@ used for a COMPLEX component.~:@>" (!define-type-class member) (!define-type-method (member :negate) (type) - (let ((members (member-type-members type))) - (if (some #'floatp members) - (let (floats) - (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero))) - (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero))) - #!+long-float - (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero))))) - (when (member (car pair) members) - (aver (not (member (cdr pair) members))) - (push (cdr pair) floats) - (setf members (remove (car pair) members))) - (when (member (cdr pair) members) - (aver (not (member (car pair) members))) - (push (car pair) floats) - (setf members (remove (cdr pair) members)))) - (apply #'type-intersection - (if (null members) - *universal-type* + (let ((xset (member-type-xset type)) + (fp-zeroes (member-type-fp-zeroes type))) + (if fp-zeroes + ;; Hairy case, which needs to do a bit of float type + ;; canonicalization. + (apply #'type-intersection + (if (xset-empty-p xset) + *universal-type* + (make-negation-type + :type (make-member-type :xset xset))) + (mapcar + (lambda (x) + (let* ((opposite (neg-fp-zero x)) + (type (ctype-of opposite))) + (type-union (make-negation-type - :type (make-member-type :members members))) - (mapcar - (lambda (x) - (let ((type (ctype-of x))) - (type-union - (make-negation-type - :type (modified-numeric-type type - :low nil :high nil)) - (modified-numeric-type type - :low nil :high (list x)) - (make-member-type :members (list x)) - (modified-numeric-type type - :low (list x) :high nil)))) - floats))) + :type (modified-numeric-type type :low nil :high nil)) + (modified-numeric-type type :low nil :high (list opposite)) + (make-member-type :members (list opposite)) + (modified-numeric-type type :low (list opposite) :high nil)))) + fp-zeroes)) + ;; Easy case (make-negation-type :type type)))) (!define-type-method (member :unparse) (type) @@ -2516,13 +2658,23 @@ used for a COMPLEX component.~:@>" (t `(member ,@members))))) (!define-type-method (member :simple-subtypep) (type1 type2) - (values (subsetp (member-type-members type1) (member-type-members type2)) - t)) + (values (and (xset-subset-p (member-type-xset type1) + (member-type-xset type2)) + (subsetp (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2))) + t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) - (every/type (swapped-args-fun #'ctypep) - type2 - (member-type-members type1))) + (block punt + (mapc-member-type-members + (lambda (elt) + (multiple-value-bind (ok surep) (ctypep elt type2) + (unless surep + (return-from punt (values nil nil))) + (unless ok + (return-from punt (values nil t))))) + type1) + (values t t))) ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a @@ -2534,46 +2686,48 @@ used for a COMPLEX component.~:@>" (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) - (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) - (cond ((subsetp mem1 mem2) type1) - ((subsetp mem2 mem1) type2) - (t - (let ((res (intersection mem1 mem2))) - (if res - (make-member-type :members res) - *empty-type*)))))) + (make-member-type :xset (xset-intersection (member-type-xset type1) + (member-type-xset type2)) + :fp-zeroes (intersection (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2)))) (!define-type-method (member :complex-intersection2) (type1 type2) (block punt - (collect ((members)) - (let ((mem2 (member-type-members type2))) - (dolist (member mem2) - (multiple-value-bind (val win) (ctypep member type1) - (unless win - (return-from punt nil)) - (when val (members member)))) - (cond ((subsetp mem2 (members)) type2) - ((null (members)) *empty-type*) - (t - (make-member-type :members (members)))))))) + (let ((xset (alloc-xset)) + (fp-zeroes nil)) + (mapc-member-type-members + (lambda (member) + (multiple-value-bind (ok sure) (ctypep member type1) + (unless sure + (return-from punt nil)) + (when ok + (if (fp-zero-p member) + (pushnew member fp-zeroes) + (add-to-xset member xset))))) + type2) + (if (and (xset-empty-p xset) (not fp-zeroes)) + *empty-type* + (make-member-type :xset xset :fp-zeroes fp-zeroes))))) ;;; We don't need a :COMPLEX-UNION2, since the only interesting case is ;;; a union type, and the member/union interaction is handled by the ;;; union type method. (!define-type-method (member :simple-union2) (type1 type2) - (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) - (cond ((subsetp mem1 mem2) type2) - ((subsetp mem2 mem1) type1) - (t - (make-member-type :members (union mem1 mem2)))))) + (make-member-type :xset (xset-union (member-type-xset type1) + (member-type-xset type2)) + :fp-zeroes (union (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2)))) (!define-type-method (member :simple-=) (type1 type2) - (let ((mem1 (member-type-members type1)) - (mem2 (member-type-members type2))) - (values (and (subsetp mem1 mem2) - (subsetp mem2 mem1)) + (let ((xset1 (member-type-xset type1)) + (xset2 (member-type-xset type2)) + (l1 (member-type-fp-zeroes type1)) + (l2 (member-type-fp-zeroes type2))) + (values (and (eql (xset-count xset1) (xset-count xset2)) + (xset-subset-p xset1 xset2) + (xset-subset-p xset2 xset1) + (subsetp l1 l2) + (subsetp l2 l1)) t))) (!define-type-method (member :complex-=) (type1 type2) @@ -2636,7 +2790,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 @@ -2828,40 +2982,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 @@ -3069,6 +3223,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 @@ -3081,29 +3237,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 @@ -3224,14 +3380,20 @@ used for a COMPLEX component.~:@>" (collect ((res)) (dolist (x-type x-types) (if (member-type-p x-type) - (collect ((members)) - (dolist (mem (member-type-members x-type)) - (multiple-value-bind (val win) (ctypep mem y) - (unless win (return-from type-difference nil)) - (unless val - (members mem)))) - (when (members) - (res (make-member-type :members (members))))) + (let ((xset (alloc-xset)) + (fp-zeroes nil)) + (mapc-member-type-members + (lambda (elt) + (multiple-value-bind (ok sure) (ctypep elt y) + (unless sure + (return-from type-difference nil)) + (unless ok + (if (fp-zero-p elt) + (pushnew elt fp-zeroes) + (add-to-xset elt xset))))) + x-type) + (unless (and (xset-empty-p xset) (not fp-zeroes)) + (res (make-member-type :xset xset :fp-zeroes fp-zeroes)))) (dolist (y-type y-types (res x-type)) (multiple-value-bind (val win) (csubtypep x-type y-type) (unless win (return-from type-difference nil)) @@ -3240,13 +3402,14 @@ used for a COMPLEX component.~:@>" (return-from type-difference nil)))))) (let ((y-mem (find-if #'member-type-p y-types))) (when y-mem - (let ((members (member-type-members y-mem))) - (dolist (x-type x-types) - (unless (member-type-p x-type) - (dolist (member members) - (multiple-value-bind (val win) (ctypep member x-type) - (when (or (not win) val) - (return-from type-difference nil))))))))) + (dolist (x-type x-types) + (unless (member-type-p x-type) + (mapc-member-type-members + (lambda (member) + (multiple-value-bind (ok sure) (ctypep member x-type) + (when (or (not sure) ok) + (return-from type-difference nil)))) + y-mem))))) (apply #'type-union (res))))) (!def-type-translator array (&optional (element-type '*)