From ce18bcfe50994889a5e3245cacd8702b5a0ced89 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Fri, 19 Sep 2003 03:49:28 +0000 Subject: [PATCH] 0.8.3.80: * FROB-DO-BODY: wrap a body in an additional TAGBODY. --- NEWS | 2 ++ src/code/defboot.lisp | 12 ++++++------ src/code/numbers.lisp | 4 ++-- src/code/primordial-extensions.lisp | 14 +++++++------- src/compiler/ir1util.lisp | 6 +++--- tests/compiler.pure-cload.lisp | 14 ++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 35 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 05c1438..3dc1c06 100644 --- a/NEWS +++ b/NEWS @@ -1985,6 +1985,8 @@ changes in sbcl-0.8.3 relative to sbcl-0.8.2: used when the result is truncated to 32 bits. * VALUES declaration is partially enabled. * fixes in SB-GROVEL (thanks to Andreas Fuchs) + * bug fix: result form in DO is not contained in the implicit + TAGBODY. * fixed some bugs revealed by Paul Dietz' test suite: ** The system now obeys the constraint imposed by UPGRADED-ARRAY-ELEMENT-TYPE that the upgraded array element diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 978a3c8..2cd77e9 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -285,14 +285,14 @@ (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body) (cond ((numberp count) `(do ((,var 0 (1+ ,var))) - ((>= ,var ,count) ,result) - (declare (type unsigned-byte ,var)) - ,@body)) + ((>= ,var ,count) ,result) + (declare (type unsigned-byte ,var)) + ,@body)) (t (let ((v1 (gensym))) `(do ((,var 0 (1+ ,var)) (,v1 ,count)) - ((>= ,var ,v1) ,result) - (declare (type unsigned-byte ,var)) - ,@body))))) + ((>= ,var ,v1) ,result) + (declare (type unsigned-byte ,var)) + ,@body))))) (defmacro-mundanely dolist ((var list &optional (result nil)) &body body) ;; We repeatedly bind the var instead of setting it so that we never diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index bcd2c0c..3632cd6 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -1358,8 +1358,8 @@ #. (collect ((forms)) (flet ((definition (name lambda-list width pattern) - ;; We rely on (SUBTYPEP `(UNSIGNED-BYTE ,WIDTH) - ;; 'BIGNUM-ELEMENT-TYPE) + (assert (sb!xc:subtypep `(unsigned-byte ,width) + 'bignum-element-type)) `(defun ,name ,lambda-list (flet ((prepare-argument (x) (declare (integer x)) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index a70b2c2..48be86d 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -104,13 +104,13 @@ (,bind ,(nreverse r-inits) ,@decls (tagbody - (go ,label-2) - ,label-1 - ,@code - (,step ,@(nreverse r-steps)) - ,label-2 - (unless ,(first endlist) (go ,label-1)) - (return-from ,block (progn ,@(rest endlist)))))))))) + (go ,label-2) + ,label-1 + (tagbody ,@code) + (,step ,@(nreverse r-steps)) + ,label-2 + (unless ,(first endlist) (go ,label-1)) + (return-from ,block (progn ,@(rest endlist)))))))))) ;;; This is like DO, except it has no implicit NIL block. Each VAR is ;;; initialized in parallel to the value of the specified INIT form. diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 41d7a58..d909bf1 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -792,10 +792,10 @@ (dolist (child (lambda-children lambda)) (if (eq (functional-kind child) :deleted) (delete-children child) - (delete-lambda child)) - (setf (lambda-children lambda) nil)) + (delete-lambda child))) + (setf (lambda-children lambda) nil) (setf (lambda-parent lambda) nil))) - (delete-children clambda))) + (delete-children clambda))) (dolist (let (lambda-lets clambda)) (setf (lambda-bind let) nil) (setf (functional-kind let) :deleted)) diff --git a/tests/compiler.pure-cload.lisp b/tests/compiler.pure-cload.lisp index 28f17a9..c21dad7 100644 --- a/tests/compiler.pure-cload.lisp +++ b/tests/compiler.pure-cload.lisp @@ -101,6 +101,20 @@ (optimize (speed 3) (safety 1) (debug 1))) (let ((v3 (min -1720 b))) (max v3 (logcount (if (= v3 b) b b))))) +;;; RESULT-FORM in DO is not contained in the implicit TAGBODY +(assert (eq (handler-case (eval `(do ((x '(1 2 3) (cdr x))) + ((endp x) (go :loop)) + :loop + (unless x (return :bad)))) + (error () :good)) + :good)) +(assert (eq (handler-case (eval `(do* ((x '(1 2 3) (cdr x))) + ((endp x) (go :loop)) + :loop + (unless x (return :bad)))) + (error () :good)) + :good)) + ;;; bug 282 ;;; ;;; Verify type checking policy in full calls: the callee is supposed diff --git a/version.lisp-expr b/version.lisp-expr index d3c49a8..6354209 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.8.3.79" +"0.8.3.80" -- 1.7.10.4