From: Christophe R. <cr...@us...> - 2003-02-27 17:20:41
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv14850/src/code Modified Files: late-type.lisp Log Message: 0.7.13.7: Fix really stupid bug in CONS :SIMPLE-UNION method ... don't mix the CDR type into the CAR type While I'm there, make the CONS :SIMPLE-UNION method smarter ... canonicalize unions of (CONS A D) with (CONS A' D'), where A subtypep A', to (OR (CONS A (OR D D')) (CONS (AND A' (NOT A)) D')) the point being that this is then in a form that can be further canonicalized when more CONS types come along. This fixes about 5 bugs from pfdietz's suite. Index: late-type.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v retrieving revision 1.71 retrieving revision 1.72 diff -u -d -r1.71 -r1.72 --- late-type.lisp 18 Feb 2003 11:44:43 -0000 1.71 +++ late-type.lisp 27 Feb 2003 17:20:02 -0000 1.72 @@ -2681,13 +2681,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 |