From: Nikodemus Siivola <demoss@us...>  20060823 12:46:30

Update of /cvsroot/sbcl/sbcl/src/code In directory sc8prcvs8.sourceforge.net:/tmp/cvsserv15277/src/code Modified Files: latetype.lisp Log Message: 0.9.15.48: more precice unions of array types * implement ARRAY :SIMPLEUNION2, and don't use CSUBTYPEP to shortcut unions where both types are array types  fixes bug #306a. (Move to tests.) * move comments in UNIONCOMPLEXSUBTYPEPARG2 slightly for clarity. * bug #367 went with #368. * bug #387 is fixed nowadays. Index: latetype.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/latetype.lisp,v retrieving revision 1.130 retrieving revision 1.131 diff u d r1.130 r1.131  latetype.lisp 21 Aug 2006 17:54:38 0000 1.130 +++ latetype.lisp 23 Aug 2006 12:46:26 0000 1.131 @@ 792,19 +792,25 @@ ;; e.g. fading away in favor of some CLOS solution) the shared logic ;; should probably become shared code.  WHN 20010316 (declare (type ctype type1 type2))  (cond ((eq type1 type2)  type1)  ((csubtypep type1 type2) type2)  ((csubtypep type2 type1) type1)  ((or (uniontypep type1)  (uniontypep type2))  ;; Unions of UNIONTYPE should have the UNIONTYPETYPES  ;; values broken out and united separately. The full TYPEUNION  ;; function knows how to do this, so let it handle it.  (typeunion type1 type2))  (t  ;; the ordinary case: we dispatch to type methods  (%typeunion2 type1 type2)))) + (let ((t2 nil)) + (cond ((eq type1 type2) + type1) + ;; CSUBTYPEP for arraytypes answers questions about the + ;; specialized type, yet for union we want to take the + ;; expressed type in account too. + ((and (not (and (arraytypep type1) (arraytypep type2))) + (or (setf t2 (csubtypep type1 type2)) + (csubtypep type2 type1))) + (if t2 type2 type1)) + ((or (uniontypep type1) + (uniontypep type2)) + ;; Unions of UNIONTYPE should have the UNIONTYPETYPES + ;; values broken out and united separately. The full TYPEUNION + ;; function knows how to do this, so let it handle it. + (typeunion type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%typeunion2 type1 type2))))) ;;; the type method dispatch case of TYPEINTERSECTION2 (defun %typeintersection2 (type1 type2) @@ 2400,6 +2406,41 @@ (t (values nil t))))) +(!definetypemethod (array :simpleunion2) (type1 type2) + (let* ((dims1 (arraytypedimensions type1)) + (dims2 (arraytypedimensions type2)) + (complexp1 (arraytypecomplexp type1)) + (complexp2 (arraytypecomplexp type2)) + (eltype1 (arraytypeelementtype type1)) + (eltype2 (arraytypeelementtype type2)) + (stype1 (arraytypespecializedelementtype type1)) + (stype2 (arraytypespecializedelementtype type2)) + (wild1 (eq eltype1 *wildtype*)) + (wild2 (eq eltype2 *wildtype*)) + (e2 nil)) + ;; This is possibly a bit more conservative then it needs to be: + ;; it seems that wild eltype in either should lead to wild eltype + ;; in result, but the rest of the typesystem doesn't seem too + ;; happy about that. NS 20060823 + (when (and (or (and wild1 wild2) + (and (not (or wild1 wild2)) + (or (setf e2 (csubtypep eltype1 eltype2)) + (csubtypep eltype2 eltype1)))) + (type= stype1 stype2)) + (makearraytype + :dimensions (cond ((or (eq dims1 '*) (eq dims2 '*)) + '*) + ((equal dims1 dims2) + dims1) + ((= (length dims1) (length dims2)) + (mapcar (lambda (x y) (if (eq x y) x '*)) + dims1 dims2)) + (t + '*)) + :complexp (if (eq complexp1 complexp2) complexp1 :maybe) + :elementtype (if (or wild2 e2) eltype2 eltype1) + :specializedelementtype stype1)))) + (!definetypemethod (array :simpleintersection2) (type1 type2) (declare (type arraytype type1 type2)) (if (arraytypesintersect type1 type2) @@ 2815,40 +2856,40 @@ (unioncomplexsubtypeparg1 type1 type2)) (defun unioncomplexsubtypeparg2 (type1 type2) + ;; 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))) + ;; 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: + ;; + ;; 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 (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))))) + (type= type1 + (apply #'typeunion + (mapcar (lambda (x) (typeintersection type1 x)) + (uniontypetypes type2)))) (if subcertain? (values subvalue subcertain?) ;; The ANY/TYPE expression above is a sufficient condition for 