From d366781e5d345aeb5e1468a8bc48c4811e22fd5d Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Tue, 4 Mar 2003 14:14:31 +0000
Subject: [PATCH] Tests to check that some forms with implicit progns do not
 also have implicit tagbodies.

---
 ansi-tests/block.lsp                |  12 ++++++++++++
 ansi-tests/case.lsp                 |  25 +++++++++++++++++++++++++
 ansi-tests/catch.lsp                |  12 ++++++++++++
 ansi-tests/ccase.lsp                |  16 +++++++++++++---
 ansi-tests/cond.lsp                 |  13 ++++++++++---
 ansi-tests/ctypecase.lsp            |  11 +++++++++++
 ansi-tests/destructuring-bind.lsp   |  10 ++++++++++
 ansi-tests/ecase.lsp                |  11 +++++++++++
 ansi-tests/etypecase.lsp            |  12 ++++++++++++
 ansi-tests/flet.lsp                 |  10 +++++++++-
 ansi-tests/labels.lsp               |  10 ++++++++++
 ansi-tests/length.lsp               | Bin 2452 -> 3086 bytes
 ansi-tests/let.lsp                  |  19 +++++++++++++++++++
 ansi-tests/multiple-value-bind.lsp  |  12 ++++++++++++
 ansi-tests/multiple-value-prog1.lsp |  14 ++++++++++++++
 ansi-tests/prog1.lsp                |  10 ++++++++++
 ansi-tests/prog2.lsp                |  12 ++++++++++++
 ansi-tests/progn.lsp                |  12 ++++++++++++
 ansi-tests/progv.lsp                |  10 ++++++++++
 ansi-tests/typecase.lsp             |  26 ++++++++++++++++++++++++++
 ansi-tests/unless.lsp               |  12 ++++++++++++
 ansi-tests/unwind-protect.lsp       |  13 +++++++++++++
 ansi-tests/when.lsp                 |  13 +++++++++++++
 23 files changed, 288 insertions(+), 7 deletions(-)

diff --git a/ansi-tests/block.lsp b/ansi-tests/block.lsp
index b68d9dff..84321ffb 100644
--- a/ansi-tests/block.lsp
+++ b/ansi-tests/block.lsp
@@ -64,6 +64,18 @@
     'bad)
   good)
 
