X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=70ccba2a7d02067c34f2894bd3d1e071ba5c0578;hb=6c4d4d984b1af6b2a73568cec3ab9c8795cff2da;hp=85b2882fe7de6e153be42b0de7a0b42042e69aea;hpb=67d2b80e478824a46317419f076ab1f6b020f6b1;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 85b2882..70ccba2 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -68,8 +68,8 @@ (defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info) ;; If TYPE2 might be concealing something related to our class ;; hierarchy - (if (type-might-contain-other-types? type2) - ;; too confusing, gotta punt + (if (type-might-contain-other-types-p type2) + ;; 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 @@ -216,8 +216,45 @@ ;;; Since all function types are equivalent to FUNCTION, they are all ;;; subtypes of each other. (!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))))) + (macrolet ((3and (x y) + `(multiple-value-bind (val1 win1) + ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) + ,y + (if (and val1 val2) + (values t t) + (values nil (or win1 win2)))))))) + (3and (csubtypep (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))) + (values nil nil)) + ((not (and (= (length (fun-type-required type1)) + (length (fun-type-required type2))) + (= (length (fun-type-optional type1)) + (length (fun-type-optional type2))))) + (values nil t)) + (t (3and (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -250,9 +287,10 @@ ;;; 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 + (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) + (parse-lambda-list-like-thing lambda-list) + (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)) @@ -640,6 +678,8 @@ (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 @@ -692,6 +732,9 @@ ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) (cond ((eq type1 type2) + ;; FIXME: For some reason, this doesn't catch e.g. type1 = + ;; type2 = (SPECIFIER-TYPE + ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 type1) ((or (intersection-type-p type1) (intersection-type-p type2)) @@ -751,7 +794,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 @@ -844,6 +897,16 @@ #+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) (let ((simplified-types (simplified-compound-types input-types #'intersection-type-p @@ -855,11 +918,17 @@ ;; 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))) + (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-compound-type-or-something #'%make-intersection-type simplified-types (some #'type-enumerable @@ -887,7 +956,7 @@ (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,11 +983,17 @@ (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) (!define-type-method (named :complex-subtypep-arg1) (type1 type2) - (aver (not (eq type1 *wild-type*))) ; * isn't really a type. + ;; This AVER causes problems if we write accurate methods for the + ;; union (and possibly intersection) types which then delegate to + ;; us; while a user shouldn't get here, because of the odd status of + ;; *wild-type* a type-intersection executed by the compiler can. - + ;; CSR, 2002-04-10 + ;; + ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type. (cond ((eq type1 *empty-type*) t) (;; When TYPE2 might be the universal type in disguise - (type-might-contain-other-types? type2) + (type-might-contain-other-types-p type2) ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods ;; can delegate to us (more or less as CALL-NEXT-METHOD) when ;; they're uncertain, we can't just barf on COMPOUND-TYPE and @@ -933,7 +1008,7 @@ (values nil nil)) (t ;; By elimination, TYPE1 is the universal type. - (aver (eq type1 *universal-type*)) + (aver (or (eq type1 *wild-type*) (eq type1 *universal-type*))) ;; This case would have been picked off by the SIMPLE-SUBTYPEP ;; method, and so shouldn't appear here. (aver (not (eq type2 *universal-type*))) @@ -970,8 +1045,9 @@ ;;;; 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))) @@ -1043,8 +1119,8 @@ ;; 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? complement-type1) - (type-might-contain-other-types? type2)) + (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 @@ -1094,8 +1170,9 @@ (!define-type-method (hairy :simple-intersection2 :complex-intersection2) (type1 type2) - (declare (ignore type1 type2)) - nil) + (if (type= type1 type2) + type1 + nil)) (!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) @@ -1313,7 +1390,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. @@ -1384,7 +1461,7 @@ >= > t))))))) (!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))) @@ -1493,7 +1570,7 @@ ;; 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))) @@ -1508,7 +1585,7 @@ ;; 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) + *empty-type* (make-numeric-type :class ',class :format ',format :low lb :high hb))))) (!def-bounded-type rational rational nil) @@ -1778,13 +1855,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)) @@ -1890,10 +1977,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))) @@ -1951,9 +2056,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)) @@ -2106,36 +2212,100 @@ (!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 'string-stream)) 'string-stream) + (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 +;;; methods are now more accurate; we don't get infinite recursion +;;; because the simple-subtypep method delegates to complex-subtypep +;;; of the individual types of type1. - CSR, 2002-04-09 +;;; +;;; Previous comment, now obsolete, but worth keeping around because +;;; it is true, though too strong a condition: +;;; ;;; Two union types are equal if their subtypes are equal sets. (!define-type-method (union :simple-=) (type1 type2) - (type=-set (union-type-types type1) - (union-type-types type2))) + (multiple-value-bind (subtype certain?) + (csubtypep type1 type2) + (if subtype + (csubtypep type2 type1) + ;; we might as well become as certain as possible. + (if certain? + (values nil t) + (multiple-value-bind (subtype certain?) + (csubtypep type2 type1) + (declare (ignore subtype)) + (values nil certain?)))))) + +(!define-type-method (union :complex-=) (type1 type2) + (declare (ignore type1)) + (if (some #'hairy-type-p (union-type-types type2)) + (values nil nil) + (values nil t))) ;;; Similarly, a union type is a subtype of another if and only if ;;; every element of TYPE1 is a subtype of TYPE2. -(!define-type-method (union :simple-subtypep) (type1 type2) +(defun union-simple-subtypep (type1 type2) (every/type (swapped-args-fun #'union-complex-subtypep-arg2) type2 (union-type-types type1))) +(!define-type-method (union :simple-subtypep) (type1 type2) + (union-simple-subtypep type1 type2)) + (defun union-complex-subtypep-arg1 (type1 type2) (every/type (swapped-args-fun #'csubtypep) type2 (union-type-types type1))) + (!define-type-method (union :complex-subtypep-arg1) (type1 type2) (union-complex-subtypep-arg1 type1 type2)) (defun union-complex-subtypep-arg2 (type1 type2) - (multiple-value-bind (sub-value sub-certain?) - (any/type #'csubtypep type1 (union-type-types type2)) + (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))))) (if sub-certain? (values sub-value sub-certain?) ;; The ANY/TYPE expression above is a sufficient condition for @@ -2143,6 +2313,7 @@ ;; certain answer by this CALL-NEXT-METHOD-ish step when the ;; ANY/TYPE expression is uncertain. (invoke-complex-subtypep-arg1-method type1 type2)))) + (!define-type-method (union :complex-subtypep-arg2) (type1 type2) (union-complex-subtypep-arg2 type1 type2)) @@ -2160,9 +2331,19 @@ ;; CSUBTYPEP, in order to avoid possibly invoking any methods which ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus ;; cause infinite recursion. - (cond ((union-complex-subtypep-arg2 type1 type2) + ;; + ;; Within this method, type2 is guaranteed to be a union type: + (aver (union-type-p type2)) + ;; Make sure to call only the applicable methods... + (cond ((and (union-type-p type1) + (union-simple-subtypep type1 type2)) type1) + ((and (union-type-p type1) + (union-simple-subtypep type2 type1)) type2) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg2 type1 type2)) type1) - ((union-complex-subtypep-arg1 type2 type1) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg1 type2 type1)) type2) (t ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2