From 37b5fc474cf0b4d739c12fc0356667a16006d217 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Thu, 11 Jan 2007 20:31:53 +0000 Subject: [PATCH] 1.0.1.20: Signal an error for duplicate tags in a tagbody rather than looping infinitely, allow using NIL as a go tag (thanks to Stephen Wilson) --- NEWS | 3 +++ src/code/full-eval.lisp | 3 ++- src/compiler/ir1-translators.lisp | 41 +++++++++++++++++++++---------------- tests/eval.impure.lisp | 23 +++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 52 insertions(+), 20 deletions(-) diff --git a/NEWS b/NEWS index 555ecba..bdde696 100644 --- a/NEWS +++ b/NEWS @@ -19,6 +19,9 @@ changes in sbcl-1.0.2 relative to sbcl-1.0.1: evaluated once (reported by Kevin Reid) * bug fix: the :SHOW-PROGRESS keyword parameter to SB-SPROF:WITH-PROFILING works again (thanks to Kilian Sprotte) + * bug fix: an error is signaled for tagbodies with duplicate tags + (thanks to Stephen Wilson) + * bug fix: NIL can be used as a tagbody tag (thanks to Stephen Wilson) changes in sbcl-1.0.1 relative to sbcl-1.0: * new platform: FreeBSD/x86-64, including support for threading. diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 56208a0..83c1122 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -893,7 +893,8 @@ (do ((form body (cdr form))) ((null form) nil) (when (atom (car form)) - ;; FIXME: detect duplicate tags + (when (assoc (car form) tags) + (ip-error "The tag :A appears more than once in a tagbody.")) (push (cons (car form) (cdr form)) tags) (push (cons (car form) #'go-to-tag) (env-tags env))))) ;; And then evaluate the forms in the body, starting from the diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index bd97ac8..72bcd18 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -133,28 +133,31 @@ extent of the block." ;;; like (
* (go )). That is, we break up the ;;; tagbody into segments of non-tag statements, and explicitly ;;; represent the drop-through with a GO. The first segment has a -;;; dummy NIL tag, since it represents code before the first tag. The +;;; dummy NIL tag, since it represents code before the first tag. Note +;;; however that NIL may appear as the tag of an inner segment. The ;;; last segment (which may also be the first segment) ends in NIL ;;; rather than a GO. (defun parse-tagbody (body) (declare (list body)) - (collect ((segments)) - (let ((current (cons nil body))) + (collect ((tags) + (segments)) + (let ((current body)) (loop - (let ((tag-pos (position-if (complement #'listp) current :start 1))) - (unless tag-pos - (segments `(,@current nil)) - (return)) - (let ((tag (elt current tag-pos))) - (when (assoc tag (segments)) - (compiler-error - "The tag ~S appears more than once in the tagbody." - tag)) - (unless (or (symbolp tag) (integerp tag)) - (compiler-error "~S is not a legal tagbody statement." tag)) - (segments `(,@(subseq current 0 tag-pos) (go ,tag)))) - (setq current (nthcdr tag-pos current))))) - (segments))) + (let ((next-segment (member-if #'atom current))) + (unless next-segment + (segments `(,@current nil)) + (return)) + (let ((tag (car next-segment))) + (when (member tag (tags)) + (compiler-error + "The tag ~S appears more than once in a tagbody." + tag)) + (unless (or (symbolp tag) (integerp tag)) + (compiler-error "~S is not a legal go tag." tag)) + (tags tag) + (segments `(,@(ldiff current next-segment) (go ,tag)))) + (setq current (rest next-segment)))) + (mapcar #'cons (cons nil (tags)) (segments))))) ;;; Set up the cleanup, emitting the entry node. Then make a block for ;;; each tag, building up the tag list for LEXENV-TAGS as we go. @@ -1007,7 +1010,9 @@ due to normal completion or a non-local exit such as THROW)." (ir1-convert start next result (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count) - `(flet ((,cleanup-fun () ,@cleanup nil)) + `(flet ((,cleanup-fun () + ,@cleanup + nil)) ;; FIXME: If we ever get DYNAMIC-EXTENT working, then ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT, ;; and something can be done to make %ESCAPE-FUN have diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 5989e51..a3db89d 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -197,4 +197,27 @@ (test-eval t '(if (true) t (oops))) (test-eval nil '(if (not (if (false) t)) (oops))) +;;; TAGBODY + +;;; As of SBCL 1.0.1.8, TAGBODY should not accept duplicate go tags, +;;; yet choked on two duplicate tags. Note that this test asserts a +;;; failure. +(with-test (:name :tagbody-dual-go-tags) + (progn + (defun tagbody-dual-go-tags () + (restart-case + (handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'NOT-AN-ERROR)))) + (tagbody :A :A) nil) + (NOT-AN-ERROR () t))) + (assert (tagbody-dual-go-tags)))) + +;;; Ensure that NIL is a valid go tag. +(with-test (:name :tagbody-nil-is-valid-tag) + (progn + (defun tagbody-nil-is-valid-tag () + (tagbody (go NIL) NIL) t) + (assert (tagbody-nil-is-valid-tag)))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index b179572..988c652 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".) -"1.0.1.19" +"1.0.1.20" -- 1.7.10.4