+;;; Block has no tagbody
+(deftest block.11
+  (block done
+    (tagbody
+     (block nil
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
 #|
 (deftest return.error.1
   (classify-error
diff --git a/ansi-tests/case.lsp b/ansi-tests/case.lsp
index 3118ccc7..0ec8b1bd 100644
--- a/ansi-tests/case.lsp
+++ b/ansi-tests/case.lsp
@@ -166,6 +166,31 @@
   (case 'a (b 'b) (otherwise))
   nil)
 
+;;; No implicit tagbody
+(deftest case.35
+  (block done
+    (tagbody
+     (case 'a (a (go 10)
+		 10
+		 (return-from done 'bad)))
+     10
+     (return-from done 'good)))
+  good)
+
+(deftest case.36
+  (block done
+    (tagbody
+     (case 'b
+       (a 'bad)
+       (otherwise (go 10)
+		  10
+		  (return-from done 'bad)))
+     10
+     (return-from done 'good)))
+  good)
+
+
+
 ;;; (deftest case.error.1
 ;;;  (classify-error (case))
 ;;;  program-error)
diff --git a/ansi-tests/catch.lsp b/ansi-tests/catch.lsp
index 5a3732e2..2cbcadb1 100644
--- a/ansi-tests/catch.lsp
+++ b/ansi-tests/catch.lsp
@@ -70,6 +70,18 @@
       'bad))
   good)
 
+;;; No implicit tagbody
+(deftest catch.13
+  (block done
+    (tagbody
+     (catch 'foo
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
 (deftest throw-error
   (classify-error (throw (gensym) nil))
   control-error)
diff --git a/ansi-tests/ccase.lsp b/ansi-tests/ccase.lsp
index 8bbc4455..76642a35 100644
--- a/ansi-tests/ccase.lsp
+++ b/ansi-tests/ccase.lsp
@@ -181,9 +181,19 @@
       (2 nil))))
   :good)
 
+;;; No implicit tagbody
+(deftest ccase.32
+  (block done
+    (tagbody
+     (let ((x 'a))
+       (ccase x (a (go 10)
+		   10
+		   (return-from done 'bad))))
+     10
+     (return-from done 'good)))
+  good)
+
+
 ;;; (deftest ccase.error.1
 ;;;  (classify-error (ccase))
 ;;;  program-error)
-
-
-    
diff --git a/ansi-tests/cond.lsp b/ansi-tests/cond.lsp
index df342485..1150887c 100644
--- a/ansi-tests/cond.lsp
+++ b/ansi-tests/cond.lsp
@@ -70,6 +70,13 @@
 
 (deftest cond.14 (cond (t (values))))
 
-
-
-
+;;; No implicit tagbody
+(deftest cond.15
+  (block done
+    (tagbody
+     (cond (t (go 10)
+	      10
+	      (return-from done 'bad)))
+     10
+     (return-from done 'good)))
+  good)
diff --git a/ansi-tests/ctypecase.lsp b/ansi-tests/ctypecase.lsp
index 7e7ea508..c786a7c1 100644
--- a/ansi-tests/ctypecase.lsp
+++ b/ansi-tests/ctypecase.lsp
@@ -86,3 +86,14 @@
 	     (#.(find-class 'symbol nil) 'good))
   good)
 
+(deftest ctypecase.14
+  (block done
+    (tagbody
+     (let ((x 'a))
+       (ctypecase x (symbol (go 10)
+			    10
+			    (return-from done 'bad))))
+     10
+     (return-from done 'good)))
+  good)
+
diff --git a/ansi-tests/destructuring-bind.lsp b/ansi-tests/destructuring-bind.lsp
index d24eb5cb..afa8d97d 100644
--- a/ansi-tests/destructuring-bind.lsp
+++ b/ansi-tests/destructuring-bind.lsp
@@ -80,6 +80,16 @@
   (destructuring-bind ((&key a b c)) '((:c 1 :b 2)) (values a b c))
   nil 2 1)
 
+;;; Test that destructuring-bind does not have a tagbody
+(deftest destructuring-bind.19
+  (block nil
+    (tagbody
+     (destructuring-bind (a . b) '(1 2) (go 10) 10 (return 'bad))
+     10
+     (return 'good)))
+  good)
+
+
 ;;; Error cases
 
 #|
diff --git a/ansi-tests/ecase.lsp b/ansi-tests/ecase.lsp
index ed47af86..72c37715 100644
--- a/ansi-tests/ecase.lsp
+++ b/ansi-tests/ecase.lsp
@@ -147,3 +147,14 @@
 (deftest ecase.32
   (ecase 'a (a) (b 'b))
   nil)
+
+;;; No implicit tagbody
+(deftest ecase.33
+  (block done
+    (tagbody
+     (ecase 'a (a (go 10)
+		  10
+		  (return-from done 'bad)))
+     10
+     (return-from done 'good)))
+  good)
diff --git a/ansi-tests/etypecase.lsp b/ansi-tests/etypecase.lsp
index 06d46ec6..189cbde7 100644
--- a/ansi-tests/etypecase.lsp
+++ b/ansi-tests/etypecase.lsp
@@ -59,3 +59,15 @@
     (#.(find-class 'symbol nil) 'good))
   good)
 
+(deftest etypecase.13
+  (block nil
+    (tagbody
+     (let ((x 'a))
+       (etypecase x (symbol (go 10)
+			    10
+			    (return 'bad))))
+     10
+     (return 'good)))
+  good)
+
+
diff --git a/ansi-tests/flet.lsp b/ansi-tests/flet.lsp
index a4691f72..0b3099fe 100644
--- a/ansi-tests/flet.lsp
+++ b/ansi-tests/flet.lsp
@@ -428,4 +428,12 @@
 	collect s)
   nil)
 
-
+;;; Check that FLET does not have a tagbody
+(deftest flet.52
+  (block done
+    (tagbody
+     (flet ((%f () (go 10) 10 (return-from done 'bad)))
+       (%f))
+     10
+     (return-from done 'good)))
+  good)
diff --git a/ansi-tests/labels.lsp b/ansi-tests/labels.lsp
index 37f88021..466c1502 100644
--- a/ansi-tests/labels.lsp
+++ b/ansi-tests/labels.lsp
@@ -212,3 +212,13 @@
 	unless (eq (eval form) 'a)
 	collect s)
   nil)
+
+;;; Check that LABELS does not have a tagbody
+(deftest labels.27
+  (block done
+    (tagbody
+     (labels ((%f () (go 10) 10 (return-from done 'bad)))
+       (%f))
+     10
+     (return-from done 'good)))
+  good)
\ No newline at end of file
diff --git a/ansi-tests/length.lsp b/ansi-tests/length.lsp
index 79aab2dad52374b917f84fc851513fa657fb29b6..039ee052de704d7d381156b7aeade4b1a6d05e89 100644
GIT binary patch
delta 885
zcmb`F%SyvQ6ozS<)TE+<H<W@N6zzmILo2OF5nSrhrHd|1>%@+xQIb(`CAf3pb=>#@
z`T*|SxOeLdxbq=I@T5uY1zc$sKb)D9fBtXI+>KpMT|Xq~&0`Mbt(2frPpqMCBwj|T
z%L8GR(g4I|-mYj+Ijzj$=Bi?$?kN=YUMZlyDodzeN)2^8d6wBGJIoO*5D@=a<H9;-
zb#dU!&*b7D?W%KXwx_Q4)fa01w5y+%qd)=(;ZQJ5EHR<uvT$X=0b&B-Uflt1rj2k9
zKhm`KnPvOFeF9~uFqbu%CoFMt$RLYZ(uNVXR=CFnw_U4#;0bI9AWI5RfUP1F!=vKE
z(C^rGk66$;I<$`{frthJ67c4s%d8F}lrhqR)A=2vwXDjw+Bn|WvzkZ!P{UiD&?=~#
z+N?ZRMowuUeD3Z3fjKe=q1$XRJj_?^PNEp7j|5_rwn-bKJO59{<$s@x9Wblju>Jn&
z^bo8^58!7eeF*JggkHa5K+#M;H8rUW$IrF(QfN_L>(er;PxdY^wU&4E89A(_258hP
auXHNk)s!CBC7Cx?WYWkC^;pWB!M_3cfBCTh

delta 288
zcmeB^m?Au38KdsR<=Q~vvI(Q^WDZ7qAnC!lUr0A6v$#apgiAp|BPTU4y(B|-vLurd
zP|}7;7f5C?=>f@^Oa?&m6q6B<{L7RCBommMCjQ{((oM=NDK06>%uApAmst&&tH+{_
z%uPV$PGZpk8nTKNL|$hFS;Wd_1tcBV<Tt-$pUA|USX7i)sS9%vAG5^d`CJlwD56G_
k`I*Hh-{Dd~6*dM7D{_mW3Y$z`#%(dVmRlOl=%w7508js0SO5S3

diff --git a/ansi-tests/let.lsp b/ansi-tests/let.lsp
index 14196616..e661fc12 100644
--- a/ansi-tests/let.lsp
+++ b/ansi-tests/let.lsp
@@ -110,6 +110,16 @@
 	collect s)
   nil)
 
+;;; Check that LET does not have a tagbody
+(deftest let.16
+  (block done
+    (tagbody
+     (let () (go 10) 10 (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
+
 ;;; Tests for LET*
 
 (deftest let*.1
@@ -208,3 +218,12 @@
 	unless (eql (eval form) 17)
 	collect s)
   nil)
+
+;;; Check that LET* does not have a tagbody
+(deftest let*.16
+  (block done
+    (tagbody
+     (let () (go 10) 10 (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
diff --git a/ansi-tests/multiple-value-bind.lsp b/ansi-tests/multiple-value-bind.lsp
index 9c5b8551..6ffc1b8f 100644
--- a/ansi-tests/multiple-value-bind.lsp
+++ b/ansi-tests/multiple-value-bind.lsp
@@ -51,6 +51,18 @@
      x y z))
   (1 2 0) nil nil 0)
 
+;;; No implicit tagbody
+(deftest multiple-value-bind.8
+  (block nil
+    (tagbody
+     (multiple-value-bind (x) nil
+       (go 10)
+       10
+       (return 'bad))
+     10
+     (return 'good)))
+  good)
+
 ;;; (deftest multiple-value-bind.error.1
 ;;;  (classify-error (multiple-value-bind))
 ;;;  program-error)
diff --git a/ansi-tests/multiple-value-prog1.lsp b/ansi-tests/multiple-value-prog1.lsp
index d8ab80cd..8f4dfb0a 100644
--- a/ansi-tests/multiple-value-prog1.lsp
+++ b/ansi-tests/multiple-value-prog1.lsp
@@ -69,3 +69,17 @@
 	(return-from foo 'a)))
      x y))
   a 1 2)
+
+;;; No implicit tagbody
+(deftest multiple-value-prog1.10
+  (block nil
+    (tagbody
+     (multiple-value-prog1
+      (values)
+      (go 10)
+      10
+      (return 'bad))
+     10
+     (return 'good)))
+  good)
+
diff --git a/ansi-tests/prog1.lsp b/ansi-tests/prog1.lsp
index 66c84597..979b2c6c 100644
--- a/ansi-tests/prog1.lsp
+++ b/ansi-tests/prog1.lsp
@@ -25,3 +25,13 @@
   (let ((x 0))
     (values (prog1 x (incf x)) x))
   0 1)
+
+;;; Test that prog1 doesn't have a tagbody
+
+(deftest prog1.6
+  (block nil
+    (tagbody
+     (return (prog1 'bad (go 10) 10))
+     10
+     (return 'good)))
+  good)
diff --git a/ansi-tests/prog2.lsp b/ansi-tests/prog2.lsp
index 97dbed83..c3659fca 100644
--- a/ansi-tests/prog2.lsp
+++ b/ansi-tests/prog2.lsp
@@ -34,3 +34,15 @@
      (prog2 (incf x (1+ x)) (incf x (+ 2 x)) (incf x 100))
      x))
   8 108)
+
+;;; Test that prog2 doesn't have a tagbody
+
+(deftest prog2.7
+  (block nil
+    (tagbody
+     (return (prog2 17 'bad (go 10) 10))
+     10
+     (return 'good)))
+  good)
+
+
diff --git a/ansi-tests/progn.lsp b/ansi-tests/progn.lsp
index 159530c9..72965496 100644
--- a/ansi-tests/progn.lsp
+++ b/ansi-tests/progn.lsp
@@ -36,3 +36,15 @@
 	  x
 	  (return 'good)))
   good)
+
+;;; No implicit tagbody
+(deftest progn.8
+  (block nil
+    (tagbody
+     (progn
+      (go 10)
+      10
+      (return 'bad))
+     10
+     (return 'good)))
+  good)
\ No newline at end of file
diff --git a/ansi-tests/progv.lsp b/ansi-tests/progv.lsp
index 5b863f0c..74f71022 100644
--- a/ansi-tests/progv.lsp
+++ b/ansi-tests/progv.lsp
@@ -73,3 +73,13 @@
 	(progn (setf y (incf c)) nil)
       (values x y c)))
   1 2 2)
+
+;;; No tagbody
+
+(deftest progv.11
+  (block nil
+    (tagbody
+     (progv nil nil (go 10) 10 (return 'bad))
+     10
+     (return 'good)))
+  good)
diff --git a/ansi-tests/typecase.lsp b/ansi-tests/typecase.lsp
index 2c83a426..48f609cb 100644
--- a/ansi-tests/typecase.lsp
+++ b/ansi-tests/typecase.lsp
@@ -70,3 +70,29 @@
     (number 'bad)
     (#.(find-class 'symbol nil) 'good))
   good)
+
+(deftest typecase.16
+  (block done
+    (tagbody
+     (typecase 'a (symbol (go 10)
+			  10
+			  (return-from done 'bad)))
+     10
+     (return-from done 'good)))
+  good)
+
+(deftest typecase.17
+  (block done
+    (tagbody
+     (typecase 'a
+       (integer 'bad)
+       (t (go 10)
+	  10
+	  (return-from done 'bad)))
+     10
+     (return-from done 'good)))
+  good)
+
+
+
+
diff --git a/ansi-tests/unless.lsp b/ansi-tests/unless.lsp
index 11a93a68..948c2c8b 100644
--- a/ansi-tests/unless.lsp
+++ b/ansi-tests/unless.lsp
@@ -44,6 +44,18 @@
      x))
   a 1)
 
+;;; No implicit tagbody
+(deftest unless.10
+  (block done
+    (tagbody
+     (unless nil
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
 ;;; (deftest unless.error.1
 ;;;  (classify-error (unless))
 ;;;  program-error)
diff --git a/ansi-tests/unwind-protect.lsp b/ansi-tests/unwind-protect.lsp
index 03d6fd3e..8b902ea5 100644
--- a/ansi-tests/unwind-protect.lsp
+++ b/ansi-tests/unwind-protect.lsp
@@ -88,3 +88,16 @@
 	  (push 'a x)))
       (type-error () x)))
   (a))
+
+;;; No implicit tagbody
+(deftest unwind-protect.10
+  (block done
+    (tagbody
+     (unwind-protect
+	 'foo
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
diff --git a/ansi-tests/when.lsp b/ansi-tests/when.lsp
index 67840fbd..3dc179d7 100644
--- a/ansi-tests/when.lsp
+++ b/ansi-tests/when.lsp
@@ -34,6 +34,19 @@
      x))
   a 1)
 
+;;; No implicit tagbody
+(deftest when.8
+  (block done
+    (tagbody
+     (when t
+       (go 10)
+       10
+       (return-from done 'bad))
+     10
+     (return-from done 'good)))
+  good)
+
+
 ;;; (deftest when.error.1
 ;;;  (classify-error (when))
 ;;;  program-error)
-- 
GitLab