From 6c4d4d984b1af6b2a73568cec3ab9c8795cff2da Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 26 Oct 2002 05:30:58 +0000 Subject: [PATCH] 0.7.9.1: * Added #+cmu(ext:quit) to build scripts * Fixed SIMPLE-SUBTYPEP type method for FUNCTIONs --- BUGS | 20 +++++++++++++++++++- make-genesis-2.sh | 1 + make-host-1.sh | 1 + make-host-2.sh | 1 + src/code/late-type.lisp | 43 ++++++++++++++++++++++++++++++++++++++++--- tests/compiler.impure.lisp | 12 ++++++++++++ version.lisp-expr | 2 +- 7 files changed, 75 insertions(+), 5 deletions(-) diff --git a/BUGS b/BUGS index 0df09bc..36986f9 100644 --- a/BUGS +++ b/BUGS @@ -1354,7 +1354,7 @@ WORKAROUND: the bad VECTOR-PUSH-EXTEND frame causes GC problems, though that may not be the actual problem. (CMU CL 18c doesn't have problems with this.) -217: +217: "Bad type operations with FUNCTION types" In sbcl.0.7.7: * (values-type-union (specifier-type '(function (base-char))) @@ -1362,6 +1362,24 @@ WORKAROUND: # + It causes insertion of wrong type assertions into generated + code. E.g. + + (defun foo (x s) + (let ((f (etypecase x + (character #'write-char) + (integer #'write-byte)))) + (funcall f x s) + (etypecase x + (character (write-char x s)) + (integer (write-byte x s))))) + + Then (FOO #\1 *STANDARD-OUTPUT*) signals type error. + + (In 0.7.9.1 the result type is (FUNCTION * *), so Python does not + produce invalid code, but type checking is not accurate. Similar + problems exist with VALUES-TYPE-INTERSECTION.) + DEFUNCT CATEGORIES OF BUGS IR1-#: diff --git a/make-genesis-2.sh b/make-genesis-2.sh index 620e680..551a34f 100644 --- a/make-genesis-2.sh +++ b/make-genesis-2.sh @@ -50,6 +50,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 ;; The map file is not needed by the system, but can ;; be very handy when debugging cold init problems. :map-file-name "output/cold-sbcl.map") + #+cmu (ext:quit) EOF echo //testing for consistency of first and second GENESIS passes diff --git a/make-host-1.sh b/make-host-1.sh index 82ca185..6bbe840 100644 --- a/make-host-1.sh +++ b/make-host-1.sh @@ -44,4 +44,5 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (load "tests/info.before-xc.lisp")) (host-cload-stem "src/compiler/generic/genesis") (sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h") + #+cmu (ext:quit) EOF diff --git a/make-host-2.sh b/make-host-2.sh index 5d0fdf1..e3c4f3f 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -123,6 +123,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil) #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core") ) + #+cmu (ext:quit) EOF # Run GENESIS (again) in order to create cold-sbcl.core. (The first diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 171ad65..70ccba2 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -69,7 +69,7 @@ ;; If TYPE2 might be concealing something related to our class ;; hierarchy (if (type-might-contain-other-types-p type2) - ;; too confusing, gotta punt + ;; too confusing, gotta punt (values nil nil) ;; ordinary case expected by old CMU CL code, where the taxonomy ;; of TYPE2's representation accurately reflects the taxonomy of @@ -216,8 +216,45 @@ ;;; Since all function types are equivalent to FUNCTION, they are all ;;; subtypes of each other. (!define-type-method (function :simple-subtypep) (type1 type2) - (declare (ignore type1 type2)) - (values t t)) + (flet ((fun-type-simple-p (type) + (not (or (fun-type-rest type) + (fun-type-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (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 (or win1 win2)))))))) + (3and (csubtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) + (values t t)) + ((fun-type-wild-args type1) + (values nil t)) + ((not (or (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + ((not (and (= (length (fun-type-required type1)) + (length (fun-type-required type2))) + (= (length (fun-type-optional type1)) + (length (fun-type-optional type2))))) + (values nil t)) + (t (3and (every-csubtypep (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep (fun-type-optional type1) + (fun-type-optional type2))))))))) (!define-superclasses function ((function)) !cold-init-forms) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index ea565bf..f128f15 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -555,6 +555,18 @@ BUG 48c, not yet fixed: (assert failure-p) (assert (raises-error? (funcall result) program-error)))) +;;; bug 217: wrong type inference +(defun bug217-1 (x s) + (let ((f (etypecase x + (character #'write-char) + (integer #'write-byte)))) + (funcall f x s) + (etypecase x + (character (write-char x s)) + (integer (write-byte x s))))) + +(bug217-1 #\1 *standard-output*) + ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/version.lisp-expr b/version.lisp-expr index 69c1d34..a5363bb 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.9" +"0.7.9.1" -- 1.7.10.4