From 1cf230d59a80f5fba3b90b929e6ab61e9a6fbe84 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 10 Aug 2005 15:10:18 +0000 Subject: [PATCH] 0.9.3.37: Fix a pair of bugs relating to cons types, noted by Brian Mastenbrook (chandler on #lisp) in paste http://paste.lisp.org/display/10664 ... named :complex-=/:complex-subtypep needs to realise that CONS types can be *EMPTY-TYPE* (but no other type) in disguise; ... cons :simple-subtypep was just plain wrong when computing its certainty value. --- NEWS | 2 ++ src/code/late-type.lisp | 39 +++++++++++++++++++++++++++++++-------- tests/type.pure.lisp | 23 +++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 57 insertions(+), 9 deletions(-) diff --git a/NEWS b/NEWS index 8a32718..742056c 100644 --- a/NEWS +++ b/NEWS @@ -22,6 +22,8 @@ changes in sbcl-0.9.4 relative to sbcl-0.9.3: regular LAMBDA. * bug fix: PARSE-INTEGER no longer depends on the whitespaceness of characters in the current readtable. (reported by Nicholas Neuss) + * bug fix: SUBTYPEP on various CONS types returns more a more + accurate acknowledgment of its certainty. * optimizations: REMOVE-DUPLICATES now runs in linear time on lists in some cases. This partially fixes bug 384. * flush all standard streams before prompting in the REPL and the diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 1f0f2a7..6ec1446 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1057,15 +1057,35 @@ ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. (values (eq type1 type2) t)) +(defun cons-type-might-be-empty-type (type) + (declare (type cons-type type)) + (let ((car-type (cons-type-car-type type)) + (cdr-type (cons-type-cdr-type type))) + (or + (if (cons-type-p car-type) + (cons-type-might-be-empty-type car-type) + (multiple-value-bind (yes surep) + (type= car-type *empty-type*) + (aver (not yes)) + (not surep))) + (if (cons-type-p cdr-type) + (cons-type-might-be-empty-type cdr-type) + (multiple-value-bind (yes surep) + (type= cdr-type *empty-type*) + (aver (not yes)) + (not surep)))))) + (!define-type-method (named :complex-=) (type1 type2) (cond ((and (eq type2 *empty-type*) - (intersection-type-p type1) - ;; not allowed to be unsure on these... FIXME: keep the list - ;; of CL types that are intersection types once and only - ;; once. - (not (or (type= type1 (specifier-type 'ratio)) - (type= type1 (specifier-type 'keyword))))) + (or (and (intersection-type-p type1) + ;; not allowed to be unsure on these... FIXME: keep + ;; the list of CL types that are intersection types + ;; once and only once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + (and (cons-type-p type1) + (cons-type-might-be-empty-type type1)))) ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION ;; STREAM) can get here. In general, we can't really tell ;; whether these are equal to NIL or not, so @@ -1116,7 +1136,9 @@ (aver (not (eq type2 *wild-type*))) ; * isn't really a type. (cond ((eq type2 *universal-type*) (values t t)) - ((type-might-contain-other-types-p type1) + ((or (type-might-contain-other-types-p type1) + (and (cons-type-p type1) + (cons-type-might-be-empty-type type1))) ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in ;; disguise. So we'd better delegate. (invoke-complex-subtypep-arg1-method type1 type2)) @@ -2845,7 +2867,8 @@ (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) (if (and val-car val-cdr) (values t (and win-car win-cdr)) - (values nil (or win-car win-cdr)))))) + (values nil (or (and (not val-car) win-car) + (and (not val-cdr) win-cdr))))))) ;;; Give up if a precise type is not possible, to avoid returning ;;; overly general types. diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 5e4b98d..3bddb5b 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -266,3 +266,26 @@ ACTUAL ~D DERIVED ~D~%" op a b c d minimize brute derived) (assert (= brute derived))))))))))))) + +;;; subtypep on CONS types wasn't taking account of the fact that a +;;; CONS type could be the empty type (but no other non-CONS type) in +;;; disguise. +(multiple-value-bind (yes win) + (subtypep '(and function stream) 'nil) + (multiple-value-bind (cyes cwin) + (subtypep '(cons (and function stream) t) + '(cons nil t)) + (assert (eq yes cyes)) + (assert (eq win cwin)))) + +;;; CONS type subtypep could be too enthusiastic about thinking it was +;;; certain +(multiple-value-bind (yes win) + (subtypep '(satisfies foo) '(satisfies bar)) + (assert (null yes)) + (assert (null win)) + (multiple-value-bind (cyes cwin) + (subtypep '(cons (satisfies foo) t) + '(cons (satisfies bar) t)) + (assert (null cyes)) + (assert (null cwin)))) diff --git a/version.lisp-expr b/version.lisp-expr index b30a6b6..15fc5fb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.3.36" +"0.9.3.37" -- 1.7.10.4