From 0f2ae6ebc3520494b665a9dbf32c36c671334d36 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 27 Feb 2003 17:20:00 +0000 Subject: [PATCH] 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. --- src/code/late-type.lisp | 36 +++++++++++++++++++++++++++++------- tests/type.pure.lisp | 7 +++++++ version.lisp-expr | 2 +- 3 files changed, 37 insertions(+), 8 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 623ff1c..0feadf6 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -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 diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 5c570c9..fd8409e 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -193,3 +193,10 @@ '(rational 0 10))) (assert (subtypep '(rational 0 10) '(or (eql 0) (rational (0) 10)))) +;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the +;;; same type gave exceedingly wrong results +(assert (null (subtypep '(or (cons fixnum single-float) + (cons bignum single-float)) + '(cons single-float single-float)))) +(assert (subtypep '(cons integer single-float) + '(or (cons fixnum single-float) (cons bignum single-float)))) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 776bb31..1a95f6f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.13.6" +"0.7.13.7" -- 1.7.10.4