X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=b2877230435f2de1c08e2969dc378872fb757fd7;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=3005a9b8f40a3d64881691125f19a595ad5efeef;hpb=ec2616d216958a608581802c47496c0194478dc8;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 3005a9b..b287723 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -65,21 +65,29 @@ ;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 ;;; method. INFO is a list of conses ;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). -;;; This will never be called with a hairy type as TYPE2, since the -;;; hairy type TYPE2 method gets first crack. (defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info) - (values - (and (sb!xc:typep type2 'sb!xc:class) - (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))))) - (dotimes (i (length inherits) nil) - (when (eq type2 (layout-class (svref inherits i))) - (return t))))))))) - t)) + ;; If TYPE2 might be concealing something related to our class + ;; hierarchy + (if (type-might-contain-other-types? 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 + ;; the underlying set + (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) + (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))))) + (dotimes (i (length inherits) nil) + (when (eq type2 (layout-class (svref inherits i))) + (return t))))))))) + t))) ;;; This function takes a list of specs, each of the form ;;; (SUPERCLASS-NAME &OPTIONAL GUARD). @@ -560,8 +568,7 @@ (eq type1 *empty-type*) (eq type2 *wild-type*)) (values t t)) - ((or (eq type1 *wild-type*) - (eq type2 *empty-type*)) + ((eq type1 *wild-type*) (values nil t)) (t (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 @@ -633,6 +640,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 @@ -685,6 +694,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)) @@ -893,7 +905,7 @@ (frob t *universal-type*)) (setf *universal-fun-type* (make-fun-type :wild-args t - :returns *wild-type*))) + :returns *wild-type*))) (!define-type-method (named :simple-=) (type1 type2) ;; FIXME: BUG 85: This assertion failed when I added it in @@ -907,26 +919,45 @@ (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. - ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause - ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over - ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..) - (aver (not (hairy-type-p type2))) - ;; Besides the old CMU CL assertion above, we also need to avoid - ;; compound types, else we could get into trouble with - ;; (SUBTYPEP T '(OR (SATISFIES FOO) (SATISFIES BAR))) - ;; or - ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))). - (aver (not (compound-type-p type2))) - ;; Then, since TYPE2 is reasonably tractable, we're good to go. - (values (eq type1 *empty-type*) t)) + ;; 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) + ;; 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 + ;; HAIRY-TYPEs as we used to. Instead we deal with the + ;; problem (where at least part of the problem is cases like + ;; (SUBTYPEP T '(SATISFIES FOO)) + ;; or + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) + ;; where the second type is a hairy type like SATISFIES, or + ;; is a compound type which might contain a hairy type) by + ;; returning uncertainty. + (values nil nil)) + (t + ;; By elimination, TYPE1 is the 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*))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the + ;; universal type in disguise, TYPE2 is not a superset of TYPE1. + (values nil t)))) (!define-type-method (named :complex-subtypep-arg2) (type1 type2) (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) ((hairy-type-p type1) - (values nil nil)) + (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 @@ -972,11 +1003,13 @@ complement-type2))) (if intersection2 (values (eq intersection2 *empty-type*) t) - (values nil nil)))) + (invoke-complex-subtypep-arg1-method type1 type2)))) (t - (values nil nil))))) + (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 @@ -1008,11 +1041,31 @@ (return (values nil nil))) (when equal (return (values nil t)))) - ;; This (TYPE= TYPE1 TYPE2) branch would never be - ;; taken, as type1 and type2 will only be equal if + ;; 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? complement-type1) + (type-might-contain-other-types? 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. - ;; ((type= type1 type2) (values t t)) + ;; 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 @@ -1030,16 +1083,18 @@ (return (values nil nil))) (when equal (return (values nil t)))) - ;; 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). + ;; 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))))) @@ -1050,8 +1105,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) @@ -1445,21 +1501,27 @@ (lb (if (consp l) (1+ (car l)) l)) (h (canonicalized-bound high 'integer)) (hb (if (consp h) (1- (car h)) h))) - (when (and hb lb (< hb lb)) - (error "Lower bound ~S is greater than upper bound ~S." l h)) - (make-numeric-type :class 'integer - :complexp :real - :enumerable (not (null (and l h))) - :low lb - :high hb))) + (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) + (make-numeric-type :class 'integer + :complexp :real + :enumerable (not (null (and l h))) + :low lb + :high hb)))) (defmacro !def-bounded-type (type class format) `(!def-type-translator ,type (&optional (low '*) (high '*)) (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) - (unless (numeric-bound-test* lb hb <= <) - (error "Lower bound ~S is not less than upper bound ~S." low high)) - (make-numeric-type :class ',class :format ',format :low lb :high hb)))) + (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))))) (!def-bounded-type rational rational nil) @@ -1919,7 +1981,8 @@ ;;; subtype of the MEMBER type. (!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) - ((types-equal-or-intersect type1 type2) (values nil nil)) + ((types-equal-or-intersect type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) (t (values nil t)))) (!define-type-method (member :simple-intersection2) (type1 type2) @@ -2063,27 +2126,95 @@ 'list `(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) + (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 every element -;;; of TYPE1 is a subtype of some element of TYPE2. -(!define-type-method (union :simple-subtypep) (type1 type2) +;;; Similarly, a union type is a subtype of another if and only if +;;; every element of TYPE1 is a subtype of 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) - (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 + ;; subsetness, but not a necessary one, so we might get a more + ;; 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)) @@ -2101,9 +2232,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