X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=c74a081d29c33e1e0ff0a812844e4f8f1685512c;hb=670010e3f3dcd62efaf23f61abdc73950edb88c6;hp=4b9296549cc513e7f878453e6e7267289ce0e27f;hpb=722703e7cbd3a4b279a4c1baab5d95df2c23cce9;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 4b92965..c74a081 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -22,14 +22,8 @@ ;;; ### Remaining incorrectnesses: ;;; -;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an -;;; exhaustive partition or coalesce contiguous ranges of numeric -;;; types. -;;; ;;; There are all sorts of nasty problems with open bounds on FLOAT ;;; types (and probably FLOAT types in general.) -;;; -;;; RATIO and BIGNUM are not recognized as numeric types. ;;; 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.) @@ -69,7 +63,7 @@ ;; If TYPE2 might be concealing something related to our class ;; hierarchy (if (type-might-contain-other-types-p type2) - ;; too confusing, gotta punt + ;; too confusing, gotta punt (values nil nil) ;; ordinary case expected by old CMU CL code, where the taxonomy ;; of TYPE2's representation accurately reflects the taxonomy of @@ -77,15 +71,16 @@ (values ;; FIXME: This old CMU CL code probably deserves a comment ;; explaining to us mere mortals how it works... - (and (sb!xc:typep type2 'sb!xc:class) + (and (sb!xc:typep type2 'classoid) (dolist (x info nil) (when (or (not (cdr x)) (csubtypep type1 (specifier-type (cdr x)))) (return (or (eq type2 (car x)) - (let ((inherits (layout-inherits (class-layout (car x))))) + (let ((inherits (layout-inherits + (classoid-layout (car x))))) (dotimes (i (length inherits) nil) - (when (eq type2 (layout-class (svref inherits i))) + (when (eq type2 (layout-classoid (svref inherits i))) (return t))))))))) t))) @@ -102,15 +97,14 @@ ;;; ;;; WHEN controls when the forms are executed. (defmacro !define-superclasses (type-class-name specs when) - (let ((type-class (gensym "TYPE-CLASS-")) - (info (gensym "INFO"))) + (with-unique-names (type-class info) `(,when (let ((,type-class (type-class-or-lose ',type-class-name)) (,info (mapcar (lambda (spec) (destructuring-bind (super &optional guard) spec - (cons (sb!xc:find-class super) guard))) + (cons (find-classoid super) guard))) ',specs))) (setf (type-class-complex-subtypep-arg1 ,type-class) (lambda (type1 type2) @@ -213,11 +207,52 @@ (type-specifier (fun-type-returns type))))) -;;; Since all function types are equivalent to FUNCTION, they are all -;;; subtypes of each other. +;;; The meaning of this is a little confused. On the one hand, all +;;; function objects are represented the same way regardless of the +;;; arglists and return values, and apps don't get to ask things like +;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the +;;; other hand, Python wants to reason about function types. So... (!define-type-method (function :simple-subtypep) (type1 type2) - (declare (ignore type1 type2)) - (values t t)) + (flet ((fun-type-simple-p (type) + (not (or (fun-type-rest type) + (fun-type-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (csubtypep a1 a2) + (unless res (return (values res sure-p)))) + finally (return (values t t))))) + (and/type (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((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 (and/type (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) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (and/type (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2)))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -229,6 +264,18 @@ (declare (ignore type1 type2)) (specifier-type 'function)) +;;; The union or intersection of a subclass of FUNCTION with a +;;; FUNCTION type is somewhat complicated. +(!define-type-method (function :complex-intersection2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type2) + ((csubtypep type1 (specifier-type 'function)) nil) + (t :call-other-method))) +(!define-type-method (function :complex-union2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type1) + (t nil))) + ;;; ### Not very real, but good enough for redefining transforms ;;; according to type: (!define-type-method (function :simple-=) (type1 type2) @@ -245,33 +292,6 @@ (!def-type-translator constant-arg (type) (make-constant-type :type (specifier-type type))) -;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE -;;; structure, fill in the slots in the structure accordingly. This is -;;; used for both FUNCTION and VALUES types. -(declaim (ftype (function (list args-type) (values)) parse-args-types)) -(defun parse-args-types (lambda-list result) - (multiple-value-bind (required optional restp rest keyp keys allowp aux) - (parse-lambda-list lambda-list) - (when aux - (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-keyp result) keyp) - (collect ((key-info)) - (dolist (key keys) - (unless (proper-list-of-length-p key 2) - (error "Keyword type description is not a two-list: ~S." key)) - (let ((kwd (first key))) - (when (find kwd (key-info) :key #'key-info-name) - (error "~@" - kwd lambda-list)) - (key-info (make-key-info :name kwd - :type (specifier-type (second key)))))) - (setf (args-type-keywords result) (key-info))) - (setf (args-type-allowp result) allowp) - (values))) - ;;; Return the lambda-list-like type specification corresponding ;;; to an ARGS-TYPE. (declaim (ftype (function (args-type) list) unparse-args-types)) @@ -302,16 +322,10 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-fun-type :returns (values-specifier-type result)))) - (if (eq args '*) - (setf (fun-type-wild-args res) t) - (parse-args-types args res)) - res)) + (make-fun-type :args args :returns (values-specifier-type result))) (!def-type-translator values (&rest values) - (let ((res (make-values-type))) - (parse-args-types values res) - res)) + (make-values-type :args values)) ;;;; VALUES types interfaces ;;;; @@ -341,7 +355,7 @@ ;;; type, return NIL, NIL. (defun fun-type-nargs (type) (declare (type ctype type)) - (if (fun-type-p type) + (if (and (fun-type-p type) (not (fun-type-wild-args type))) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -401,7 +415,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)) @@ -435,6 +449,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))) @@ -576,12 +592,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 @@ -673,14 +690,14 @@ (flet ((1way (x y) (!invoke-type-method :simple-intersection2 :complex-intersection2 x y - :default :no-type-method-found))) + :default :call-other-method))) (declare (inline 1way)) (let ((xy (1way type1 type2))) - (or (and (not (eql xy :no-type-method-found)) xy) + (or (and (not (eql xy :call-other-method)) xy) (let ((yx (1way type2 type1))) - (or (and (not (eql yx :no-type-method-found)) yx) - (cond ((and (eql xy :no-type-method-found) - (eql yx :no-type-method-found)) + (or (and (not (eql yx :call-other-method)) yx) + (cond ((and (eql xy :call-other-method) + (eql yx :call-other-method)) *empty-type*) (t (aver (and (not xy) (not yx))) ; else handled above @@ -756,7 +773,17 @@ (let ((res (specifier-type spec))) (unless (unknown-type-p res) (setf (info :type :builtin spec) res) - (setf (info :type :kind spec) :primitive)))) + ;; KLUDGE: the three copies of this idiom in this file (and + ;; the one in class.lisp as at sbcl-0.7.4.1x) should be + ;; coalesced, or perhaps the error-detecting code that + ;; disallows redefinition of :PRIMITIVE types should be + ;; rewritten to use *TYPE-SYSTEM-FINALIZED* (rather than + ;; *TYPE-SYSTEM-INITIALIZED*). The effect of this is not to + ;; cause redefinition errors when precompute-types is called + ;; for a second time while building the target compiler using + ;; the cross-compiler. -- CSR, trying to explain why this + ;; isn't completely wrong, 2002-06-07 + (setf (info :type :kind spec) #+sb-xc-host :defined #-sb-xc-host :primitive)))) (values)) ;;;; general TYPE-UNION and TYPE-INTERSECTION operations @@ -771,7 +798,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))) @@ -828,7 +855,7 @@ ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE ;;; object whose components are the types in TYPES, or skip to special ;;; cases when TYPES is short. -(defun make-compound-type-or-something (constructor types enumerable identity) +(defun make-probably-compound-type (constructor types enumerable identity) (declare (type function constructor)) (declare (type (vector ctype) types)) (declare (type ctype identity)) @@ -842,14 +869,29 @@ ;; brain-dead, so that would generate a full call to ;; SPECIFIER-TYPE at runtime, so we get into bootstrap ;; problems in cold init because 'LIST is a compound - ;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING + ;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE ;; before we know what 'LIST is. Once the COERCE ;; optimizer is less brain-dead, we can make this ;; (COERCE TYPES 'LIST) again. #+sb-xc-host (coerce types 'list) #-sb-xc-host (coerce-to-list types))))) +(defun maybe-distribute-one-union (union-type types) + (let* ((intersection (apply #'type-intersection types)) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-type-types union-type)))) + (if (notany (lambda (x) (or (hairy-type-p x) + (intersection-type-p x))) + union) + union + 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))) @@ -860,25 +902,40 @@ ;; always achieve that by the distributive rule. But we don't want ;; to just apply the distributive rule, since it would be too easy ;; to end up with unreasonably huge type expressions. So instead - ;; we punt to HAIRY-TYPE when this comes up. + ;; we try to generate a simple type by distributing the union; if + ;; the type can't be made simple, we punt to HAIRY-TYPE. (if (and (> (length simplified-types) 1) (some #'union-type-p simplified-types)) - (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified-types))) - (make-compound-type-or-something #'%make-intersection-type - simplified-types - (some #'type-enumerable - simplified-types) - *universal-type*)))) + (let* ((first-union (find-if #'union-type-p simplified-types)) + (other-types (coerce (remove first-union simplified-types) + 'list)) + (distributed (maybe-distribute-one-union first-union + other-types))) + (if distributed + (apply #'type-union distributed) + (make-hairy-type + :specifier `(and ,@(map 'list + #'type-specifier + simplified-types))))) + (make-probably-compound-type #'%make-intersection-type + simplified-types + (some #'type-enumerable + simplified-types) + *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 - simplified-types - (every #'type-enumerable simplified-types) - *empty-type*))) + (make-probably-compound-type #'make-union-type + simplified-types + (every #'type-enumerable simplified-types) + *empty-type*))) ;;;; built-in types @@ -892,7 +949,8 @@ (macrolet ((frob (name var) `(progn (setq ,var (make-named-type :name ',name)) - (setf (info :type :kind ',name) :primitive) + (setf (info :type :kind ',name) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin ',name) ,var)))) ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a ;; special symbol which can be stuck in some places where an @@ -914,6 +972,23 @@ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) +(!define-type-method (named :complex-=) (type1 type2) + (cond + ((and (eq type2 *empty-type*) + (intersection-type-p type1) + ;; not allowed to be unsure on these... FIXME: keep the list + ;; of CL types that are intersection types once and only + ;; once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION + ;; STREAM) can get here. In general, we can't really tell + ;; whether these are equal to NIL or not, so + (values nil nil)) + ((type-might-contain-other-types-p type1) + (invoke-complex-=-other-method type1 type2)) + (t (values nil t)))) + (!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)) @@ -956,11 +1031,13 @@ (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((hairy-type-p type1) + ((type-might-contain-other-types-p type1) + ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in + ;; disguise. So we'd better delegate. (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)))) @@ -981,151 +1058,46 @@ ;;;; hairy and unknown types -(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) - +(!define-type-method (hairy :unparse) (x) + (hairy-type-specifier x)) + (!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. @@ -1135,11 +1107,281 @@ (error 'simple-type-error :datum predicate-name :expected-type 'symbol - :format-control "~S is not a symbol." + :format-control "The SATISFIES predicate name is not a symbol: ~S" :format-arguments (list predicate-name)))) ;; 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 + ;; FIXME: if uncertain, maybe try arg1? + (type= intersection2 *empty-type*) + (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)))) + ((member-type-p not-type) + (let ((members (member-type-members not-type))) + (if (some #'floatp members) + (let (floats) + (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0) + #!+long-float (0.0l0 . -0.0l0))) + (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* + (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))) + (make-negation-type :type 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) @@ -1149,8 +1391,8 @@ (and (eq (numeric-type-class type1) (numeric-type-class type2)) (eq (numeric-type-format type1) (numeric-type-format type2)) (eq (numeric-type-complexp type1) (numeric-type-complexp type2)) - (equal (numeric-type-low type1) (numeric-type-low type2)) - (equal (numeric-type-high type1) (numeric-type-high type2))) + (equalp (numeric-type-low type1) (numeric-type-low type2)) + (equalp (numeric-type-high type1) (numeric-type-high type2))) t)) (!define-type-method (number :unparse) (type) @@ -1210,7 +1452,6 @@ ;;; ;;; This is for comparing bounds of the same kind, e.g. upper and ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds. -#!-negative-zero-is-not-zero (defmacro numeric-bound-test (x y closed open) `(cond ((not ,y) t) ((not ,x) nil) @@ -1223,32 +1464,12 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test-zero (op x y) - `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y)) - (,op (float-sign ,x) (float-sign ,y)) - (,op ,x ,y))) - -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test (x y closed open) - `(cond ((not ,y) t) - ((not ,x) nil) - ((consp ,x) - (if (consp ,y) - (numeric-bound-test-zero ,closed (car ,x) (car ,y)) - (numeric-bound-test-zero ,closed (car ,x) ,y))) - (t - (if (consp ,y) - (numeric-bound-test-zero ,open ,x (car ,y)) - (numeric-bound-test-zero ,closed ,x ,y))))) - ;;; This is used to compare upper and lower bounds. This is different ;;; from the same-bound case: ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we ;;; return true if *either* arg is NIL. ;;; -- an open inner bound is "greater" and also squeezes the interval, ;;; causing us to use the OPEN test for those cases as well. -#!-negative-zero-is-not-zero (defmacro numeric-bound-test* (x y closed open) `(cond ((not ,y) t) ((not ,x) t) @@ -1261,19 +1482,6 @@ (,open ,x (car ,y)) (,closed ,x ,y))))) -#!+negative-zero-is-not-zero -(defmacro numeric-bound-test* (x y closed open) - `(cond ((not ,y) t) - ((not ,x) t) - ((consp ,x) - (if (consp ,y) - (numeric-bound-test-zero ,open (car ,x) (car ,y)) - (numeric-bound-test-zero ,open (car ,x) ,y))) - (t - (if (consp ,y) - (numeric-bound-test-zero ,open ,x (car ,y)) - (numeric-bound-test-zero ,closed ,x ,y))))) - ;;; Return whichever of the numeric bounds X and Y is "maximal" ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >). ;;; This is only meaningful for maximizing like bounds, i.e. upper and @@ -1307,11 +1515,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. @@ -1325,7 +1535,7 @@ (t (values nil t))))) -(!define-superclasses number ((generic-number)) !cold-init-forms) +(!define-superclasses number ((number)) !cold-init-forms) ;;; If the high bound of LOW is adjacent to the low bound of HIGH, ;;; then return true, otherwise NIL. @@ -1335,28 +1545,19 @@ (cond ((not (and low-bound high-bound)) nil) ((and (consp low-bound) (consp high-bound)) nil) ((consp low-bound) - #!-negative-zero-is-not-zero (let ((low-value (car low-bound))) (or (eql low-value high-bound) (and (eql low-value -0f0) (eql high-bound 0f0)) (and (eql low-value 0f0) (eql high-bound -0f0)) (and (eql low-value -0d0) (eql high-bound 0d0)) - (and (eql low-value 0d0) (eql high-bound -0d0)))) - #!+negative-zero-is-not-zero - (eql (car low-bound) high-bound)) + (and (eql low-value 0d0) (eql high-bound -0d0))))) ((consp high-bound) - #!-negative-zero-is-not-zero (let ((high-value (car high-bound))) (or (eql high-value low-bound) (and (eql high-value -0f0) (eql low-bound 0f0)) (and (eql high-value 0f0) (eql low-bound -0f0)) (and (eql high-value -0d0) (eql low-bound 0d0)) - (and (eql high-value 0d0) (eql low-bound -0d0)))) - #!+negative-zero-is-not-zero - (eql (car high-bound) low-bound)) - #!+negative-zero-is-not-zero - ((or (and (eql low-bound -0f0) (eql high-bound 0f0)) - (and (eql low-bound -0d0) (eql high-bound 0d0)))) + (and (eql high-value 0d0) (eql low-bound -0d0))))) ((and (eq (numeric-type-class low) 'integer) (eq (numeric-type-class high) 'integer)) (eql (1+ low-bound) high-bound)) @@ -1365,8 +1566,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) @@ -1378,25 +1581,69 @@ (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) :primitive) + (setf (info :type :kind 'number) + #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) @@ -1502,10 +1749,7 @@ (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: - (specifier-type 'nil) + *empty-type* (make-numeric-type :class 'integer :complexp :real :enumerable (not (null (and l h))) @@ -1517,11 +1761,11 @@ (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 - (specifier-type 'nil) - (make-numeric-type :class ',class :format ',format :low lb :high hb))))) + *empty-type* + (make-numeric-type :class ',class + :format ',format + :low lb + :high hb))))) (!def-bounded-type rational rational nil) @@ -1790,13 +2034,23 @@ (array-type-element-type type))) (!define-type-method (array :simple-=) (type1 type2) - (values (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)) + (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) + (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))) (!define-type-method (array :unparse) (type) (let ((dims (array-type-dimensions type)) @@ -1902,10 +2156,28 @@ (eq complexp2 :maybe) (eq complexp1 complexp2))) (values nil t)) - ;; If either element type is wild, then they intersect. - ;; Otherwise, the types must be identical. - ((or (eq (array-type-element-type type1) *wild-type*) - (eq (array-type-element-type type2) *wild-type*) + ;; Old comment: + ;; + ;; If either element type is wild, then they intersect. + ;; Otherwise, the types must be identical. + ;; + ;; FIXME: There seems to have been a fair amount of + ;; confusion about the distinction between requested element + ;; type and specialized element type; here is one of + ;; them. If we request an array to hold objects of an + ;; unknown type, we can do no better than represent that + ;; type as an array specialized on wild-type. We keep the + ;; requested element-type in the -ELEMENT-TYPE slot, and + ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here, + ;; we must test for the SPECIALIZED slot being *WILD-TYPE*, + ;; not just the ELEMENT-TYPE slot. Maybe the return value + ;; in that specific case should be T, NIL? Or maybe this + ;; function should really be called + ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this + ;; was responsible for bug #123, and this whole issue could + ;; 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))) @@ -1963,9 +2235,10 @@ (!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) - (if (equal members '(nil)) - 'null - `(member ,@members)))) + (cond + ((equal members '(nil)) 'null) + ((type= type (specifier-type 'standard-char)) 'standard-char) + (t `(member ,@members))))) (!define-type-method (member :simple-subtypep) (type1 type2) (values (subsetp (member-type-members type1) (member-type-members type2)) @@ -1997,7 +2270,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) @@ -2038,8 +2311,20 @@ (!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 + (float (if (zerop m) + (push m ms) + (push (ctype-of m) numbers))) + (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 ;;;; @@ -2066,21 +2351,19 @@ ;;; 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 ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) - (flet (;; true if every type in the set X matches a type in the set Y - (type<=-set (x y) + (flet ((type<=-set (x y) (declare (type list x y)) - (every (lambda (xelement) - (position xelement y :test #'type=)) - x))) - (values (and (type<=-set types1 types2) - (type<=-set types2 types1)) - t))) + (every/type (lambda (x y-element) + (any/type #'type= y-element x)) + x y))) + (and/type (type<=-set types1 types2) + (type<=-set types2 types1)))) ;;; Two intersection types are equal if their subtypes are equal sets. ;;; @@ -2094,21 +2377,94 @@ (intersection-type-types type2))) (defun %intersection-complex-subtypep-arg1 (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1))) + (type= type1 (type-intersection type1 type2))) -(!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) + ;; KLUDGE: This special (and somewhat hairy) magic is required + ;; to deal with the RATIONAL/INTEGER special case. The UNION + ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER)) + ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28 + ((and (csubtypep type2 (specifier-type 'ratio)) + (numeric-type-p type1) + (csubtypep type1 (specifier-type 'integer)) + (csubtypep type2 + (make-numeric-type + :class 'rational + :complexp nil + :low (if (null (numeric-type-low type1)) + nil + (list (1- (numeric-type-low type1)))) + :high (if (null (numeric-type-high type1)) + nil + (list (1+ (numeric-type-high type1))))))) + (type-union type1 + (apply #'type-intersection + (remove (specifier-type '(not integer)) + (intersection-type-types type2) + :test #'type=)))) + (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 @@ -2118,13 +2474,17 @@ (!define-type-class union) -;;; The LIST type has a special name. Other union types just get -;;; mechanically unparsed. +;;; The LIST, FLOAT and REAL types have special names. Other union +;;; types just get mechanically unparsed. (!define-type-method (union :unparse) (type) (declare (type ctype type)) - (if (type= type (specifier-type 'list)) - 'list - `(or ,@(mapcar #'type-specifier (union-type-types type))))) + (cond + ((type= type (specifier-type 'list)) 'list) + ((type= type (specifier-type 'float)) 'float) + ((type= type (specifier-type 'real)) 'real) + ((type= type (specifier-type 'sequence)) 'sequence) + ((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 ;;; other. We need to be this clever because our complex subtypep @@ -2150,7 +2510,9 @@ (values nil certain?)))))) (!define-type-method (union :complex-=) (type1 type2) - (if (some #'hairy-type-p (union-type-types type2)) + (declare (ignore type1)) + (if (some #'type-might-contain-other-types-p + (union-type-types type2)) (values nil nil) (values nil t))) @@ -2262,12 +2624,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 @@ -2279,8 +2637,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))) @@ -2313,13 +2672,35 @@ (car-type2 (cons-type-car-type type2)) (cdr-type1 (cons-type-cdr-type type1)) (cdr-type2 (cons-type-cdr-type type2))) - (cond ((type= car-type1 car-type2) - (make-cons-type car-type1 - (type-union cdr-type1 cdr-type2))) - ((type= cdr-type1 cdr-type2) - (make-cons-type (type-union cdr-type1 cdr-type2) - cdr-type1))))) - + ;; UGH. -- CSR, 2003-02-24 + (macrolet ((frob-car (car1 car2 cdr1 cdr2) + `(type-union + (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) + (make-cons-type + (type-intersection ,car2 + (specifier-type + `(not ,(type-specifier ,car1)))) + ,cdr2)))) + (cond ((type= car-type1 car-type2) + (make-cons-type car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-type (type-union car-type1 car-type2) + cdr-type1)) + ((csubtypep car-type1 car-type2) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) + ((csubtypep car-type2 car-type1) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; Don't put these in -- consider the effect of taking the + ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and + ;; (CONS (INTEGER 0 3) (INTEGER 5 6)). + #+nil + ((csubtypep cdr-type1 cdr-type2) + (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2)) + #+nil + ((csubtypep cdr-type2 cdr-type1) + (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1)))))) + (!define-type-method (cons :simple-intersection2) (type1 type2) (declare (type cons-type type1 type2)) (let (car-int2 @@ -2382,14 +2763,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 @@ -2398,8 +2780,8 @@ (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) (declare (type ctype defined-ftype declared-ftype)) (flet ((is-built-in-class-function-p (ctype) - (and (built-in-class-p ctype) - (eq (built-in-class-%name ctype) 'function)))) + (and (built-in-classoid-p ctype) + (eq (built-in-classoid-name ctype) 'function)))) (cond (;; DECLARED-FTYPE could certainly be #; ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). (is-built-in-class-function-p declared-ftype)