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)

diff --git a/NEWS b/NEWS
index 555ecba..bdde696 100644 (file)
--- 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 (file)
--- 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 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -133,28 +133,31 @@ extent of the block."
 ;;; like (<tag> <form>* (go <next tag>)). 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 (file)
--- 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 (file)
--- 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"