From: Christophe Rhodes <crhodes@us...>  20020419 17:38:37

Update of /cvsroot/sbcl/sbcl/src/code In directory uswprcvs1:/tmp/cvsserv24288/src/code Modified Files: crosstype.lisp latetype.lisp Log Message: 0.7.2.18: Merge CSR "More type hacking" sbcldevel 20020410 ... don't include request for explanation (as WHN explained) ... do crosstype of complex complex specifiers conservatively Index: crosstype.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/crosstype.lisp,v retrieving revision 1.16 retrieving revision 1.17 diff C2 d r1.16 r1.17 *** crosstype.lisp 8 Apr 2002 22:00:39 0000 1.16  crosstype.lisp 19 Apr 2002 16:27:21 0000 1.17 *************** *** 212,215 ****  212,221  (t (values nil t)))) + (;; Complexes suffer the same kind of problems as arrays + (and (not (unknowntypep (valuesspecifiertype targettype))) + (sb!xc:subtypep targettype 'cl:complex)) + (if (complexp hostobject) + (warnandgiveup) ; generalcase complexes being way too hard + (values nil t))) ; but "obviously not a complex" being easy ;; Some types require translation between the crosscompilation ;; host Common Lisp and the target SBCL. Index: latetype.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/latetype.lisp,v retrieving revision 1.44 retrieving revision 1.45 diff C2 d r1.44 r1.45 *** latetype.lisp 8 Apr 2002 22:00:39 0000 1.44  latetype.lisp 19 Apr 2002 16:27:21 0000 1.45 *************** *** 641,644 ****  641,646  (cond ((eq type1 type2) type1) + ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) ((or (uniontypep type1) (uniontypep type2)) *************** *** 693,696 ****  695,701  (declare (type ctype type1 type2)) (cond ((eq type1 type2) + ;; FIXME: For some reason, this doesn't catch e.g. type1 = + ;; type2 = (SPECIFIERTYPE + ;; 'SOMEUNKNOWNTYPE). Investigate.  CSR, 20020410 type1) ((or (intersectiontypep type1) *************** *** 915,919 **** (!definetypemethod (named :complexsubtypeparg1) (type1 type2) ! (aver (not (eq type1 *wildtype*))) ; * isn't really a type. (cond ((eq type1 *emptytype*) t)  920,930  (!definetypemethod (named :complexsubtypeparg1) (type1 type2) ! ;; 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 ! ;; *wildtype* a typeintersection executed by the compiler can.  ! ;; CSR, 20020410 ! ;; ! ;; (aver (not (eq type1 *wildtype*))) ; * isn't really a type. (cond ((eq type1 *emptytype*) t) *************** *** 934,938 **** (t ;; By elimination, TYPE1 is the universal type. ! (aver (eq type1 *universaltype*)) ;; This case would have been picked off by the SIMPLESUBTYPEP ;; method, and so shouldn't appear here.  945,949  (t ;; By elimination, TYPE1 is the universal type. ! (aver (or (eq type1 *wildtype*) (eq type1 *universaltype*))) ;; This case would have been picked off by the SIMPLESUBTYPEP ;; method, and so shouldn't appear here. *************** *** 1095,1100 **** (!definetypemethod (hairy :simpleintersection2 :complexintersection2) (type1 type2) ! (declare (ignore type1 type2)) ! nil) (!definetypemethod (hairy :simple=) (type1 type2)  1106,1112  (!definetypemethod (hairy :simpleintersection2 :complexintersection2) (type1 type2) ! (if (type= type1 type2) ! type1 ! nil)) (!definetypemethod (hairy :simple=) (type1 type2) *************** *** 2115,2140 **** `(or ,@(mapcar #'typespecifier (uniontypetypes type))))) ;;; Two union types are equal if their subtypes are equal sets. (!definetypemethod (union :simple=) (type1 type2) ! (type=set (uniontypetypes type1) ! (uniontypetypes type2))) ;;; Similarly, a union type is a subtype of another if and only if ;;; every element of TYPE1 is a subtype of TYPE2. ! (!definetypemethod (union :simplesubtypep) (type1 type2) (every/type (swappedargsfun #'unioncomplexsubtypeparg2) type2 (uniontypetypes type1))) (defun unioncomplexsubtypeparg1 (type1 type2) (every/type (swappedargsfun #'csubtypep) type2 (uniontypetypes type1))) (!definetypemethod (union :complexsubtypeparg1) (type1 type2) (unioncomplexsubtypeparg1 type1 type2)) (defun unioncomplexsubtypeparg2 (type1 type2) ! (multiplevaluebind (subvalue subcertain?) ! (any/type #'csubtypep type1 (uniontypetypes type2)) (if subcertain? (values subvalue subcertain?)  2127,2211  `(or ,@(mapcar #'typespecifier (uniontypetypes 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 simplesubtypep method delegates to complexsubtypep + ;;; of the individual types of type1.  CSR, 20020409 + ;;; + ;;; 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. (!definetypemethod (union :simple=) (type1 type2) ! (multiplevaluebind (subtype certain?) ! (csubtypep type1 type2) ! (if subtype ! (csubtypep type2 type1) ! ;; we might as well become as certain as possible. ! (if certain? ! (values nil t) ! (multiplevaluebind (subtype certain?) ! (csubtypep type2 type1) ! (declare (ignore subtype)) ! (values nil certain?)))))) ! ! (!definetypemethod (union :complex=) (type1 type2) ! (if (some #'hairytypep (uniontypetypes 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. ! (defun unionsimplesubtypep (type1 type2) (every/type (swappedargsfun #'unioncomplexsubtypeparg2) type2 (uniontypetypes type1))) + (!definetypemethod (union :simplesubtypep) (type1 type2) + (unionsimplesubtypep type1 type2)) + (defun unioncomplexsubtypeparg1 (type1 type2) (every/type (swappedargsfun #'csubtypep) type2 (uniontypetypes type1))) + (!definetypemethod (union :complexsubtypeparg1) (type1 type2) (unioncomplexsubtypeparg1 type1 type2)) (defun unioncomplexsubtypeparg2 (type1 type2) ! (multiplevaluebind (subvalue subcertain?) ! ;; was: (any/type #'csubtypep type1 (uniontypetypes 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 (uniontypep type2)) ! (aver (not (uniontypep 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, 20020410 ! (type= type1 ! (apply #'typeunion ! (mapcar (lambda (x) (typeintersection type1 x)) ! (uniontypetypes type2))))) (if subcertain? (values subvalue subcertain?) *************** *** 2144,2147 ****  2215,2219  ;; ANY/TYPE expression is uncertain. (invokecomplexsubtypeparg1method type1 type2)))) + (!definetypemethod (union :complexsubtypeparg2) (type1 type2) (unioncomplexsubtypeparg2 type1 type2)) *************** *** 2161,2167 **** ;; might in turn invoke (TYPEINTERSECTION2 TYPE1 TYPE2) and thus ;; cause infinite recursion. ! (cond ((unioncomplexsubtypeparg2 type1 type2) type1) ! ((unioncomplexsubtypeparg1 type2 type1) type2) (t  2233,2249  ;; might in turn invoke (TYPEINTERSECTION2 TYPE1 TYPE2) and thus ;; cause infinite recursion. ! ;; ! ;; Within this method, type2 is guaranteed to be a union type: ! (aver (uniontypep type2)) ! ;; Make sure to call only the applicable methods... ! (cond ((and (uniontypep type1) ! (unionsimplesubtypep type1 type2)) type1) ! ((and (uniontypep type1) ! (unionsimplesubtypep type2 type1)) type2) ! ((and (not (uniontypep type1)) ! (unioncomplexsubtypeparg2 type1 type2)) type1) ! ((and (not (uniontypep type1)) ! (unioncomplexsubtypeparg1 type2 type1)) type2) (t 