From 508bf17fa9e609c523a2795d84a3bc908db1b302 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Wed, 9 Apr 2003 12:42:21 +0000 Subject: [PATCH] 0.pre8.51: TYPE=-SET uses 3-values logic. --- BUGS | 22 +++++++++++ package-data-list.lisp-expr | 1 + src/code/early-extensions.lisp | 9 +++++ src/code/late-type.lisp | 80 ++++++++++++++++++---------------------- tests/type.pure.lisp | 3 ++ version.lisp-expr | 2 +- 6 files changed, 71 insertions(+), 46 deletions(-) diff --git a/BUGS b/BUGS index f43d6b2..23d87a5 100644 --- a/BUGS +++ b/BUGS @@ -845,6 +845,28 @@ WORKAROUND: (INTEGER 1296 1296) ...)>)[:EXTERNAL] + In recent SBCL the following example also illustrates this bug: + + (time (compile + nil + '(lambda () + (declare (optimize (safety 3))) + (declare (optimize (compilation-speed 2))) + (declare (optimize (speed 1) (debug 1) (space 1))) + (let ((start 4)) + (declare (type (integer 0) start)) + (print (incf start 22)) + (print (incf start 26)) + (print (incf start 28))) + (let ((start 6)) + (declare (type (integer 0) start)) + (print (incf start 22)) + (print (incf start 26))) + (let ((start 10)) + (declare (type (integer 0) start)) + (print (incf start 22)) + (print (incf start 26)))))) + 190: "PPC/Linux pipe? buffer? bug" In sbcl-0.7.6, the run-program.test.sh test script sometimes hangs on the PPC/Linux platform, waiting for a zombie env process. This diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2d865d3..72e86e4 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -737,6 +737,7 @@ retained, possibly temporariliy, because it might be used internally." "CYCLIC-LIST-P" "COMPOUND-OBJECT-P" "SWAPPED-ARGS-FUN" + "AND/TYPE" "ANY/TYPE" "EVERY/TYPE" "EQUAL-BUT-NO-CAR-RECURSION" "TYPE-BOUND-NUMBER" diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 4522aa2..fe0f319 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -916,6 +916,15 @@ which can be found at .~:@>" ;;;; utilities for two-VALUES predicates +(defmacro and/type (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2)))))))) + ;;; sort of like ANY and EVERY, except: ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. ;;; (And if the result is uncertain, then we return (VALUES NIL NIL), diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 15b8cb5..b1df87b 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -231,43 +231,35 @@ (csubtypep a1 a2) (unless res (return (values res sure-p)))) finally (return (values t t))))) - (macrolet ((3and (x y) - `(multiple-value-bind (val1 win1) ,x - (if (and (not val1) win1) - (values nil t) - (multiple-value-bind (val2 win2) ,y - (if (and val1 val2) - (values t t) - (values nil (and win2 (not val2))))))))) - (3and (values-subtypep (fun-type-returns type1) - (fun-type-returns type2)) - (cond ((fun-type-wild-args type2) (values t t)) - ((fun-type-wild-args type1) - (cond ((fun-type-keyp type2) (values nil nil)) - ((not (fun-type-rest type2)) (values nil t)) - ((not (null (fun-type-required type2))) (values nil t)) - (t (3and (type= *universal-type* (fun-type-rest type2)) - (every/type #'type= *universal-type* - (fun-type-optional type2)))))) - ((not (and (fun-type-simple-p type1) - (fun-type-simple-p type2))) - (values nil nil)) - (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) - (multiple-value-bind (min2 max2) (fun-type-nargs type2) - (cond ((or (> max1 max2) (< min1 min2)) - (values nil t)) - ((and (= min1 min2) (= max1 max2)) - (3and (every-csubtypep (fun-type-required type1) - (fun-type-required type2)) - (every-csubtypep (fun-type-optional type1) - (fun-type-optional type2)))) - (t (every-csubtypep - (concatenate 'list - (fun-type-required type1) - (fun-type-optional type1)) - (concatenate 'list - (fun-type-required type2) - (fun-type-optional type2))))))))))))) + (and/type (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((fun-type-wild-args type1) + (cond ((fun-type-keyp type2) (values nil nil)) + ((not (fun-type-rest type2)) (values nil t)) + ((not (null (fun-type-required type2))) (values nil t)) + (t (and/type (type= *universal-type* (fun-type-rest type2)) + (every/type #'type= *universal-type* + (fun-type-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) + (multiple-value-bind (min2 max2) (fun-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (and/type (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2)))))))))))) (!define-superclasses function ((function)) !cold-init-forms) @@ -2404,15 +2396,13 @@ ;;; shared machinery for type equality: true if every type in the set ;;; TYPES1 matches a type in the set TYPES2 and vice versa (defun type=-set (types1 types2) - (flet (;; true if every type in the set X matches a type in the set Y - (type<=-set (x y) + (flet ((type<=-set (x y) (declare (type list x y)) - (every (lambda (xelement) - (position xelement y :test #'type=)) - x))) - (values (and (type<=-set types1 types2) - (type<=-set types2 types1)) - t))) + (every/type (lambda (x y-element) + (any/type #'type= y-element x)) + x y))) + (and/type (type<=-set types1 types2) + (type<=-set types2 types1)))) ;;; Two intersection types are equal if their subtypes are equal sets. ;;; diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index c4b282a..557b327 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -200,3 +200,6 @@ '(cons single-float single-float)))) (assert (subtypep '(cons integer single-float) '(or (cons fixnum single-float) (cons bignum single-float)))) + +(assert (not (nth-value 1 (subtypep '(and null some-unknown-type) + 'another-unknown-type)))) diff --git a/version.lisp-expr b/version.lisp-expr index 740dce8..adeac00 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.pre8.50" +"0.pre8.51" -- 1.7.10.4