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