X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=623ff1cb3e237901ca7572c65d5bee8007c4b7c7;hb=05449b9101cdf156f48e7cf935d3874dc7cbadeb;hp=f867fc9ad65b55884fb0849e33711cdc4d5b93f5;hpb=f319c3261c5eeb9c96dd003d7bb87664e0eea2fa;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index f867fc9..623ff1c 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -237,13 +237,19 @@ (multiple-value-bind (val2 win2) ,y (if (and val1 val2) (values t t) - (values nil (or win1 win2)))))))) + (values nil (and win2 (not val2))))))))) (3and (values-subtypep (fun-type-returns type1) (fun-type-returns type2)) (cond ((fun-type-wild-args type2) (values t t)) - ((fun-type-wild-args type1) (values nil t)) - ((not (or (fun-type-simple-p type1) - (fun-type-simple-p type2))) + ((fun-type-wild-args type1) + (cond ((fun-type-keyp type2) (values nil nil)) + ((not (fun-type-rest type2)) (values nil t)) + ((not (null (fun-type-required type2))) (values nil t)) + (t (3and (type= *universal-type* (fun-type-rest type2)) + (every/type #'type= *universal-type* + (fun-type-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) (values nil nil)) (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) (multiple-value-bind (min2 max2) (fun-type-nargs type2) @@ -298,9 +304,12 @@ (declare (ignore aux)) ; since we require AUXP=NIL (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) - (setf (args-type-required result) (mapcar #'specifier-type required)) - (setf (args-type-optional result) (mapcar #'specifier-type optional)) - (setf (args-type-rest result) (if restp (specifier-type rest) nil)) + (setf (args-type-required result) + (mapcar #'single-value-specifier-type required)) + (setf (args-type-optional result) + (mapcar #'single-value-specifier-type optional)) + (setf (args-type-rest result) + (if restp (single-value-specifier-type rest) nil)) (setf (args-type-keyp result) keyp) (collect ((key-info)) (dolist (key keys) @@ -311,7 +320,7 @@ (error "~@" kwd lambda-list)) (key-info (make-key-info :name kwd - :type (specifier-type (second key)))))) + :type (single-value-specifier-type (second key)))))) (setf (args-type-keywords result) (key-info))) (setf (args-type-allowp result) allowp) (values))) @@ -353,7 +362,7 @@ res)) (!def-type-translator values (&rest values) - (let ((res (make-values-type))) + (let ((res (%make-values-type))) (parse-args-types values res) res)) @@ -445,7 +454,7 @@ :initial-element rest2))) exact))) -;;; If Type isn't a values type, then make it into one: +;;; If TYPE isn't a values type, then make it into one: ;;; ==> (values type &rest t) (defun coerce-to-values (type) (declare (type ctype type)) @@ -479,6 +488,8 @@ (defun args-type-op (type1 type2 operation nreq default-type) (declare (type ctype type1 type2 default-type) (type function operation nreq)) + (when (eq type1 type2) + (values type1 t)) (if (or (values-type-p type1) (values-type-p type2)) (let ((type1 (coerce-to-values type1)) (type2 (coerce-to-values type2))) @@ -620,12 +631,13 @@ :complex-arg1 :complex-subtypep-arg1)))) ;;; Just parse the type specifiers and call CSUBTYPE. -(defun sb!xc:subtypep (type1 type2) +(defun sb!xc:subtypep (type1 type2 &optional environment) #!+sb-doc "Return two values indicating the relationship between type1 and type2. If values are T and T, type1 definitely is a subtype of type2. If values are NIL and T, type1 definitely is not a subtype of type2. If values are NIL and NIL, it couldn't be determined." + (declare (ignore environment)) (csubtypep (specifier-type type1) (specifier-type type2))) ;;; If two types are definitely equivalent, return true. The second @@ -825,7 +837,7 @@ (defun accumulate1-compound-type (type types %compound-type-p simplify2) (declare (type ctype type)) (declare (type (vector ctype) types)) - (declare (type function simplify2)) + (declare (type function %compound-type-p simplify2)) ;; Any input object satisfying %COMPOUND-TYPE-P should've been ;; broken into components before it reached us. (aver (not (funcall %compound-type-p type))) @@ -914,6 +926,11 @@ nil))) (defun type-intersection (&rest input-types) + (%type-intersection input-types)) +(defun-cached (%type-intersection :hash-bits 8 + :hash-function (lambda (x) + (logand (sxhash x) #xff))) + ((input-types equal)) (let ((simplified-types (simplified-compound-types input-types #'intersection-type-p #'type-intersection2))) @@ -946,10 +963,15 @@ *universal-type*)))) (defun type-union (&rest input-types) + (%type-union input-types)) +(defun-cached (%type-union :hash-bits 8 + :hash-function (lambda (x) + (logand (sxhash x) #xff))) + ((input-types equal)) (let ((simplified-types (simplified-compound-types input-types #'union-type-p #'type-union2))) - (make-compound-type-or-something #'%make-union-type + (make-compound-type-or-something #'make-union-type simplified-types (every #'type-enumerable simplified-types) *empty-type*))) @@ -1035,7 +1057,7 @@ (invoke-complex-subtypep-arg1-method type1 type2)) (t ;; FIXME: This seems to rely on there only being 2 or 3 - ;; HAIRY-TYPE values, and the exclusion of various + ;; 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)))) @@ -1062,146 +1084,40 @@ (!define-type-method (hairy :simple-subtypep) (type1 type2) (let ((hairy-spec1 (hairy-type-specifier type1)) (hairy-spec2 (hairy-type-specifier type2))) - (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not) - (consp hairy-spec2) (eq (car hairy-spec2) 'not)) - (csubtypep (specifier-type (cadr hairy-spec2)) - (specifier-type (cadr hairy-spec1)))) - ((equal hairy-spec1 hairy-spec2) + (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) (values t t)) (t (values nil nil))))) (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) - (let ((hairy-spec (hairy-type-specifier type2))) - (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not)) - (let* ((complement-type2 (specifier-type (cadr hairy-spec))) - (intersection2 (type-intersection2 type1 - complement-type2))) - (if intersection2 - (values (eq intersection2 *empty-type*) t) - (invoke-complex-subtypep-arg1-method type1 type2)))) - (t - (invoke-complex-subtypep-arg1-method type1 type2))))) + (invoke-complex-subtypep-arg1-method type1 type2)) (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2) - ;; "Incrementally extended heuristic algorithms tend inexorably toward the - ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt - (let ((hairy-spec (hairy-type-specifier type1))) - (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not)) - ;; You may not believe this. I couldn't either. But then I - ;; sat down and drew lots of Venn diagrams. Comments - ;; involving a and b refer to the call (subtypep '(not a) - ;; 'b) -- CSR, 2002-02-27. - (block nil - ;; (Several logical truths in this block are true as - ;; long as b/=T. As of sbcl-0.7.1.28, it seems - ;; impossible to construct a case with b=T where we - ;; actually reach this type method, but we'll test for - ;; and exclude this case anyway, since future - ;; maintenance might make it possible for it to end up - ;; in this code.) - (multiple-value-bind (equal certain) - (type= type2 (specifier-type t)) - (unless certain - (return (values nil nil))) - (when equal - (return (values t t)))) - (let ((complement-type1 (specifier-type (cadr hairy-spec)))) - ;; Do the special cases first, in order to give us a - ;; chance if subtype/supertype relationships are hairy. - (multiple-value-bind (equal certain) - (type= complement-type1 type2) - ;; If a = b, ~a is not a subtype of b (unless b=T, - ;; which was excluded above). - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) - ;; KLUDGE: ANSI requires that the SUBTYPEP result - ;; between any two built-in atomic type specifiers - ;; never be uncertain. This is hard to do cleanly for - ;; the built-in types whose definitions include - ;; (NOT FOO), i.e. CONS and RATIO. However, we can do - ;; it with this hack, which uses our global knowledge - ;; that our implementation of the type system uses - ;; disjoint implementation types to represent disjoint - ;; sets (except when types are contained in other types). - ;; (This is a KLUDGE because it's fragile. Various - ;; changes in internal representation in the type - ;; system could make it start confidently returning - ;; incorrect results.) -- WHN 2002-03-08 - (unless (or (type-might-contain-other-types-p complement-type1) - (type-might-contain-other-types-p type2)) - ;; Because of the way our types which don't contain - ;; other types are disjoint subsets of the space of - ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when - ;; AA and B are simple (and B is not T, as checked above). - (return (values nil t))) - ;; The old (TYPE= TYPE1 TYPE2) branch would never be - ;; taken, as TYPE1 and TYPE2 will only be equal if - ;; they're both NOT types, and then the - ;; :SIMPLE-SUBTYPEP method would be used instead. - ;; But a CSUBTYPEP relationship might still hold: - (multiple-value-bind (equal certain) - (csubtypep complement-type1 type2) - ;; If a is a subtype of b, ~a is not a subtype of b - ;; (unless b=T, which was excluded above). - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) - (multiple-value-bind (equal certain) - (csubtypep type2 complement-type1) - ;; If b is a subtype of a, ~a is not a subtype of b. - ;; (FIXME: That's not true if a=T. Do we know at - ;; this point that a is not T?) - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) - ;; old CSR comment ca. 0.7.2, now obsoleted by the - ;; SIMPLE-CTYPE? KLUDGE case above: - ;; Other cases here would rely on being able to catch - ;; all possible cases, which the fragility of this - ;; type system doesn't inspire me; for instance, if a - ;; is type= to ~b, then we want T, T; if this is not - ;; the case and the types are disjoint (have an - ;; intersection of *empty-type*) then we want NIL, T; - ;; else if the union of a and b is the - ;; *universal-type* then we want T, T. So currently we - ;; still claim to be unsure about e.g. (subtypep '(not - ;; fixnum) 'single-float). - ))) - (t - (values nil nil))))) + (declare (ignore type1 type2)) + (values nil nil)) (!define-type-method (hairy :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) -(!define-type-method (hairy :simple-intersection2 :complex-intersection2) +(!define-type-method (hairy :simple-intersection2 :complex-intersection2) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + +(!define-type-method (hairy :simple-union2) (type1 type2) (if (type= type1 type2) type1 nil)) (!define-type-method (hairy :simple-=) (type1 type2) - (if (equal (hairy-type-specifier type1) - (hairy-type-specifier type2)) + (if (equal-but-no-car-recursion (hairy-type-specifier type1) + (hairy-type-specifier type2)) (values t t) (values nil nil))) -(!def-type-translator not (&whole whole type) - (declare (ignore type)) - ;; Check legality of arguments. - (destructuring-bind (not typespec) whole - (declare (ignore not)) - (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec - (if (and (listp spec) (eq (car spec) 'not)) - ;; canonicalize (not (not foo)) - (specifier-type (cadr spec)) - (make-hairy-type :specifier whole))))) - (!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) ;; Check legality of arguments. @@ -1216,6 +1132,242 @@ ;; Create object. (make-hairy-type :specifier whole)) +;;;; negation types + +(!define-type-method (negation :unparse) (x) + `(not ,(type-specifier (negation-type-type x)))) + +(!define-type-method (negation :simple-subtypep) (type1 type2) + (csubtypep (negation-type-type type2) (negation-type-type type1))) + +(!define-type-method (negation :complex-subtypep-arg2) (type1 type2) + (let* ((complement-type2 (negation-type-type type2)) + (intersection2 (type-intersection2 type1 + complement-type2))) + (if intersection2 + (values (eq intersection2 *empty-type*) t) + (invoke-complex-subtypep-arg1-method type1 type2)))) + +(!define-type-method (negation :complex-subtypep-arg1) (type1 type2) + ;; "Incrementally extended heuristic algorithms tend inexorably toward the + ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt + ;; + ;; You may not believe this. I couldn't either. But then I sat down + ;; and drew lots of Venn diagrams. Comments involving a and b refer + ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27. + (block nil + ;; (Several logical truths in this block are true as long as + ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a + ;; case with b=T where we actually reach this type method, but + ;; we'll test for and exclude this case anyway, since future + ;; maintenance might make it possible for it to end up in this + ;; code.) + (multiple-value-bind (equal certain) + (type= type2 *universal-type*) + (unless certain + (return (values nil nil))) + (when equal + (return (values t t)))) + (let ((complement-type1 (negation-type-type type1))) + ;; Do the special cases first, in order to give us a chance if + ;; subtype/supertype relationships are hairy. + (multiple-value-bind (equal certain) + (type= complement-type1 type2) + ;; If a = b, ~a is not a subtype of b (unless b=T, which was + ;; excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; KLUDGE: ANSI requires that the SUBTYPEP result between any + ;; two built-in atomic type specifiers never be uncertain. This + ;; is hard to do cleanly for the built-in types whose + ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, + ;; we can do it with this hack, which uses our global knowledge + ;; that our implementation of the type system uses disjoint + ;; implementation types to represent disjoint sets (except when + ;; types are contained in other types). (This is a KLUDGE + ;; because it's fragile. Various changes in internal + ;; representation in the type system could make it start + ;; confidently returning incorrect results.) -- WHN 2002-03-08 + (unless (or (type-might-contain-other-types-p complement-type1) + (type-might-contain-other-types-p type2)) + ;; Because of the way our types which don't contain other + ;; types are disjoint subsets of the space of possible values, + ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B + ;; is not T, as checked above). + (return (values nil t))) + ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as + ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, + ;; and then the :SIMPLE-SUBTYPEP method would be used instead. + ;; But a CSUBTYPEP relationship might still hold: + (multiple-value-bind (equal certain) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b (unless + ;; b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + (multiple-value-bind (equal certain) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: + ;; That's not true if a=T. Do we know at this point that a is + ;; not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? + ;; KLUDGE case above: Other cases here would rely on being able + ;; to catch all possible cases, which the fragility of this type + ;; system doesn't inspire me; for instance, if a is type= to ~b, + ;; then we want T, T; if this is not the case and the types are + ;; disjoint (have an intersection of *empty-type*) then we want + ;; NIL, T; else if the union of a and b is the *universal-type* + ;; then we want T, T. So currently we still claim to be unsure + ;; about e.g. (subtypep '(not fixnum) 'single-float). + ;; + ;; OTOH we might still get here: + (values nil nil)))) + +(!define-type-method (negation :complex-=) (type1 type2) + ;; (NOT FOO) isn't equivalent to anything that's not a negation + ;; type, except possibly a type that might contain it in disguise. + (declare (ignore type2)) + (if (type-might-contain-other-types-p type1) + (values nil nil) + (values nil t))) + +(!define-type-method (negation :simple-intersection2) (type1 type2) + (let ((not1 (negation-type-type type1)) + (not2 (negation-type-type type2))) + (cond + ((csubtypep not1 not2) type2) + ((csubtypep not2 not1) type1) + ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 + ;; method, below? The clause would read + ;; + ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) + ;; + ;; but with proper canonicalization of negation types, there's + ;; no way of constructing two negation types with union of their + ;; negations being the universal type. + (t + (aver (not (eq (type-union not1 not2) *universal-type*))) + nil)))) + +(!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) + (t nil))) + +(!define-type-method (negation :simple-union2) (type1 type2) + (let ((not1 (negation-type-type type1)) + (not2 (negation-type-type type2))) + (cond + ((csubtypep not1 not2) type1) + ((csubtypep not2 not1) type2) + ((eq (type-intersection not1 not2) *empty-type*) + *universal-type*) + (t nil)))) + +(!define-type-method (negation :complex-union2) (type1 type2) + (cond + ((csubtypep (negation-type-type type2) type1) *universal-type*) + ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) + type2) + (t nil))) + +(!define-type-method (negation :simple-=) (type1 type2) + (type= (negation-type-type type1) (negation-type-type type2))) + +(!def-type-translator not (typespec) + (let* ((not-type (specifier-type typespec)) + (spec (type-specifier not-type))) + (cond + ;; canonicalize (NOT (NOT FOO)) + ((and (listp spec) (eq (car spec) 'not)) + (specifier-type (cadr spec))) + ;; canonicalize (NOT NIL) and (NOT T) + ((eq not-type *empty-type*) *universal-type*) + ((eq not-type *universal-type*) *empty-type*) + ((and (numeric-type-p not-type) + (null (numeric-type-low not-type)) + (null (numeric-type-high not-type))) + (make-negation-type :type not-type)) + ((numeric-type-p not-type) + (type-union + (make-negation-type + :type (modified-numeric-type not-type :low nil :high nil)) + (cond + ((null (numeric-type-low not-type)) + (modified-numeric-type + not-type + :low (let ((h (numeric-type-high not-type))) + (if (consp h) (car h) (list h))) + :high nil)) + ((null (numeric-type-high not-type)) + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-type-low not-type))) + (if (consp l) (car l) (list l))))) + (t (type-union + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-type-low not-type))) + (if (consp l) (car l) (list l)))) + (modified-numeric-type + not-type + :low (let ((h (numeric-type-high not-type))) + (if (consp h) (car h) (list h))) + :high nil)))))) + ((intersection-type-p not-type) + (apply #'type-union + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)))) + (intersection-type-types not-type)))) + ((union-type-p not-type) + (apply #'type-intersection + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)))) + (union-type-types not-type)))) + ((and (cons-type-p not-type) + (eq (cons-type-car-type not-type) *universal-type*) + (eq (cons-type-cdr-type not-type) *universal-type*)) + (make-negation-type :type not-type)) + ((cons-type-p not-type) + (type-union + (make-negation-type :type (specifier-type 'cons)) + (cond + ((and (not (eq (cons-type-car-type not-type) *universal-type*)) + (not (eq (cons-type-cdr-type not-type) *universal-type*))) + (type-union + (make-cons-type + (specifier-type `(not ,(type-specifier + (cons-type-car-type not-type)))) + *universal-type*) + (make-cons-type + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-type-cdr-type not-type))))))) + ((not (eq (cons-type-car-type not-type) *universal-type*)) + (make-cons-type + (specifier-type `(not ,(type-specifier + (cons-type-car-type not-type)))) + *universal-type*)) + ((not (eq (cons-type-cdr-type not-type) *universal-type*)) + (make-cons-type + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-type-cdr-type not-type)))))) + (t (bug "Weird CONS type ~S" not-type))))) + (t (make-negation-type :type not-type))))) + ;;;; numeric types (!define-type-class number) @@ -1383,11 +1535,13 @@ (null complexp2))) (values nil t)) ;; If the classes are specified and different, the types are - ;; disjoint unless type2 is rational and type1 is integer. + ;; disjoint unless type2 is RATIONAL and type1 is INTEGER. + ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL + ;; X X) for integral X, but this is dealt with in the + ;; canonicalization inside MAKE-NUMERIC-TYPE ] ((not (or (eq class1 class2) (null class2) - (and (eq class1 'integer) - (eq class2 'rational)))) + (and (eq class1 'integer) (eq class2 'rational)))) (values nil t)) ;; If the float formats are specified and different, the types ;; are disjoint. @@ -1441,8 +1595,10 @@ ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; -;;; ### Note: we give up early to keep from dropping lots of information on -;;; the floor by returning overly general types. +;;; Old comment, probably no longer applicable: +;;; +;;; ### Note: we give up early to keep from dropping lots of +;;; information on the floor by returning overly general types. (!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) @@ -1454,22 +1610,65 @@ (class2 (numeric-type-class type2)) (format2 (numeric-type-format type2)) (complexp2 (numeric-type-complexp type2))) - (when (and (eq class1 class2) - (eq format1 format2) - (eq complexp1 complexp2) - (or (numeric-types-intersect type1 type2) - (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class class1 - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))))))) + (cond + ((and (eq class1 class2) + (eq format1 format2) + (eq complexp1 complexp2) + (or (numeric-types-intersect type1 type2) + (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class class1 + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + ;; FIXME: These two clauses are almost identical, and the + ;; consequents are in fact identical in every respect. + ((and (eq class1 'rational) + (eq class2 'integer) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-type-low type2)) + (integerp (numeric-type-high type2)) + (= (numeric-type-low type2) (numeric-type-high type2)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + ((and (eq class1 'integer) + (eq class2 'rational) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-type-low type1)) + (integerp (numeric-type-high type1)) + (= (numeric-type-low type1) (numeric-type-high type1)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + (t nil)))))) + (!cold-init-forms (setf (info :type :kind 'number) @@ -1579,9 +1778,6 @@ (h (canonicalized-bound high 'integer)) (hb (if (consp h) (1- (car h)) h))) (if (and hb lb (< hb lb)) - ;; previously we threw an error here: - ;; (error "Lower bound ~S is greater than upper bound ~S." l h)) - ;; but ANSI doesn't say anything about that, so: *empty-type* (make-numeric-type :class 'integer :complexp :real @@ -1594,9 +1790,6 @@ (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) (if (not (numeric-bound-test* lb hb <= <)) - ;; as above, previously we did - ;; (error "Lower bound ~S is not less than upper bound ~S." low high)) - ;; but it is correct to do *empty-type* (make-numeric-type :class ',class :format ',format @@ -2106,7 +2299,7 @@ *empty-type*)))))) (!define-type-method (member :complex-intersection2) (type1 type2) - (block punt + (block punt (collect ((members)) (let ((mem2 (member-type-members type2))) (dolist (member mem2) @@ -2147,8 +2340,17 @@ (!def-type-translator member (&rest members) (if members - (make-member-type :members (remove-duplicates members)) - *empty-type*)) + (let (ms numbers) + (dolist (m (remove-duplicates members)) + (typecase m + (number (push (ctype-of m) numbers)) + (t (push m ms)))) + (apply #'type-union + (if ms + (make-member-type :members ms) + *empty-type*) + (nreverse numbers))) + *empty-type*)) ;;;; intersection types ;;;; @@ -2175,7 +2377,7 @@ ;;; mechanically unparsed. (!define-type-method (intersection :unparse) (type) (declare (type ctype type)) - (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=) + (or (find type '(ratio keyword) :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 @@ -2207,17 +2409,70 @@ type2 (intersection-type-types type1))) -(!define-type-method (intersection :simple-subtypep) (type1 type2) +(defun %intersection-simple-subtypep (type1 type2) (every/type #'%intersection-complex-subtypep-arg1 type1 (intersection-type-types type2))) +(!define-type-method (intersection :simple-subtypep) (type1 type2) + (%intersection-simple-subtypep type1 type2)) + (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) (%intersection-complex-subtypep-arg1 type1 type2)) -(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) +(defun %intersection-complex-subtypep-arg2 (type1 type2) (every/type #'csubtypep type1 (intersection-type-types type2))) +(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (%intersection-complex-subtypep-arg2 type1 type2)) + +;;; FIXME: This will look eeriely familiar to readers of the UNION +;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's +;;; because it was generated by cut'n'paste methods. Given that +;;; intersections and unions have all sorts of symmetries known to +;;; mathematics, it shouldn't be beyond the ken of some programmers to +;;; reflect those symmetries in code in a way that ties them together +;;; more strongly than having two independent near-copies :-/ +(!define-type-method (intersection :simple-union2 :complex-union2) + (type1 type2) + ;; Within this method, type2 is guaranteed to be an intersection + ;; type: + (aver (intersection-type-p type2)) + ;; Make sure to call only the applicable methods... + (cond ((and (intersection-type-p type1) + (%intersection-simple-subtypep type1 type2)) type2) + ((and (intersection-type-p type1) + (%intersection-simple-subtypep type2 type1)) type1) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg2 type1 type2)) + type2) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg1 type2 type1)) + type1) + (t + (let ((accumulator *universal-type*)) + (do ((t2s (intersection-type-types type2) (cdr t2s))) + ((null t2s) accumulator) + (let ((union (type-union type1 (car t2s)))) + (when (union-type-p union) + ;; we have to give up here -- there are all sorts of + ;; ordering worries, but it's better than before. + ;; Doing exactly the same as in the UNION + ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack + ;; overflow with the mutual recursion never bottoming + ;; out. + (if (and (eq accumulator *universal-type*) + (null (cdr t2s))) + ;; KLUDGE: if we get here, we have a partially + ;; simplified result. While this isn't by any + ;; means a universal simplification, including + ;; this logic here means that we can get (OR + ;; KEYWORD (NOT KEYWORD)) canonicalized to T. + (return union) + (return nil))) + (setf accumulator + (type-intersection accumulator union)))))))) + (!def-type-translator and (&whole whole &rest type-specifiers) (apply #'type-intersection (mapcar #'specifier-type @@ -2236,7 +2491,7 @@ ((type= type (specifier-type 'float)) 'float) ((type= type (specifier-type 'real)) 'real) ((type= type (specifier-type 'sequence)) 'sequence) - ((type= type (specifier-type 'string-stream)) 'string-stream) + ((type= type (specifier-type 'bignum)) 'bignum) (t `(or ,@(mapcar #'type-specifier (union-type-types type)))))) ;;; Two union types are equal if they are each subtypes of each @@ -2264,7 +2519,9 @@ (!define-type-method (union :complex-=) (type1 type2) (declare (ignore type1)) - (if (some #'hairy-type-p (union-type-types type2)) + (if (some #'(lambda (x) (or (hairy-type-p x) + (negation-type-p x))) + (union-type-types type2)) (values nil nil) (values nil t))) @@ -2376,12 +2633,8 @@ (let ((accumulator *empty-type*)) (dolist (t2 (union-type-types type2) accumulator) (setf accumulator - (type-union2 accumulator - (type-intersection type1 t2))) - ;; When our result isn't simple any more (because - ;; TYPE-UNION2 was unable to give us a simple result) - (unless accumulator - (return nil))))))) + (type-union accumulator + (type-intersection type1 t2)))))))) (!def-type-translator or (&rest type-specifiers) (apply #'type-union @@ -2393,8 +2646,9 @@ (!define-type-class cons) (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) - (make-cons-type (specifier-type car-type-spec) - (specifier-type cdr-type-spec))) + (let ((car-type (specifier-type car-type-spec)) + (cdr-type (specifier-type cdr-type-spec))) + (make-cons-type car-type cdr-type))) (!define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) @@ -2496,14 +2750,15 @@ (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) + :complexp :maybe :element-type (specifier-type element-type)))) (!def-type-translator simple-array (&optional (element-type '*) (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) - :element-type (specifier-type element-type) - :complexp nil))) + :complexp nil + :element-type (specifier-type element-type)))) ;;;; utilities shared between cross-compiler and target system