Signed-off-by: Jose E. Marchesi <[email protected]>
gcc/testsuite/ChangeLog
* algol68/compile/a68includes/goodbye-supper.a68
* algol68/compile/a68includes/goodbye.a68: Likewise.
* algol68/compile/a68includes/hello-supper.a68: Likewise.
* algol68/compile/a68includes/hello.a68: Likewise.
* algol68/compile/actual-bounds-expected-1.a68: Likewise.
* algol68/compile/actual-bounds-expected-2.a68: Likewise.
* algol68/compile/actual-bounds-expected-3.a68: Likewise.
* algol68/compile/balancing-1.a68: Likewise.
* algol68/compile/bold-nestable-comment-1.a68: Likewise.
* algol68/compile/bold-taggle-1.a68: Likewise.
* algol68/compile/brief-nestable-comment-1.a68: Likewise.
* algol68/compile/brief-nestable-comment-2.a68: Likewise.
* algol68/compile/char-break-1.a68: Likewise.
* algol68/compile/compile.exp: Likewise.
* algol68/compile/conditional-clause-1.a68: Likewise.
* algol68/compile/error-bold-taggle-1.a68: Likewise.
* algol68/compile/error-coercion-1.a68: Likewise.
* algol68/compile/error-coercion-2.a68: Likewise.
* algol68/compile/error-coercion-flex-1.a68: Likewise.
* algol68/compile/error-conformance-clause-1.a68: Likewise.
* algol68/compile/error-contraction-1.a68: Likewise.
* algol68/compile/error-contraction-2.a68: Likewise.
* algol68/compile/error-incestuous-union-1.a68: Likewise.
* algol68/compile/error-label-after-decl-1.a68: Likewise.
* algol68/compile/error-nestable-comments-1.a68: Likewise.
* algol68/compile/error-nested-comment-1.a68: Likewise.
* algol68/compile/error-no-bounds-allowed-1.a68: Likewise.
* algol68/compile/error-string-break-1.a68: Likewise.
* algol68/compile/error-string-break-2.a68: Likewise.
* algol68/compile/error-string-break-3.a68: Likewise.
* algol68/compile/error-string-break-4.a68: Likewise.
* algol68/compile/error-string-break-5.a68: Likewise.
* algol68/compile/error-string-break-6.a68: Likewise.
* algol68/compile/error-string-break-7.a68: Likewise.
* algol68/compile/error-supper-1.a68: Likewise.
* algol68/compile/error-supper-2.a68: Likewise.
* algol68/compile/error-supper-3.a68: Likewise.
* algol68/compile/error-supper-4.a68: Likewise.
* algol68/compile/error-supper-5.a68: Likewise.
* algol68/compile/error-supper-6.a68: Likewise.
* algol68/compile/error-underscore-in-mode-1.a68: Likewise.
* algol68/compile/error-underscore-in-tag-1.a68: Likewise.
* algol68/compile/error-upper-1.a68: Likewise.
* algol68/compile/error-widening-1.a68: Likewise.
* algol68/compile/error-widening-2.a68: Likewise.
* algol68/compile/error-widening-3.a68: Likewise.
* algol68/compile/error-widening-4.a68: Likewise.
* algol68/compile/error-widening-5.a68: Likewise.
* algol68/compile/error-widening-6.a68: Likewise.
* algol68/compile/error-widening-7.a68: Likewise.
* algol68/compile/error-widening-8.a68: Likewise.
* algol68/compile/error-widening-9.a68: Likewise.
* algol68/compile/hidden-operators-1.a68: Likewise.
* algol68/compile/implicit-widening-1.a68: Likewise.
* algol68/compile/include-supper.a68: Likewise.
* algol68/compile/include.a68: Likewise.
* algol68/compile/labeled-unit-1.a68: Likewise.
* algol68/compile/nested-comment-1.a68: Likewise.
* algol68/compile/nested-comment-2.a68: Likewise.
* algol68/compile/operators-firmly-related.a68: Likewise.
* algol68/compile/recursive-modes-1.a68: Likewise.
* algol68/compile/recursive-modes-2.a68: Likewise.
* algol68/compile/serial-clause-jump-1.a68: Likewise.
* algol68/compile/snobol.a68: Likewise.
* algol68/compile/supper-1.a68: Likewise.
* algol68/compile/supper-10.a68: Likewise.
* algol68/compile/supper-11.a68: Likewise.
* algol68/compile/supper-12.a68: Likewise.
* algol68/compile/supper-13.a68: Likewise.
* algol68/compile/supper-2.a68: Likewise.
* algol68/compile/supper-3.a68: Likewise.
* algol68/compile/supper-4.a68: Likewise.
* algol68/compile/supper-5.a68: Likewise.
* algol68/compile/supper-6.a68: Likewise.
* algol68/compile/supper-7.a68: Likewise.
* algol68/compile/supper-8.a68: Likewise.
* algol68/compile/supper-9.a68: Likewise.
* algol68/compile/uniting-1.a68: Likewise.
* algol68/compile/upper-1.a68: Likewise.
* algol68/compile/warning-scope-1.a68: Likewise.
* algol68/compile/warning-scope-2.a68: Likewise.
* algol68/compile/warning-scope-3.a68: Likewise.
* algol68/compile/warning-scope-4.a68: Likewise.
* algol68/compile/warning-scope-5.a68: Likewise.
* algol68/compile/warning-scope-6.a68: Likewise.
* algol68/compile/warning-scope-7.a68: Likewise.
* algol68/compile/warning-voiding-1.a68: Likewise.
* algol68/compile/warning-voiding-2.a68: Likewise.
---
.../compile/a68includes/goodbye-supper.a68 | 4 +
.../algol68/compile/a68includes/goodbye.a68 | 8 +
.../compile/a68includes/hello-supper.a68 | 5 +
.../algol68/compile/a68includes/hello.a68 | 8 +
.../compile/actual-bounds-expected-1.a68 | 4 +
.../compile/actual-bounds-expected-2.a68 | 4 +
.../compile/actual-bounds-expected-3.a68 | 6 +
gcc/testsuite/algol68/compile/balancing-1.a68 | 7 +
.../compile/bold-nestable-comment-1.a68 | 7 +
.../algol68/compile/bold-taggle-1.a68 | 6 +
.../compile/brief-nestable-comment-1.a68 | 4 +
.../compile/brief-nestable-comment-2.a68 | 6 +
.../algol68/compile/char-break-1.a68 | 11 +
gcc/testsuite/algol68/compile/compile.exp | 34 +
.../algol68/compile/conditional-clause-1.a68 | 9 +
.../algol68/compile/error-bold-taggle-1.a68 | 6 +
.../algol68/compile/error-coercion-1.a68 | 5 +
.../algol68/compile/error-coercion-2.a68 | 6 +
.../algol68/compile/error-coercion-flex-1.a68 | 8 +
.../compile/error-conformance-clause-1.a68 | 8 +
.../algol68/compile/error-contraction-1.a68 | 6 +
.../algol68/compile/error-contraction-2.a68 | 8 +
.../compile/error-incestuous-union-1.a68 | 8 +
.../compile/error-label-after-decl-1.a68 | 8 +
.../compile/error-mode-stropping-1.a68 | 3 +
.../compile/error-mode-stropping-10.a68 | 3 +
.../compile/error-mode-stropping-11.a68 | 4 +
.../compile/error-mode-stropping-12.a68 | 3 +
.../compile/error-mode-stropping-13.a68 | 4 +
.../compile/error-mode-stropping-14.a68 | 3 +
.../compile/error-mode-stropping-15.a68 | 4 +
.../compile/error-mode-stropping-16.a68 | 3 +
.../compile/error-mode-stropping-17.a68 | 4 +
.../compile/error-mode-stropping-2.a68 | 4 +
.../compile/error-mode-stropping-3.a68 | 3 +
.../compile/error-mode-stropping-4.a68 | 4 +
.../compile/error-mode-stropping-5.a68 | 3 +
.../compile/error-mode-stropping-6.a68 | 4 +
.../compile/error-mode-stropping-8.a68 | 3 +
.../compile/error-mode-stropping-9.a68 | 4 +
.../compile/error-nestable-comments-1.a68 | 9 +
.../compile/error-nested-comment-1.a68 | 6 +
.../compile/error-no-bounds-allowed-1.a68 | 15 +
.../algol68/compile/error-string-break-1.a68 | 4 +
.../algol68/compile/error-string-break-2.a68 | 2 +
.../algol68/compile/error-string-break-3.a68 | 2 +
.../algol68/compile/error-string-break-4.a68 | 2 +
.../algol68/compile/error-string-break-5.a68 | 2 +
.../algol68/compile/error-string-break-6.a68 | 2 +
.../algol68/compile/error-string-break-7.a68 | 2 +
.../algol68/compile/error-stropping-5.a68 | 3 +
.../algol68/compile/error-stropping-6.a68 | 4 +
.../compile/error-stropping-keyword-1.a68 | 2 +
.../compile/error-stropping-keyword-2.a68 | 3 +
.../compile/error-stropping-keyword-3.a68 | 2 +
.../compile/error-stropping-keyword-4.a68 | 3 +
.../algol68/compile/error-supper-1.a68 | 3 +
.../algol68/compile/error-supper-2.a68 | 5 +
.../algol68/compile/error-supper-3.a68 | 5 +
.../algol68/compile/error-supper-4.a68 | 5 +
.../algol68/compile/error-supper-5.a68 | 5 +
.../algol68/compile/error-supper-6.a68 | 6 +
.../compile/error-underscore-in-mode-1.a68 | 7 +
.../compile/error-underscore-in-tag-1.a68 | 7 +
.../algol68/compile/error-upper-1.a68 | 3 +
.../algol68/compile/error-vacuum-1.a68 | 2 +
.../algol68/compile/error-vacuum-2.a68 | 2 +
.../algol68/compile/error-vacuum-3.a68 | 3 +
.../algol68/compile/error-widening-1.a68 | 6 +
.../algol68/compile/error-widening-2.a68 | 6 +
.../algol68/compile/error-widening-3.a68 | 10 +
.../algol68/compile/error-widening-4.a68 | 10 +
.../algol68/compile/error-widening-5.a68 | 6 +
.../algol68/compile/error-widening-6.a68 | 6 +
.../algol68/compile/error-widening-7.a68 | 6 +
.../algol68/compile/error-widening-8.a68 | 6 +
.../algol68/compile/error-widening-9.a68 | 10 +
.../algol68/compile/hidden-operators-1.a68 | 11 +
.../algol68/compile/implicit-widening-1.a68 | 10 +
.../algol68/compile/include-supper.a68 | 16 +
gcc/testsuite/algol68/compile/include.a68 | 19 +
.../algol68/compile/labeled-unit-1.a68 | 7 +
.../algol68/compile/nested-comment-1.a68 | 4 +
.../algol68/compile/nested-comment-2.a68 | 6 +
.../compile/operators-firmly-related.a68 | 7 +
.../algol68/compile/recursive-modes-1.a68 | 33 +
.../algol68/compile/recursive-modes-2.a68 | 7 +
.../algol68/compile/serial-clause-jump-1.a68 | 7 +
gcc/testsuite/algol68/compile/snobol.a68 | 1100 +++++++++++++++++
gcc/testsuite/algol68/compile/supper-1.a68 | 11 +
gcc/testsuite/algol68/compile/supper-10.a68 | 6 +
gcc/testsuite/algol68/compile/supper-11.a68 | 6 +
gcc/testsuite/algol68/compile/supper-12.a68 | 6 +
gcc/testsuite/algol68/compile/supper-13.a68 | 7 +
gcc/testsuite/algol68/compile/supper-2.a68 | 5 +
gcc/testsuite/algol68/compile/supper-3.a68 | 5 +
gcc/testsuite/algol68/compile/supper-4.a68 | 5 +
gcc/testsuite/algol68/compile/supper-5.a68 | 6 +
gcc/testsuite/algol68/compile/supper-6.a68 | 5 +
gcc/testsuite/algol68/compile/supper-7.a68 | 5 +
gcc/testsuite/algol68/compile/supper-8.a68 | 6 +
gcc/testsuite/algol68/compile/supper-9.a68 | 6 +
gcc/testsuite/algol68/compile/uniting-1.a68 | 8 +
gcc/testsuite/algol68/compile/upper-1.a68 | 11 +
.../algol68/compile/warning-scope-1.a68 | 9 +
.../algol68/compile/warning-scope-2.a68 | 8 +
.../algol68/compile/warning-scope-3.a68 | 3 +
.../algol68/compile/warning-scope-4.a68 | 3 +
.../algol68/compile/warning-scope-5.a68 | 8 +
.../algol68/compile/warning-scope-6.a68 | 6 +
.../algol68/compile/warning-scope-7.a68 | 12 +
.../algol68/compile/warning-voiding-1.a68 | 5 +
.../algol68/compile/warning-voiding-2.a68 | 6 +
113 files changed, 1809 insertions(+)
create mode 100644 gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
create mode 100644 gcc/testsuite/algol68/compile/a68includes/goodbye.a68
create mode 100644 gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
create mode 100644 gcc/testsuite/algol68/compile/a68includes/hello.a68
create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
create mode 100644 gcc/testsuite/algol68/compile/balancing-1.a68
create mode 100644 gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
create mode 100644 gcc/testsuite/algol68/compile/bold-taggle-1.a68
create mode 100644 gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
create mode 100644 gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
create mode 100644 gcc/testsuite/algol68/compile/char-break-1.a68
create mode 100644 gcc/testsuite/algol68/compile/compile.exp
create mode 100644 gcc/testsuite/algol68/compile/conditional-clause-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-coercion-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-coercion-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-contraction-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-contraction-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-10.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-11.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-12.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-13.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-14.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-15.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-16.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-17.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-3.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-4.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-5.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-6.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-8.a68
create mode 100644 gcc/testsuite/algol68/compile/error-mode-stropping-9.a68
create mode 100644 gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-nested-comment-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-3.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-4.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-5.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-6.a68
create mode 100644 gcc/testsuite/algol68/compile/error-string-break-7.a68
create mode 100644 gcc/testsuite/algol68/compile/error-stropping-5.a68
create mode 100644 gcc/testsuite/algol68/compile/error-stropping-6.a68
create mode 100644 gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68
create mode 100644 gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68
create mode 100644 gcc/testsuite/algol68/compile/error-supper-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-supper-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-supper-3.a68
create mode 100644 gcc/testsuite/algol68/compile/error-supper-4.a68
create mode 100644 gcc/testsuite/algol68/compile/error-supper-5.a68
create mode 100644 gcc/testsuite/algol68/compile/error-supper-6.a68
create mode 100644 gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-upper-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-vacuum-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-vacuum-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-vacuum-3.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-1.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-2.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-3.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-4.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-5.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-6.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-7.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-8.a68
create mode 100644 gcc/testsuite/algol68/compile/error-widening-9.a68
create mode 100644 gcc/testsuite/algol68/compile/hidden-operators-1.a68
create mode 100644 gcc/testsuite/algol68/compile/implicit-widening-1.a68
create mode 100644 gcc/testsuite/algol68/compile/include-supper.a68
create mode 100644 gcc/testsuite/algol68/compile/include.a68
create mode 100644 gcc/testsuite/algol68/compile/labeled-unit-1.a68
create mode 100644 gcc/testsuite/algol68/compile/nested-comment-1.a68
create mode 100644 gcc/testsuite/algol68/compile/nested-comment-2.a68
create mode 100644 gcc/testsuite/algol68/compile/operators-firmly-related.a68
create mode 100644 gcc/testsuite/algol68/compile/recursive-modes-1.a68
create mode 100644 gcc/testsuite/algol68/compile/recursive-modes-2.a68
create mode 100644 gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
create mode 100644 gcc/testsuite/algol68/compile/snobol.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-1.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-10.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-11.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-12.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-13.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-2.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-3.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-4.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-5.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-6.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-7.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-8.a68
create mode 100644 gcc/testsuite/algol68/compile/supper-9.a68
create mode 100644 gcc/testsuite/algol68/compile/uniting-1.a68
create mode 100644 gcc/testsuite/algol68/compile/upper-1.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-1.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-2.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-3.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-4.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-5.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-6.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-scope-7.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-voiding-1.a68
create mode 100644 gcc/testsuite/algol68/compile/warning-voiding-2.a68
diff --git a/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
b/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
new file mode 100644
index 00000000000..c287d6a9309
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
@@ -0,0 +1,4 @@
+proc goodbye = (string name) string:
+begin string msg := "Goodbye " + name;
+ msg
+end;
diff --git a/gcc/testsuite/algol68/compile/a68includes/goodbye.a68
b/gcc/testsuite/algol68/compile/a68includes/goodbye.a68
new file mode 100644
index 00000000000..19c3acc5779
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/goodbye.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" } #
+# PR UPPER PR #
+
+PROC goodbye = (STRING name) STRING:
+BEGIN
+ STRING msg := "Goodbye " + name;
+ msg
+END;
diff --git a/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
b/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
new file mode 100644
index 00000000000..2af568bcb01
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
@@ -0,0 +1,5 @@
+proc hello = (string name) string:
+begin string msg := "Hello " + name;
+ msg
+end;
+
diff --git a/gcc/testsuite/algol68/compile/a68includes/hello.a68
b/gcc/testsuite/algol68/compile/a68includes/hello.a68
new file mode 100644
index 00000000000..aa72e282d2c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/hello.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" } #
+# PR UPPER PR #
+
+PROC hello = (STRING name) STRING:
+BEGIN
+ STRING msg := "Hello " + name;
+ msg
+END;
diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
b/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
new file mode 100644
index 00000000000..58309db74fd
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN []INT a := (1,2,3); # { dg-error "actual bounds expected" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
b/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
new file mode 100644
index 00000000000..e80e8cb45c0
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN LOC[]INT a := (1,2,3); # { dg-error "actual bounds expected" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
b/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
new file mode 100644
index 00000000000..26ddd279f05
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN LOC[]INT a := (1,2,3), # { dg-error "actual bounds expected" } #
+ b := (4);
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/balancing-1.a68
b/gcc/testsuite/algol68/compile/balancing-1.a68
new file mode 100644
index 00000000000..62d1221f675
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/balancing-1.a68
@@ -0,0 +1,7 @@
+mode Word = union (void,real),
+ Rules = union (void,string);
+
+op LEN = (Word w) int: skip,
+LEN = (Rules r) int: skip;
+
+skip
diff --git a/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
b/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
new file mode 100644
index 00000000000..0820c3d20c2
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
@@ -0,0 +1,7 @@
+# { dg-options {-fstropping=upper} } #
+# pr UPPER pr #
+BEGIN NOTE This is a
+ NOTE nestable ETON comment in bold style.
+ ETON
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/bold-taggle-1.a68
b/gcc/testsuite/algol68/compile/bold-taggle-1.a68
new file mode 100644
index 00000000000..77ce9e7c2fa
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/bold-taggle-1.a68
@@ -0,0 +1,6 @@
+# { dg-options {-std=gnu68 -fstropping=upper} } #
+
+BEGIN MODE FOO_BAR = INT;
+ FOO_BAR foo_bar = 10;
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
b/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
new file mode 100644
index 00000000000..045b9b56d57
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
@@ -0,0 +1,4 @@
+begin { This is a
+ { nestable } comment in brief style. }
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
b/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
new file mode 100644
index 00000000000..a4e5d3ebb87
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN NOTE This is a
+ { nestable } comment in brief style.
+ ETON
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/char-break-1.a68
b/gcc/testsuite/algol68/compile/char-break-1.a68
new file mode 100644
index 00000000000..8a43364919f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/char-break-1.a68
@@ -0,0 +1,11 @@
+{ Make sure char denotations with string breaks work. }
+begin prio % = 9;
+ op % = (char a) char: a;
+ assert (ABS %"'n" = 10);
+ assert (ABS %"'f" = 12);
+ assert (ABS %"'t" = 9);
+ assert (ABS %"'r" = 13);
+ assert (%"'( u0061)" = "a");
+ assert (%"'(U00000061 )" = "a");
+ assert (%"'(u1234)" = invalid_char)
+end
diff --git a/gcc/testsuite/algol68/compile/compile.exp
b/gcc/testsuite/algol68/compile/compile.exp
new file mode 100644
index 00000000000..68fa5fa2625
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/compile.exp
@@ -0,0 +1,34 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# Compile tests, no torture testing.
+#
+# These tests raise errors in the front end; torture testing doesn't apply.
+
+load_lib algol68-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+set saved-dg-do-what-default ${dg-do-what-default}
+
+set dg-do-what-default "compile"
+algol68-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] "" ""
+set dg-do-what-default ${saved-dg-do-what-default}
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/algol68/compile/conditional-clause-1.a68
b/gcc/testsuite/algol68/compile/conditional-clause-1.a68
new file mode 100644
index 00000000000..a727bc21e58
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/conditional-clause-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT i := 26;
+ IF INT ii = i * 2; ii > 50 THEN
+ ii
+ ELIF i = 10 THEN
+ 100
+ FI
+END
diff --git a/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
b/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
new file mode 100644
index 00000000000..d813e55e5ba
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
@@ -0,0 +1,6 @@
+# { dg-options {-std=algol68 -fstropping=upper} } #
+
+BEGIN MODE FOO_BAR = INT; # { dg-error "unworthy" } #
+ FOO_BAR foo_bar = 10;
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-coercion-1.a68
b/gcc/testsuite/algol68/compile/error-coercion-1.a68
new file mode 100644
index 00000000000..d0e24821f27
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-coercion-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT a;
+ a := "foo" # { dg-error "cannot be coerced" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-coercion-2.a68
b/gcc/testsuite/algol68/compile/error-coercion-2.a68
new file mode 100644
index 00000000000..bb8de3064b5
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-coercion-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+# This is Example 4.2.6c in McGETTRICK[78]. #
+BEGIN []STRUCT([]INT a) r = (1,2,3); # { dg-error "cannot be coerced" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
b/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
new file mode 100644
index 00000000000..c556d703b40
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" } #
+
+# Coercing from REF FLEX[]REAL to REF[]REAL is not allowed, since
+ flexibility shall match #
+BEGIN FLEX[1:0] REAL rowvar := SKIP;
+ REF [] REAL xlm = rowvar; # { dg-error "FLEX.*cannot be coerced" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
b/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
new file mode 100644
index 00000000000..e6cb738a2c9
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
@@ -0,0 +1,8 @@
+{ This is an invalid program. }
+begin case
+ if true then "foo" else 10 fi { dg-error "not a united mode" }
+ in (string): skip,
+ (int): skip
+ esac
+end
+
diff --git a/gcc/testsuite/algol68/compile/error-contraction-1.a68
b/gcc/testsuite/algol68/compile/error-contraction-1.a68
new file mode 100644
index 00000000000..f2bce73ff17
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-contraction-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+# Contracting mixed collateral variable and constant declarations is
+ not allowed.
+#
+(INT foo = 100, bar := 200) # { dg-error "mixed" } #
diff --git a/gcc/testsuite/algol68/compile/error-contraction-2.a68
b/gcc/testsuite/algol68/compile/error-contraction-2.a68
new file mode 100644
index 00000000000..2115a4cbfab
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-contraction-2.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" } #
+
+# Contracting mixed collateral variable and constant declarations is
+ not allowed. #
+BEGIN PROC x = VOID: SKIP,
+ y := VOID: SKIP; # { dg-error "mixed" } #
+ x
+END
diff --git a/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
b/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
new file mode 100644
index 00000000000..519cb8a9af1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" } #
+
+# Union modes shall not contain modes which are firmly related, i.e.
+ it shall not be possible to coerce from one mode to another in a
+ firm context. #
+BEGIN UNION(INT, REF INT) incestuous; # { dg-error "has firmly related
components" } #
+ incestuous
+END
diff --git a/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
b/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
new file mode 100644
index 00000000000..670f8908af1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN GOTO end;
+ ASSERT(FALSE);
+end: 0;
+ INT i = 10; # { dg-error "declaration cannot follow" } #
+ i
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-1.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-1.a68
new file mode 100644
index 00000000000..7a619d8408f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-1.a68
@@ -0,0 +1,3 @@
+begin struct (int i, real r) j;
+ j := "joo" { dg-error "char.*struct \\(int i, real r\\)" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-10.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-10.a68
new file mode 100644
index 00000000000..fd70de7df0d
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-10.a68
@@ -0,0 +1,3 @@
+begin long long int j;
+ j := "joo" { dg-error "char.*long long int" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-11.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-11.a68
new file mode 100644
index 00000000000..156d8d39aa6
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-11.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN LONG LONG INT j;
+ j := "joo" { dg-error "CHAR.*LONG LONG INT" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-12.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-12.a68
new file mode 100644
index 00000000000..0dda5beb414
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-12.a68
@@ -0,0 +1,3 @@
+begin short int j;
+ j := "joo" { dg-error "char.*short int" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-13.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-13.a68
new file mode 100644
index 00000000000..84cf830e7ec
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-13.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN SHORT INT j;
+ j := "joo" { dg-error "CHAR.*SHORT INT" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-14.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-14.a68
new file mode 100644
index 00000000000..24bda0a6db9
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-14.a68
@@ -0,0 +1,3 @@
+begin short short int j;
+ j := "joo" { dg-error "char.*short short int" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-15.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-15.a68
new file mode 100644
index 00000000000..0136fdb4f7b
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-15.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN SHORT SHORT INT j;
+ j := "joo" { dg-error "CHAR.*SHORT SHORT INT" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-16.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-16.a68
new file mode 100644
index 00000000000..82359e52d95
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-16.a68
@@ -0,0 +1,3 @@
+begin flex[1:0]int j;
+ j := "joo" { dg-error "char.*flex.*int" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-17.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-17.a68
new file mode 100644
index 00000000000..e733c51c75f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-17.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN FLEX[1:0]INT j;
+ j := "joo" { dg-error "CHAR.*FLEX.*INT" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-2.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-2.a68
new file mode 100644
index 00000000000..f72b6dd1368
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-2.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN STRUCT (INT i, REAL r) j;
+ j := "joo" # { dg-error "CHAR.*STRUCT \\(INT i, REAL r\\)" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-3.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-3.a68
new file mode 100644
index 00000000000..eb672c49533
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-3.a68
@@ -0,0 +1,3 @@
+begin union (int,real) j;
+ j := "joo" { dg-error "char.*union \\( *real *, *int *\\)" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-4.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-4.a68
new file mode 100644
index 00000000000..42c6ee29b6d
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-4.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN UNION (INT,REAL) j;
+ j := "joo" { dg-error "CHAR.*UNION \\( *REAL *, *INT *\\)" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-5.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-5.a68
new file mode 100644
index 00000000000..0206d19f72f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-5.a68
@@ -0,0 +1,3 @@
+begin proc union (int,real) j;
+ j := "joo" { dg-error "char.*proc union \\( *real *, *int *\\)" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-6.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-6.a68
new file mode 100644
index 00000000000..5f8404363dd
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-6.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN PROC UNION (INT,REAL) j;
+ j := "joo" { dg-error "CHAR.*PROC UNION \\( *REAL *, *INT *\\)" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-8.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-8.a68
new file mode 100644
index 00000000000..49308860381
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-8.a68
@@ -0,0 +1,3 @@
+begin long int j;
+ j := "joo" { dg-error "char.*long int" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-mode-stropping-9.a68
b/gcc/testsuite/algol68/compile/error-mode-stropping-9.a68
new file mode 100644
index 00000000000..dc20eb34a34
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-mode-stropping-9.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN LONG INT j;
+ j := "joo" { dg-error "CHAR.*LONG INT" }
+END
diff --git a/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
b/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
new file mode 100644
index 00000000000..df00a1a9970
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" } #
+# pr UPPER pr #
+BEGIN NOTE This is a
+ NOTE nestable ETON comment in brief style.
+ ETON
+ { Another { comment }. }
+ NOTE invalid { nesting ETON of comments } # { dg-error "" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-nested-comment-1.a68
b/gcc/testsuite/algol68/compile/error-nested-comment-1.a68
new file mode 100644
index 00000000000..3c78f34a51a
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-nested-comment-1.a68
@@ -0,0 +1,6 @@
+{ The string in nested comment is in one logical line. }
+begin
+ { puts ("{'n { dg-error {} }
+"); { this prints foo }}
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
b/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
new file mode 100644
index 00000000000..75d66bc1715
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN [1:10]INT i,
+ [1:10]STRUCT(REF[]INT i, BOOL j) k,
+ [1:10]STRUCT([1:10]INT i, BOOL j) l,
+ [1:10]REF[]INT p;
+ # formal, so no bounds allowed: #
+ [1:10]PROC[1:10]INT q, # { dg-error "formal bounds expected" } #
+ STRUCT(REF[1:10]INT i, BOOLj) m, # { dg-error "virtual bounds expected"
} #
+ [1:10]REF[1:10]INT mn, # { dg-error "virtual bounds expected" } #
+ PROC([1:10]INT)VOID pp, # { dg-error "formal bounds expected" } #
+ UNION([1:10] INT, BOOL) nm, # { dg-error "formal bounds expected" } #
+ [1:10]INT u = (1); # { dg-error "formal bounds expected" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-string-break-1.a68
b/gcc/testsuite/algol68/compile/error-string-break-1.a68
new file mode 100644
index 00000000000..fd8e765ab48
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN puts ("hello '_ world") # { dg-error "invalid string break sequence" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-string-break-2.a68
b/gcc/testsuite/algol68/compile/error-string-break-2.a68
new file mode 100644
index 00000000000..465f8f80404
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-2.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(U0000) world") # { dg-error "eight" } #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-3.a68
b/gcc/testsuite/algol68/compile/error-string-break-3.a68
new file mode 100644
index 00000000000..e4cf8f6f1a3
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-3.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u00) world") # { dg-error "four" } #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-4.a68
b/gcc/testsuite/algol68/compile/error-string-break-4.a68
new file mode 100644
index 00000000000..76adff9b2bc
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-4.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u) world") # { dg-error "four" } #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-5.a68
b/gcc/testsuite/algol68/compile/error-string-break-5.a68
new file mode 100644
index 00000000000..c42589fde7c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-5.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u0010u0020) world") # { dg-error "" } #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-6.a68
b/gcc/testsuite/algol68/compile/error-string-break-6.a68
new file mode 100644
index 00000000000..fed7d84b221
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-6.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u0010'/) world") # { dg-error "" } #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-7.a68
b/gcc/testsuite/algol68/compile/error-string-break-7.a68
new file mode 100644
index 00000000000..58545e01ce1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-7.a68
@@ -0,0 +1,2 @@
+begin puts ("'") # { dg-error "" } #
+end
diff --git a/gcc/testsuite/algol68/compile/error-stropping-5.a68
b/gcc/testsuite/algol68/compile/error-stropping-5.a68
new file mode 100644
index 00000000000..3190472129a
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-stropping-5.a68
@@ -0,0 +1,3 @@
+begin int j;
+ j := "joo" { dg-error "char.*int" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-stropping-6.a68
b/gcc/testsuite/algol68/compile/error-stropping-6.a68
new file mode 100644
index 00000000000..af6097df7c0
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-stropping-6.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN INT j;
+ j := "joo" # { dg-error "CHAR.*INT" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68
b/gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68
new file mode 100644
index 00000000000..4bf549f91e3
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-1.a68
@@ -0,0 +1,2 @@
+begin for i to 10 skip od { dg-error "do" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68
b/gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68
new file mode 100644
index 00000000000..a1e616deaeb
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-2.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN FOR i TO 10 SKIP OD # { dg-error "DO" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68
b/gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68
new file mode 100644
index 00000000000..d1076e935bd
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-3.a68
@@ -0,0 +1,2 @@
+begin if then 10 else 20 fi { dg-error "if" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68
b/gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68
new file mode 100644
index 00000000000..92b0b3b58cb
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-stropping-keyword-4.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" } #
+BEGIN IF THEN 10 ELSE 20 FI # { dg-error "IF" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-supper-1.a68
b/gcc/testsuite/algol68/compile/error-supper-1.a68
new file mode 100644
index 00000000000..f2646c41b7b
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-1.a68
@@ -0,0 +1,3 @@
+# { dg-options {-fstropping=upper} } #
+
+begin ~ end # { dg-error "" } #
diff --git a/gcc/testsuite/algol68/compile/error-supper-2.a68
b/gcc/testsuite/algol68/compile/error-supper-2.a68
new file mode 100644
index 00000000000..f8c6c284b20
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-2.a68
@@ -0,0 +1,5 @@
+# { dg-options {-fstropping=supper} } #
+
+begin int foo__bar = 10; # { dg-error "unworthy" } #
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-3.a68
b/gcc/testsuite/algol68/compile/error-supper-3.a68
new file mode 100644
index 00000000000..a35730ce1f7
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-3.a68
@@ -0,0 +1,5 @@
+# { dg-options {-fstropping=supper} } #
+
+begin int _bar = 10; # { dg-error "unworthy" } #
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-4.a68
b/gcc/testsuite/algol68/compile/error-supper-4.a68
new file mode 100644
index 00000000000..726f80638d6
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-4.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo bar = 10; { dg-error "" }
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-5.a68
b/gcc/testsuite/algol68/compile/error-supper-5.a68
new file mode 100644
index 00000000000..0cf51c519de
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-5.a68
@@ -0,0 +1,5 @@
+# { dg-options {-fstropping=supper} } #
+
+begin int foo__ = 10; # { dg-error "unworthy" } #
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-6.a68
b/gcc/testsuite/algol68/compile/error-supper-6.a68
new file mode 100644
index 00000000000..c013b4894b3
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-6.a68
@@ -0,0 +1,6 @@
+# { dg-options {-fstropping=supper} } #
+
+begin mode foo_Invalid = int; # { dg-error "Invalid" } #
+ foo_Invalid some_int = 10; # { dg-error "Invalid" } #
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
b/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
new file mode 100644
index 00000000000..2aa294d1f02
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" } #
+
+# Underscores are unworthy characters if they are not trailing
+ either a taggle or, in UPPER stropping, a bold word. #
+BEGIN INT invalid_tag__; # { dg-error "unworthy character" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
b/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
new file mode 100644
index 00000000000..a5dcb86b6e1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" } #
+
+# Underscores are unworthy characters if they are not trailing a
+ taggle or, in UPPER stropping, a bold word.. #
+BEGIN MODE INVALID_BOLD_WORD__; # { dg-error "unworthy character" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-upper-1.a68
b/gcc/testsuite/algol68/compile/error-upper-1.a68
new file mode 100644
index 00000000000..053846972ac
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-upper-1.a68
@@ -0,0 +1,3 @@
+# { dg-options {-fstropping=supper} } #
+
+BEGIN ~ END # { dg-error "" } #
diff --git a/gcc/testsuite/algol68/compile/error-vacuum-1.a68
b/gcc/testsuite/algol68/compile/error-vacuum-1.a68
new file mode 100644
index 00000000000..0e724592e25
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-vacuum-1.a68
@@ -0,0 +1,2 @@
+begin { dg-error "" }
+end
diff --git a/gcc/testsuite/algol68/compile/error-vacuum-2.a68
b/gcc/testsuite/algol68/compile/error-vacuum-2.a68
new file mode 100644
index 00000000000..fe9716aeef4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-vacuum-2.a68
@@ -0,0 +1,2 @@
+( { dg-error "" }
+)
diff --git a/gcc/testsuite/algol68/compile/error-vacuum-3.a68
b/gcc/testsuite/algol68/compile/error-vacuum-3.a68
new file mode 100644
index 00000000000..fc096002709
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-vacuum-3.a68
@@ -0,0 +1,3 @@
+begin struct(int i, real r) foo = (); { dg-error "" }
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-widening-1.a68
b/gcc/testsuite/algol68/compile/error-widening-1.a68
new file mode 100644
index 00000000000..38ea59afb28
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT a := 10;
+ LONG REAL l := a; # { dg-error "coerced" } #
+ l
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-2.a68
b/gcc/testsuite/algol68/compile/error-widening-2.a68
new file mode 100644
index 00000000000..3165d1b7113
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT a := 10;
+ LONG INT l := a; # { dg-error "coerced" } #
+ l
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-3.a68
b/gcc/testsuite/algol68/compile/error-widening-3.a68
new file mode 100644
index 00000000000..c4ffb305a62
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-3.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT d := 0;
+ INT y := 10;
+ LONG REAL x;
+ 2
+ + (d > 0 | x | # { dg-error "" } #
+ y
+ )
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-4.a68
b/gcc/testsuite/algol68/compile/error-widening-4.a68
new file mode 100644
index 00000000000..fa5b2072e17
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-4.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ INT d := 0;
+ LONG REAL x;
+ 2
+ + (d > 0 | x | # { dg-error "" } #
+ 10
+ )
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-5.a68
b/gcc/testsuite/algol68/compile/error-widening-5.a68
new file mode 100644
index 00000000000..a6198669c45
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-5.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG INT d := 0; # { dg-error "coerced" } #
+ d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-6.a68
b/gcc/testsuite/algol68/compile/error-widening-6.a68
new file mode 100644
index 00000000000..09512e21678
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-6.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG LONG INT d := LONG 0; # { dg-error "coerced" } #
+ d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-7.a68
b/gcc/testsuite/algol68/compile/error-widening-7.a68
new file mode 100644
index 00000000000..09352081583
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-7.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG REAL d := 3.14; # { dg-error "coerced" } #
+ d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-8.a68
b/gcc/testsuite/algol68/compile/error-widening-8.a68
new file mode 100644
index 00000000000..098f6c3b615
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-8.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG LONG REAL d := LONG 3.14; # { dg-error "coerced" } #
+ d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-9.a68
b/gcc/testsuite/algol68/compile/error-widening-9.a68
new file mode 100644
index 00000000000..4d092386b61
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-9.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ INT d := 0;
+ LONG LONG REAL x;
+ 2
+ + (d > 0 | x | # { dg-error "" } #
+ 10
+ )
+END
diff --git a/gcc/testsuite/algol68/compile/hidden-operators-1.a68
b/gcc/testsuite/algol68/compile/hidden-operators-1.a68
new file mode 100644
index 00000000000..d66242d67a6
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/hidden-operators-1.a68
@@ -0,0 +1,11 @@
+{ dg-options {-Whidden-declarations} }
+
+begin mode Trilean = union (void,bool);
+
+ Trilean unknown = empty;
+ op NOT = (Trilean a) Trilean: { dg-warning "hides" }
+ skip;
+ op AND = (Trilean a,b) Trilean: { dg-warning "hides" }
+ skip;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/implicit-widening-1.a68
b/gcc/testsuite/algol68/compile/implicit-widening-1.a68
new file mode 100644
index 00000000000..2fa010c12a7
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/implicit-widening-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-Wextensions -fstropping=upper" } #
+
+# This program shall compile without warning, because
+ widening from INT to REAL is legal in the strict language,
+ since they have the same size. #
+
+BEGIN BOOL cond;
+ REAL x, y;
+ y + (cond | x | 10)
+END
diff --git a/gcc/testsuite/algol68/compile/include-supper.a68
b/gcc/testsuite/algol68/compile/include-supper.a68
new file mode 100644
index 00000000000..af0521be101
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/include-supper.a68
@@ -0,0 +1,16 @@
+{ dg-options "-I$srcdir/algol68/compile/a68includes" }
+{ dg-additional-files "$srcdir/algol68/compile/a68includes/hello-supper.a68
$srcdir/algol68/compile/a68includes/goodbye-supper.a68" }
+
+begin string name := "Algol68 with supper!";
+ { Both files are in `./a68includes'.
+ The first one will be included because we uwed `-I.
+ The second one will be included because of the relative path. }
+ pr include "hello-supper.a68" pr
+ pr include "a68includes/goodbye-supper.a68" pr
+
+ string bye := goodbye(name);
+ string hi := hello(name);
+
+ puts(hi + "\n");
+ puts(bye + "\n")
+end
diff --git a/gcc/testsuite/algol68/compile/include.a68
b/gcc/testsuite/algol68/compile/include.a68
new file mode 100644
index 00000000000..6f4855b33da
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/include.a68
@@ -0,0 +1,19 @@
+# { dg-options "-I$srcdir/algol68/compile/a68includes -fstropping=upper" } #
+# { dg-additional-files "$srcdir/algol68/compile/a68includes/hello.a68
$srcdir/algol68/compile/a68includes/goodbye.a68" } #
+
+# PR UPPER PR #
+
+BEGIN STRING name := "Algol68!";
+ # Both files are in `./a68includes'.
+ The first one will be included because we used `-I'.
+ The second one will be included because of the relative path.
+ #
+ PR include "hello.a68" PR
+ PR include "a68includes/goodbye.a68" PR
+
+ STRING bye := goodbye(name);
+ STRING hi := hello(name);
+
+ puts(hi + "\n");
+ puts(bye + "\n")
+END
diff --git a/gcc/testsuite/algol68/compile/labeled-unit-1.a68
b/gcc/testsuite/algol68/compile/labeled-unit-1.a68
new file mode 100644
index 00000000000..d3dbd8c40d7
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/labeled-unit-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" } #
+
+# This tests that the mode of the value yielded by a labeled unit is
+ the mode of the unit. #
+BEGIN 10;
+jorl: 20
+END
diff --git a/gcc/testsuite/algol68/compile/nested-comment-1.a68
b/gcc/testsuite/algol68/compile/nested-comment-1.a68
new file mode 100644
index 00000000000..f5752435a0e
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/nested-comment-1.a68
@@ -0,0 +1,4 @@
+{ Comment delimiters within strings get ignored. }
+begin { puts { ("{""'n"); } }
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/nested-comment-2.a68
b/gcc/testsuite/algol68/compile/nested-comment-2.a68
new file mode 100644
index 00000000000..9fc912f2687
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/nested-comment-2.a68
@@ -0,0 +1,6 @@
+{ The string in nested comment is in one logical line. }
+begin
+ { puts ("{'n\
+"); { this prints foo }}
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/operators-firmly-related.a68
b/gcc/testsuite/algol68/compile/operators-firmly-related.a68
new file mode 100644
index 00000000000..a7efe750219
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/operators-firmly-related.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN PRIO MIN = 6;
+ OP MIN = (REF REAL a, b) REF REAL: (a < b | a | b), # { dg-error "firmly
related" } #
+ MIN = (REAL a, b) REAL: (a < b | a | b); # { dg-error "firmly
related" } #
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/recursive-modes-1.a68
b/gcc/testsuite/algol68/compile/recursive-modes-1.a68
new file mode 100644
index 00000000000..4a77a5646be
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/recursive-modes-1.a68
@@ -0,0 +1,33 @@
+# { dg-options "-fstropping=upper" } #
+
+# This program triggered a bug related to incomplete modes. #
+BEGIN MODE REC_MSET = STRUCT (REF REC_MSET_ELM head, tail,
+ INT num elems,
+ PROC(REC_MSET_DATA)BOOL gate),
+ REC_MSET_ELM = STRUCT (REC_MSET_DATA data, BOOL mark, REF
REC_MSET_ELM next),
+ REC_MSET_DATA = UNION (REC_RSET,REC_RECORD,REC_FIELD,REC_CMNT),
+ REC_RSET = STRUCT (REC_MSET mset,
+ INT min size, max size,
+ REF REC_RECORD descriptor),
+ REC_RECORD = STRUCT (REC_LOC loc, REC_MSET mset, INT foo),
+ REC_CMNT = STRUCT (REC_LOC loc, STRING content),
+ REC_FIELD = STRUCT (REC_LOC loc, STRING name, value),
+ REC_LOC = STRUCT (STRING source, INT line, char);
+
+ PROC rec loc unknown = REC_LOC:
+ ("unknown", 0, 0);
+ PROC rec record gate = (REC_MSET_DATA d) BOOL:
+ (d | (REC_FIELD): TRUE, (REC_CMNT): TRUE | FALSE);
+ REF REC_MSET_ELM rec no mset elm = NIL;
+
+ PROC rec mset new = (PROC(REC_MSET_DATA)BOOL gate) REC_MSET:
+ (HEAP REC_MSET := (rec no mset elm, rec no mset elm,
+ 0, gate));
+
+ REF REC_RECORD rec no record = NIL;
+
+ PROC rec record new = REF REC_RECORD:
+ HEAP REC_RECORD := (rec loc unknown, rec mset new (rec record gate),
0);
+
+ SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/recursive-modes-2.a68
b/gcc/testsuite/algol68/compile/recursive-modes-2.a68
new file mode 100644
index 00000000000..f79b214d075
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/recursive-modes-2.a68
@@ -0,0 +1,7 @@
+begin mode Word = union (int, struct (ref Word w)),
+ Value = union (void,Word),
+ Stack = struct (ref Stack prev, Value val);
+
+ struct (Word a) qs; { type_2 has no size! }
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
b/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
new file mode 100644
index 00000000000..f4e3773ba53
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" } #
+
+# This is an infinite loop, but it should compile just fine an yield
+ an integer after infinite time. #
+
+BEGIN foo: foo
+END
diff --git a/gcc/testsuite/algol68/compile/snobol.a68
b/gcc/testsuite/algol68/compile/snobol.a68
new file mode 100644
index 00000000000..9b6c4fc824f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/snobol.a68
@@ -0,0 +1,1100 @@
+# { dg-options "-fstropping=upper" } #
+
+# This is Frank Pagan's SNOBOL4 Interpreter in ALGOL 68 (1976),
+ fetched from Dick Grune's page https://dickgrune.com/CS/Algol68/
+
+ The interpreter described in "Algol 68 as an Implementation Language\
+ for Portable Interpreters", ACM SIGPLAN Notices - Proceedings of the
+ Strathclyde ALGOL 68 conference, Volume 12 Issue 6, June 1977,
+ pp. 54 - 62, and "A Highly-Structured Interpreter for a SNOBOL4
+ Subset", Software: Practice and Experience, Vol. 9, 4,
+ pp. 281-312, April 1979.
+
+ Modifications by Jose E. Marchesi:
+ - Use the simple POSIX-like transput provided by GCC.
+ - Read programs from lines rather than from cards.
+ - Add command-line option -l (listing).
+#
+
+BEGIN PROC itoa = (INT i) STRING:
+ BEGIN IF i = 0
+ THEN "0"
+ ELSE INT n := ABS i;
+ STRING res;
+ WHILE n /= 0
+ DO INT rem = n %* 10;
+ res := REPR (rem > 9 | (rem - 10) + ABS "a" | rem + ABS
"0") + res;
+ n %:= 10
+ OD;
+ (i < 0 | "-" + res | res)
+ FI
+ END;
+
+ CHAR sharp = REPR 35; # Sharp character,
+ to avoid confusing Emacs. #
+
+ # Input file. #
+ INT filein;
+
+ # IMPLEMENTATION RESTRICTIONS #
+ INT spoolsize = 400,
+ stlim = 50,
+ arglim = 5,
+ rslim = 80,
+ pslim = 20,
+ ftlim = 10;
+
+ # ABSTRACT MACHINE #
+ MODE ITEM = UNION (INT, REF STRINGITEM, PATTERN),
+ STRINGITEM = STRUCT (STRING val, REF ITEM ref),
+ PATTERN = REF[]COMPONENT,
+ COMPONENT = STRUCT (INT routine, subsequent, alternate, extra,
+ REF ITEM arg),
+ PSENTRY = STRUCT (INT cursor, alternate),
+ RSENTRY = REF ITEM,
+ FTENTRY = STRUCT (REF ITEM fnname, entry name,
+ REF[]REF ITEM params, locals);
+
+ [1:spoolsize] REF ITEM spool;
+ [1:pslim] PSENTRY pattern stack;
+ [1:rslim] RSENTRY run stack;
+ [1:ftlim] FTENTRY function table;
+
+ BOOL failed := FALSE;
+ INT nin, psp, rsp := 0, ftp := 0;
+ INT mstr = 1, mlen = 2, mbrk = 3, mspn = 4, many = 5, mnul = 6,
+ miv1 = 7, miv2 = 8, m1 = 9, mat = 10, mpos = 11, mtab = 12,
+ mrpos = 13, mrtab = 14, mnty = 15;
+
+ # INTERNAL FORM OF PROGRAMS #
+
+ MODE STMT = STRUCT (REF IDR label,
+ UNION (REF ASMT, REF MATCH,
+ REF REPL, REF EXPR) stmt core,
+ REF GOTOFIELD goto),
+ IDR = STRUCT (REF ITEM idr addr),
+ NUM = STRUCT (REF ITEM num addr),
+ LSTR = STRUCT (REF ITEM lstr addr),
+ ASMT = STRUCT (REF EXPR subject, object),
+ MATCH = STRUCT (REF EXPR subject, pattern),
+ REPL = STRUCT (REF EXPR subject, pattern, object),
+ EXPR = UNION (REF UNARYEXPR, REF BINARYEXPR, IDR, NUM,
+ LSTR, REF CALL),
+ GOTOFIELD = STRUCT (REF DEST upart, spart, fpart),
+ DEST = UNION (REF EXPR, CHAR),
+ UNARYEXPR = STRUCT (REF EXPR operand, CHAR operator),
+ BINARYEXPR = STRUCT (REF EXPR operand1, operand2,
+ CHAR operator),
+ CALL = STRUCT (IDR fnname, REF[]REF EXPR args);
+
+ REF[]STMT t;
+ REF ITEM prog entry := NIL;
+
+ PROC error = (STRING mess) VOID:
+ (puts ("error: " + mess + "'n"); stop);
+
+ # TRANSLATION PHASE #
+
+ BEGIN # DECLARATIONS FOR SCANNER #
+ STRING card, INT cp, # SOURCE LINE AND POINTER #
+ CHAR ch, # SOURCE CHARACTER #
+ [1:80]CHAR str, INT sp, # STRING BUFFER AND POINTER #
+ CHAR tok, # TOKEN CODE #
+ REF ITEM psn, # POSITION OF A CREATED VALUE #
+ INT nv, # NUMERIC VALUE OF CONSTANT #
+ INT stn, # SOURCE STATEMENT NUMBER #
+ BOOL listing, # FLAG FOR SOURCE LISTING #
+ CHAR c; # TEMPORARY #
+
+ # TOKEN MNEMONICS #
+ CHAR doll = "$", bdoll = "D",
+ plus = "+", bplus = "P",
+ minus = "-", bminus = "M",
+ at = "@", bbar = "!",
+ bstar = "*", bslash = "/",
+ lpar = "(", rpar = ")",
+ comma = ",", colon = ":",
+ equal = "=", blank = " ",
+ eos = ";", name = "A",
+ lstring = "L", number = "U",
+ endt = "E", ret = "R",
+ fret = "F", stok = "Y",
+ ftok = "Z";
+
+ PROC get card = VOID:
+ BEGIN cp := 0;
+ WHILE card := fgets (filein, 80);
+ IF UPB card = 0 THEN exit FI;
+ c := card[1];
+ IF c /= "." AND c /= "+" AND c /= "-" AND c /= "*"
+ THEN stn := stn + 1 FI;
+ IF listing THEN puts (itoa (stn) + " " + card +
"'n") FI;
+ IF c = "-"
+ THEN IF card[2:5] = "LIST"
+ THEN listing := TRUE
+ ELIF card[2:7] = "UNLIST"
+ THEN listing := FALSE
+ FI
+ FI;
+ c = "-" OR c = "*"
+ DO SKIP OD;
+ exit: SKIP
+ END;
+
+ PROC next ch = VOID:
+ IF cp = UPB card
+ THEN get card;
+ IF c = "." OR c = "+"
+ THEN ch := " "; cp := 1
+ ELSE ch := sharp # END OF LINE AND STATEMENT #
+ FI
+ ELSE ch := card[cp +:= 1]
+ FI;
+
+ PROC lookup = (STRING sv) REF ITEM : (
+ INT i := 0, BOOL nf := TRUE;
+ WHILE IF (i +:= 1) <= nin
+ THEN nf := sv /= val OF (spool[i] | (REF STRINGITEM s) :
s)
+ ELSE FALSE
+ FI
+ DO SKIP OD;
+ IF nf
+ THEN IF nin = spoolsize THEN error ("too many strings") FI;
+ spool[nin +:= 1] := HEAP ITEM := HEAP STRINGITEM :=
+ (sv, NIL)
+ FI;
+ spool[i]);
+
+ PROC scan = VOID:
+ IF ch = " " # BLANKS AND BINARY OPERATORS #
+ THEN WHILE next ch; ch = " " DO SKIP OD;
+ # IGNORE TRAILING BLANKS IN A STATEMENT #
+ IF ch = ";" THEN next ch; stn := stn + 1; tok := eos
+ ELIF ch = sharp THEN next ch; tok := eos
+ ELIF ch = "!" OR ch = "$" OR ch = "+" OR ch = "-"
+ OR ch = "*" OR ch = "/"
+ THEN IF card[cp+1] = " "
+ THEN c := ch;
+ WHILE next ch; ch = " " DO SKIP OD ;
+ tok := (c = "!" | bbar
+ |: c = "$" | bdoll
+ |: c = "-" | bminus
+ |: c = "+" | bplus
+ |: c = "*" | bstar
+ | bslash)
+ ELSE tok := blank
+ FI
+ ELSE tok := blank
+ FI
+ ELIF ch = "''" OR ch = """" # LITERAL STRINGS #
+ THEN c := ch; sp := 0;
+ WHILE next ch;
+ IF ch = sharp THEN error ("UNTERMINATED LITERAL") FI;
+ (str[sp +:= 1] := ch) /= c
+ DO SKIP OD ;
+ next ch;
+ tok := lstring;
+ IF sp = 1
+ THEN psn := NIL
+ ELSE STRING s = str[1:sp-1] ;
+ psn := lookup (s)
+ FI
+ ELIF ch >= "0" AND ch <= "9" # NUMBERS #
+ THEN nv := 0 ;
+ WHILE nv := nv * 10 + ABS ch - ABS "0";
+ next ch;
+ ch >= "0" AND ch <= "9"
+ DO SKIP OD ;
+ tok := number;
+ psn := HEAP ITEM := nv
+ ELIF ch >= "A" AND ch <= "Z" # NAMES #
+ THEN sp := 0;
+ WHILE str[sp +:= 1] := ch;
+ next ch;
+ ch = "." OR ch >= "A" AND ch <= "Z"
+ OR ch >= "0" AND ch <= "9"
+ DO SKIP OD ;
+ STRING s = str[1:sp];
+ tok := (s = "S" | stok
+ |: s = "F" | ftok
+ |: s = "END" | endt
+ |: s = "RETURN" | ret
+ |: s = "FRETURN" | fret
+ | psn := lookup (s); name)
+ ELIF ch = ";"
+ THEN next ch; stn := stn + 1; tok := eos
+ ELIF ch = sharp
+ THEN next ch; tok := eos
+ ELSE # ( ) , : = @ $ + - #
+ tok := ch; next ch
+ FI;
+
+ PROC init = VOID:
+ BEGIN stn := 0;
+ spool[nin := 1] := HEAP ITEM := HEAP STRINGITEM :=
+ ("ARB", HEAP ITEM := HEAP[1:3]COMPONENT :=
+ ((mnul, 2, 0, SKIP, NIL),
+ (mnul, 0, 3, SKIP, NIL),
+ (m1, 2, 0, SKIP, NIL)));
+ get card;
+ next ch;
+ scan
+ END;
+
+ PROC verify = (CHAR token) VOID:
+ IF tok = token THEN scan
+ ELSE STRING s := "TOKEN "" "" DOES NOT OCCUR WHERE EXPECTED";
+ s[8] := token;
+ error (s)
+ FI;
+
+ PROC translate = VOID:
+ BEGIN HEAP[1:stlim]STMT ss, INT ssc := 0;
+ WHILE IF ssc = stlim THEN error ("TOO MANY STATEMENTS") FI;
+ tok /= endt
+ DO ss[ssc +:= 1] := trans stmt OD;
+ scan;
+ IF tok = blank
+ THEN scan;
+ IF tok = name THEN prog entry := psn FI
+ FI;
+ t := ss[1:ssc]
+ END;
+
+ PROC trans stmt = STMT:
+ BEGIN
+ REF IDR lab := NIL;
+ REF EXPR subj, pat, obj := NIL;
+ REF GOTOFIELD go := NIL;
+ BOOL asgn;
+
+ PROC move to obj = STMT:
+ BEGIN
+ IF tok = blank
+ THEN scan;
+ IF tok = colon
+ THEN go := trans gofield
+ ELSE obj := trans expr;
+ IF tok = colon
+ THEN go := trans gofield
+ ELSE verify (eos)
+ FI
+ FI
+ ELSE verify (eos)
+ FI ;
+ IF asgn
+ THEN STMT (lab, HEAP ASMT := (subj, obj), go)
+ ELSE STMT (lab, HEAP REPL := (subj, pat, obj), go)
+ FI
+ END;
+
+ PROC move to subj = STMT:
+ BEGIN scan;
+ IF tok = colon
+ THEN STMT (lab, REF EXPR (NIL), trans gofield)
+ ELSE subj := trans elem;
+ IF tok = blank
+ THEN scan;
+ IF tok = colon
+ THEN STMT (lab, REF EXPR (subj), trans gofield)
+ ELIF tok = equal
+ THEN asgn := TRUE; scan; move to obj
+ ELSE pat := trans expr;
+ IF tok = colon
+ THEN STMT (lab, HEAP MATCH := (subj, pat),
trans gofield)
+ ELIF tok = equal
+ THEN asgn := FALSE; scan; move to obj
+ ELSE verify (eos);
+ STMT (lab, HEAP MATCH := (subj, pat),
NIL)
+ FI
+ FI
+ ELSE verify (eos);
+ STMT (lab, REF EXPR (subj), NIL)
+ FI
+ FI
+ END;
+
+ # Body of trans stmt. #
+ IF tok = name
+ THEN lab := HEAP IDR; idr addr OF lab := psn; scan;
+ IF tok = blank
+ THEN move to subj
+ ELSE verify (eos);
+ STMT (lab, REF EXPR (NIL), NIL)
+ FI
+ ELIF tok = blank
+ THEN move to subj
+ ELSE verify (eos);
+ STMT (lab, REF EXPR (NIL), NIL)
+ FI
+ END;
+
+ PROC trans gofield = REF GOTOFIELD:
+ BEGIN PROC where = REF DEST:
+ BEGIN HEAP DEST d;
+ verify (lpar);
+ IF tok = blank THEN scan FI;
+ d := (tok = endt | scan; "E"
+ |: tok = ret | scan; "R"
+ |: tok = fret | scan; "F"
+ | trans expr);
+ verify (rpar);
+ d
+ END;
+
+ REF DEST uncond := NIL, succ := NIL, fail := NIL;
+ scan; IF tok = blank THEN scan FI;
+ IF tok = stok
+ THEN scan; succ := where;
+ IF tok = blank THEN scan FI;
+ IF tok = ftok THEN scan; fail := where FI;
+ verify (eos)
+ ELIF tok = ftok
+ THEN scan; fail := where;
+ IF tok = blank THEN scan FI;
+ IF tok = stok THEN scan; succ := where FI;
+ verify (eos)
+ ELSE uncond := where; verify (eos)
+ FI;
+ HEAP GOTOFIELD := (uncond, succ, fail)
+ END;
+
+ PROC trans expr = REF EXPR:
+ BEGIN REF EXPR e := trans expr1;
+ WHILE tok = bbar
+ DO scan;
+ e := HEAP EXPR := HEAP BINARYEXPR := (e, trans expr1, "!")
+ OD;
+ e
+ END;
+
+ PROC trans expr1 = REF EXPR:
+ BEGIN REF EXPR e := trans expr2;
+ WHILE tok = blank
+ DO scan;
+ IF tok /= colon AND tok /= rpar AND tok /= comma AND tok
/= equal
+ THEN e := HEAP EXPR := HEAP BINARYEXPR := (e, trans
expr2, "C")
+ FI
+ OD;
+ e
+ END;
+
+ PROC trans expr2 = REF EXPR:
+ BEGIN REF EXPR e := trans term;
+ CHAR opr;
+ WHILE tok = bplus OR tok = bminus
+ DO opr := (tok = bplus | "+" | "-");
+ scan;
+ e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term, opr)
+ OD;
+ e
+ END;
+
+ PROC trans term = REF EXPR:
+ BEGIN REF EXPR e := trans term1;
+ WHILE tok = bslash
+ DO scan;
+ e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term1, "/")
+ OD;
+ e
+ END;
+
+ PROC trans term1 = REF EXPR:
+ BEGIN REF EXPR e := trans term2;
+ WHILE tok = bstar
+ DO scan;
+ e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term2, "*")
+ OD;
+ e
+ END;
+
+ PROC trans term2 = REF EXPR:
+ BEGIN REF EXPR e := trans elem;
+ WHILE tok = bdoll
+ DO scan;
+ e := HEAP EXPR := HEAP BINARYEXPR := (e, trans elem, "$")
+ OD;
+ e
+ END;
+
+ PROC trans elem = REF EXPR:
+ IF tok = doll OR tok = plus OR tok = minus OR tok = at
+ THEN CHAR opr = tok;
+ scan;
+ HEAP EXPR := HEAP UNARYEXPR := (trans element, opr)
+ ELSE trans element
+ FI;
+
+ PROC trans element = REF EXPR:
+ IF tok = name
+ THEN IDR n;
+ idr addr OF n := psn;
+ scan;
+ IF tok /= lpar
+ THEN HEAP EXPR := n
+ ELSE HEAP[1:arglim]REF EXPR a, INT ac := 0;
+ WHILE scan;
+ IF tok = blank THEN scan FI;
+ IF ac = arglim
+ THEN error ("TOO MANY ARGUMENTS IN FUNCTION
CALL")
+ FI;
+ IF NOT (ac = 0 AND tok = rpar)
+ THEN a[ac +:= 1] := (tok = comma OR tok = rpar
| NIL | trans expr)
+ FI;
+ IF tok /= comma AND tok /= rpar
+ THEN error ("ERROR IN ARGUMENT LIST")
+ FI;
+ tok = comma
+ DO SKIP OD;
+ scan;
+ HEAP EXPR := HEAP CALL := (n, a[1:ac])
+ FI
+ ELIF tok = lstring
+ THEN LSTR ls;
+ lstr addr OF ls := psn;
+ scan;
+ HEAP EXPR := ls
+ ELIF tok = number
+ THEN NUM nu; num addr OF nu := psn;
+ scan;
+ HEAP EXPR := nu
+ ELSE verify (lpar);
+ IF tok = blank THEN scan FI;
+ REF EXPR e = trans expr;
+ verify (rpar);
+ e
+ FI;
+
+ PROC usage = VOID:
+ BEGIN puts ("Usage: snobol [-l] FILE'n");
+ stop
+ END;
+
+ listing := FALSE;
+ IF argc < 2 THEN usage FI;
+ FOR i FROM 2 TO argc
+ DO IF argv (i) = "-l" THEN listing := TRUE
+ ELIF filein = 0
+ THEN filein := fopen (argv (i), file o rdonly);
+ IF (filein = -1)
+ THEN error ("opening " + argv (i) + ": " + strerror
(errno)) FI
+ ELSE usage
+ FI
+ OD;
+ init;
+ translate
+ END; # TRANSLATION PHASE #
+
+ BEGIN # INTERPRETATION PHASE #
+
+ OP INTG = (REF ITEM a) INT: (a | (INT i) : i),
+ STR = (REF ITEM a) REF STRINGITEM: (a | (REF STRINGITEM s): s),
+ PAT = (REF ITEM a) PATTERN: (a | (PATTERN p) : p);
+ BOOL fn success;
+
+ PROC interpret = (INT stmt no) VOID:
+ BEGIN INT sn := stmt no; BOOL cycling := TRUE;
+
+ PROC jump = (REF DEST dest) VOID:
+ BEGIN failed := FALSE;
+ CASE dest
+ IN (REF EXPR e): sn := find label (eval softly (e)),
+ (CHAR c): IF c = "E" THEN sn := UPB t + 1
+ ELIF c = "R" THEN fn success := TRUE;
+ cycling := FALSE
+ ELSE # c = "F" # fn success := cycling :=
FALSE
+ FI
+ ESAC
+ END;
+
+ WHILE cycling
+ DO IF sn > UPB t THEN stop FI;
+ failed := FALSE;
+
+ # EXECUTE STATEMENT CORE #
+ CASE stmt core OF t[sn]
+ IN (REF ASMT a):
+ (REF ITEM sp = eval softly (subject OF a);
+ assign (sp, eval strongly (object OF a))),
+ (REF MATCH m):
+ (REF ITEM svp = eval strongly (subject OF m);
+ match (convert to str (svp),
+ convert to pat (eval strongly (pattern OF
m)))),
+ (REF REPL r):
+ (REF ITEM sp = eval softly (subject OF r);
+ REF ITEM pp = convert to pat (eval strongly
(pattern OF r));
+ REF ITEM svp = convert to str (ref OF (STR sp));
+ INT c = match (svp, pp);
+ REF ITEM b = (svp IS NIL | NIL | make str ((val OF
(STR svp))[c+1:]));
+ REF ITEM obp = eval strongly (object OF r);
+ assign (sp, concatenate (obp, b))),
+ (REF EXPR e):
+ eval strongly (e)
+ ESAC;
+
+ # PROCESS GOTO FIELD #
+ REF GOTOFIELD go = goto OF t[sn];
+ IF go IS NIL THEN sn := sn + 1
+ ELIF REF DEST (upart OF go) ISNT NIL
+ THEN jump (upart OF go)
+ ELIF NOT failed AND (REF DEST (spart OF go) ISNT NIL)
+ THEN jump (spart OF go)
+ ELIF failed AND (REF DEST (fpart OF go) ISNT NIL)
+ THEN jump (fpart OF go)
+ ELSE sn := sn + 1
+ FI
+ OD
+ END; # END OF INTERPRET #
+
+ PROC find label = (REF ITEM label ptr) INT:
+ BEGIN INT stmt no := 0;
+ IF failed THEN error ("FAILURE IN GOTO FIELD") FI;
+ FOR i TO UPB t WHILE stmt no = 0
+ DO IF (REF IDR (label OF t[i]) IS NIL
+ | FALSE
+ | label ptr IS idr addr OF label OF t[i])
+ THEN stmt no := i
+ FI
+ OD;
+ IF stmt no = 0 THEN error ("UNDEFINED LABEL") FI;
+ stmt no
+ END;
+
+ PROC match = (REF ITEM subject ptr, pattern ptr) INT:
+ IF failed
+ THEN 0
+ ELSE PATTERN p = PAT pattern ptr;
+ STRING subj = (subject ptr IS NIL | "" | val OF (STR
subject ptr));
+ INT u = UPB subj;
+ INT iarg, # INTEGER COMPONENT ARGUMENT #
+ STRING sarg, # STRING COMPONENT ARGUMENT #
+ INT l; # LENGTH OF SARG #
+ INT cn := 1, # COMPONENT NUMBER #
+ c := 0, # CURSOR #
+ code; # NEW CURSOR OR -1 IF COMPONENT NO-MATCH #
+ BOOL matching := TRUE;
+
+ psp := 0; # CLEAR PATTERN STACK #
+ WHILE matching
+ DO IF alternate OF p[cn] /= 0
+ THEN # PUSH PATTERN STACK #
+ pattern stack[psp +:= 1] := (c, alternate OF p[cn])
+ FI;
+ IF REF ITEM (arg OF p[cn]) ISNT NIL
+ THEN CASE arg OF p[cn]
+ IN (INT i) : iarg := i,
+ (REF STRINGITEM s):
+ (sarg := val OF s; l := UPB sarg)
+ ESAC
+ FI;
+
+ # EXECUTE INDICATED MATCHING ROUTINE #
+ CASE routine OF p[cn]
+ IN # MSTR #
+ IF REF ITEM (arg OF p[cn]) IS NIL
+ THEN code := c
+ ELIF c + l > u THEN code := -1
+ ELSE code := (sarg = subj[c+1:c+l] | c + l | -1)
+ FI,
+ # MLEN #
+ code := (iarg <= u - c | c + iarg | -1),
+ # MBRK #
+ IF c >= u THEN code := -1
+ ELSE INT n = break scan (subj[c+1:], sarg);
+ code := (n < u - c | c + n | -1)
+ FI,
+ # MSPN #
+ IF c >= u THEN code := -1
+ ELIF any (sarg, subj[c+1])
+ THEN INT j := c + 1;
+ FOR i FROM c + 2 TO u WHILE any (sarg, subj[i])
+ DO j := i OD;
+ code := j
+ ELSE code := -1
+ FI,
+ # MANY #
+ IF c >= u
+ THEN code := -1
+ ELSE code := (any (sarg, subj[c+1]) | c + 1 | -1)
+ FI,
+ # MNUL #
+ code := c,
+ # MIV1 #
+ code := extra OF p[cn] := c,
+ # MIV2 #
+ (INT m = extra OF p[cn - extra OF p[cn]] + 1;
+ assign (arg OF p[cn], make str (subj[m:c]));
+ code := c),
+ # M1 #
+ code := (1 <= u - c | c + 1 | -1),
+ # MAT #
+ (assign (arg OF p[cn], make int (c));
+ code := c),
+ # MPOS #
+ code := (c = iarg | c | -1),
+ # MTAB #
+ code := (c <= iarg AND iarg <= u | iarg | -1),
+ # MRPOS #
+ code := (u - c = iarg | c | -1),
+ # MRTAB #
+ code := (u - c >= iarg | u - iarg | -1),
+ # MNTY #
+ IF c >= u
+ THEN code := -1
+ ELSE code := (any (sarg, subj[c+1]) | -1 | c + 1)
+ FI
+ ESAC;
+
+ # DECIDE WHAT TO DO NEXT #
+ IF code >= 0
+ THEN IF subsequent OF p[cn] = 0
+ THEN matching := FALSE #SUCCESSFUL TERMINATION #
+ ELSE cn := subsequent OF p[cn];
+ c := code # CONTINUE #
+ FI
+ ELIF psp = 0
+ THEN failed := TRUE;
+ matching := FALSE # STMT FAILURE #
+ ELSE # POP PATTERN STACK TO BACKTRACK #
+ cn := alternate OF pattern stack[psp];
+ c := cursor OF pattern stack[psp];
+ psp := psp - 1
+ FI
+ OD;
+ (failed | 0 | code)
+ FI; # END OF MATCH PROCEDURE #
+
+ PROC assign = (REF ITEM subject ptr, object ptr) VOID:
+ IF failed THEN SKIP
+ ELSE REF STRINGITEM s = STR subject ptr;
+ ref OF s := object ptr;
+ IF val OF s = "OUTPUT"
+ THEN IF object ptr IS NIL
+ THEN puts ("'n")
+ ELSE CASE object ptr
+ IN (REF STRINGITEM r): puts ((val OF r) + "'n"),
+ (INT i): puts (itoa (i) + "'n"),
+ (PATTERN): (error ("ATTEMPT TO OUTPUT
PATTERN"); SKIP)
+ ESAC
+ FI
+ FI
+ FI;
+
+ PROC eval softly = (REF EXPR expression) REF ITEM:
+ IF failed THEN SKIP
+ ELSE CASE expression # CAN NEVER BE NIL #
+ IN (IDR id): idr addr OF id,
+ (REF UNARYEXPR ue):
+ IF operator OF ue = "$"
+ THEN REF ITEM r = convert to str (eval strongly
(operand OF ue));
+ IF r IS NIL
+ THEN error ("NULL RESULT WHERE VAR REQUIRED");
+ SKIP
+ ELSE r
+ FI
+ ELSE error ("INAPPROPRIATE UNARY EXPR WHERE VAR
REQUIRED");
+ SKIP
+ FI
+ OUT error ("INAPPROPRIATE EXPR WHERE VAR REQUIRED");
+ SKIP
+ ESAC
+ FI;
+
+ PROC eval strongly = (REF EXPR expression) REF ITEM:
+ IF failed THEN SKIP
+ ELIF expression IS NIL THEN NIL
+ ELSE CASE expression
+ IN (IDR id):
+ (REF STRINGITEM s = STR (idr addr OF id);
+ IF val OF s = "INPUT"
+ THEN STRING line;
+ # SNOBOL programs read data from stdin. #
+ line := gets (80);
+ IF (line = "") THEN failed := TRUE; eof FI;
+ assign (idr addr OF id, make str (line));
+ eof: SKIP
+ FI;
+ ref OF s),
+ (NUM nbr):
+ num addr OF nbr,
+ (LSTR ls):
+ lstr addr OF ls,
+ (REF UNARYEXPR ue):
+ (REF ITEM arg ptr = (operator OF ue = "@"
+ | eval softly (operand OF ue)
+ | eval strongly (operand OF
ue));
+ eval unary (arg ptr, operator OF ue)),
+ (REF BINARYEXPR be):
+ (REF ITEM arg1 ptr = eval strongly (operand1 OF be);
+ REF ITEM arg2 ptr = (operator OF be = "$"
+ | eval softly (operand2 OF be)
+ | eval strongly (operand2 OF
be));
+ eval binary (arg1 ptr, arg2 ptr, operator OF be)),
+ (REF CALL cl):
+ (INT n = UPB args OF cl;
+ [1:n]REF ITEM arglist;
+ FOR i TO n
+ DO arglist[i] := eval strongly ((args OF cl)[i]) OD;
+ eval call (idr addr OF fnname OF cl, arglist))
+ ESAC
+ FI;
+
+ PROC eval unary = (REF ITEM arg ptr, CHAR opr) REF ITEM:
+ IF failed THEN SKIP
+ ELSE IF opr = "$"
+ THEN IF arg ptr IS NIL
+ THEN error ("INDIRECTION APPLIED TO NULL STRING");
+ SKIP
+ ELSE ref OF (STR convert to str (arg ptr))
+ FI
+ ELIF opr = "+"
+ THEN convert to int (arg ptr)
+ ELIF opr = "-"
+ THEN INT k = INTG convert to int (arg ptr);
+ make int (-k)
+ ELSE # OPR = "@" #
+ make pat comp (mat, arg ptr)
+ FI
+ FI;
+
+ PROC eval binary = (REF ITEM arg1 ptr, arg2 ptr, CHAR opr) REF
ITEM:
+ IF failed THEN SKIP
+ ELSE IF opr = "$"
+ THEN REF ITEM c = concatenate (make pat comp (miv1, NIL),
+ arg1 ptr);
+ concatenate (c, make pat comp (miv2, arg2 ptr))
+ ELIF opr = "*" OR opr = "/" OR opr = "+" OR opr = "-"
+ THEN INT m = INTG convert to int (arg1 ptr),
+ n = INTG convert to int (arg2 ptr);
+ make int ((opr = "*" | m * n
+ |: opr = "/" | m OVER n
+ |: opr = "+" | m + n | m - n))
+ ELIF opr = "C"
+ THEN concatenate (arg1 ptr, arg2 ptr)
+ ELSE # OPR = "!" #
+ PATTERN p1 = PAT convert to pat (arg1 ptr),
+ p2 = PAT convert to pat (arg2 ptr);
+ INT u1 = UPB p1, u2 = UPB p2;
+ PATTERN p = HEAP[u1 + u2]COMPONENT,
+ INT offset = u1 + 1, INT j := 1;
+ p[1:u1] := p1[1:u1];
+ WHILE alternate OF p[j] /= 0
+ DO j := alternate OF p[j] OD;
+ alternate OF p[j] := offset;
+ FOR i FROM offset TO u1 + u2
+ DO p[i] := p2 [i - u1];
+ IF subsequent OF p[i] /= 0
+ THEN subsequent OF p[i] +:= u1
+ FI;
+ IF alternate OF p[i] /= 0
+ THEN alternate OF p[i] +:= u1
+ FI
+ OD;
+ HEAP ITEM := p
+ FI
+ FI;
+
+ PROC eval call = (REF ITEM name ptr, REF[]REF ITEM arglist) REF
ITEM:
+ IF failed THEN SKIP
+ ELSE # SEARCH FUNCTION TABLE FOR NAME #
+ BOOL not found := TRUE, INT j;
+ FOR i TO ftp WHILE not found
+ DO IF name ptr IS fnname OF function table[i]
+ THEN j := i; not found := FALSE
+ FI
+ OD;
+ IF not found
+ THEN exec prim fn (name ptr, arglist)
+ ELSE #PROGRAMMER-DEFINED FUNCTION #
+
+ PROC stack = (REF ITEM a) VOID:
+ (IF rsp = rslim THEN error ("RUN STACK OVERFLOW")
FI;
+ run stack [rsp +:= 1] := a);
+
+ PROC unstack = REF ITEM:
+ (IF rsp = 0 THEN error ("RETURN FROM LEVEL 0") FI;
+ run stack [(rsp -:= 1) + 1]);
+
+ REF STRINGITEM name = STR name ptr;
+
+ # ENTRY PROTOCOL #
+ stack (ref OF name);
+ assign (name ptr, NIL);
+ REF[]REF ITEM params = params OF function table[j],
+ INT n = UPB arglist;
+ IF UPB params /= n
+ THEN error ("WRONG NUMBER OF ARGUMENTS IN CALL")
+ FI;
+ FOR i TO n
+ DO stack (ref OF (STR params[i]));
+ assign (params[i], arglist[i])
+ OD;
+ REF[]REF ITEM locals = locals OF function table[j];
+ FOR i TO UPB locals
+ DO stack (ref OF (STR locals[i]));
+ assign (locals[i], NIL)
+ OD;
+
+ interpret (find label (entry name OF function
table[j]));
+
+ # RETURN PROTOCOL #
+ FOR i FROM UPB locals BY -1 TO 1
+ DO assign (locals[i], unstack) OD;
+ FOR i FROM n BY -1 TO 1
+ DO assign (params[i], unstack) OD;
+ REF ITEM result = ref OF name;
+ assign (name ptr, unstack);
+ (fn success | result | failed := TRUE ; SKIP)
+ FI
+ FI;
+
+ PROC exec prim fn = (REF ITEM name ptr,
+ REF[]REF ITEM arglist) REF ITEM:
+ BEGIN
+ PROC gen1 = (INT routine) REF ITEM:
+ BEGIN # CREATE PATTERN COMPONENT WITH STRING ARGUMENT #
+ REF ITEM arg = convert to str (arglist[1]);
+ IF arg IS NIL
+ THEN error ("NULL ARG FOR PATTERN-VALUED PRIMITIVE
FUNCTION" )
+ FI;
+ make pat comp (routine, arg)
+ END;
+
+ PROC gen2 = (INT routine) REF ITEM:
+ BEGIN # CREATE PATTERN COMPONENT WITH INTEGER ARGUMENT #
+ REF ITEM arg = convert to int (arglist[1]);
+ IF INTG arg < 0
+ THEN error ("NEGATIVE ARG FOR PATTERN-VALUED PRIMITIVE
FUNCTION")
+ FI;
+ make pat comp (routine, arg)
+ END;
+
+ STRING fn = val OF (STR name ptr), INT n = UPB arglist;
+ IF fn = "LE" AND n = 2
+ THEN IF INTG convert to int (arglist[1])
+ <= INTG convert to int (arglist[2])
+ THEN NIL
+ ELSE failed := TRUE;
+ SKIP
+ FI
+ ELIF fn = "EQ" AND n = 2
+ THEN IF INTG convert to int (arglist[1])
+ = INTG convert to int (arglist[2])
+ THEN NIL
+ ELSE failed := TRUE;
+ SKIP
+ FI
+ ELIF fn = "NE" AND n = 2
+ THEN IF INTG convert to int (arglist[1])
+ /= INTG convert to int (arglist[2])
+ THEN NIL
+ ELSE failed := TRUE;
+ SKIP
+ FI
+ ELIF fn = "IDENT" AND n = 2
+ THEN IF REF ITEM (arglist[1]) IS arglist[2]
+ THEN NIL
+ ELSE failed := TRUE;
+ SKIP
+ FI
+ ELIF fn = "DIFFER" AND n = 2
+ THEN IF REF ITEM (arglist[1]) ISNT arglist[2]
+ THEN NIL
+ ELSE failed := TRUE;
+ SKIP
+ FI
+ ELIF fn = "ANY" AND n = 1 THEN gen1 (many)
+ ELIF fn = "LEN" AND n = 1 THEN gen2 (mlen)
+ ELIF fn = "POS" AND n = 1 THEN gen2 (mpos)
+ ELIF fn = "TAB" AND n = 1 THEN gen2 (mtab)
+ ELIF fn = "SPAN" AND n = 1 THEN gen1 (mspn)
+ ELIF fn = "RPOS" AND n = 1 THEN gen2 (mrpos)
+ ELIF fn = "RTAB" AND n = 1 THEN gen2 (mrtab)
+ ELIF fn = "BREAK" AND n = 1 THEN gen1 (mbrk)
+ ELIF fn = "NOTANY" AND n = 1 THEN gen1 (mnty)
+ ELIF fn = "SIZE" AND n = 1
+ THEN make int (UPB val OF (STR convert to str (arglist[1])))
+ ELIF fn = "DEFINE" AND n = 2
+ THEN IF REF ITEM (arglist[1]) IS NIL
+ THEN error ("NULL PROTOTYPE") FI;
+ STRING prototype = val OF (STR convert to str
(arglist[1]));
+ REF ITEM entry = convert to str (arglist[2]);
+ IF entry IS NIL THEN error ("NULL ENTRY LABEL") FI;
+
+ PROC check and find = (STRING str) REF ITEM:
+ BEGIN IF UPB str = 0 THEN error ("ILLEGAL PROTOTYPE")
FI;
+ STRING an =
"ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.";
+ IF NOT any (an[:26], str[1])
+ THEN error ("ILLEGAL PROTOTYPE") FI;
+ FOR i FROM 2 TO UPB str
+ DO IF NOT any (an, str[i])
+ THEN error ("ILLEGAL PROTOTYPE")
+ FI
+ OD;
+ make str (str)
+ END;
+
+ PROC breakup = (STRING str) REF[]REF ITEM:
+ BEGIN #ANALYZE A LIST OF IDENTIFIERS #
+ [1:arglim]REF ITEM r, INT p := 0, a := 1, b;
+ WHILE a <= UPB str
+ DO b := break scan (str[a:], ",");
+ IF p >= arglim
+ THEN error ("TOO MANY PARAMETERS OR LOCALS IN
PROTOTYPE") FI;
+ r[p +:= 1] := check and find (str[a:a+b-1]);
+ a := a + b + 1
+ OD;
+ HEAP[1:p]REF ITEM := r[:p]
+ END;
+
+ INT lp = UPB prototype;
+ INT a = break scan (prototype, "(");
+ IF a >= lp THEN error ("ILLEGAL PROTOTYPE") FI;
+ REF ITEM name ptr = check and find (prototype[:a]);
+ INT b = break scan (prototype[a+2:], ")");
+ IF b >= lp - a - 1 THEN error ("ILLEGAL PROTOTYPE") FI;
+ REF[]REF ITEM params = breakup (prototype[a+2:a+1+b]);
+ REF[]REF ITEM locals = breakup (prototype[a+b+3:]);
+
+ BOOL not found := TRUE;
+ FOR i TO ftp WHILE not found
+ DO IF name ptr IS fnname OF function table[i]
+ THEN not found := FALSE;
+ function table[i] := (name ptr, entry, params,
locals)
+ FI
+ OD;
+ IF not found
+ THEN IF ftp = ftlim
+ THEN error ("FUNCTION TABLE OVERFLOW") FI;
+ function table [ftp +:= 1] := (name ptr, entry,
params, locals)
+ FI;
+ NIL # RESULT OF DEFINE(...) #
+ ELSE error ("ILLEGAL FUNCTION CALL");
+ SKIP
+ FI
+ END;
+
+ PROC concatenate = (REF ITEM ptr1, ptr2) REF ITEM:
+ BEGIN
+
+ PROC concat patterns = (PATTERN p1, p2) REF ITEM:
+ BEGIN INT u1 = UPB p1, u2 = UPB p2;
+ PATTERN p = HEAP[u1 + u2]COMPONENT;
+ INT offset = u1 + 1;
+ FOR i TO u1
+ DO p[i] := p1[i];
+ IF subsequent OF p[i] = 0
+ THEN subsequent OF p[i] := offset FI
+ OD;
+ FOR i FROM offset TO u1 + u2
+ DO p[i] := p2[i - u1];
+ IF subsequent OF p[i] /= 0
+ THEN subsequent OF p[i] +:= u1 FI;
+ IF alternate OF p[i] /= 0
+ THEN alternate OF p[i] +:= u1 FI
+ OD;
+ IF u2 = 1 AND routine OF p[offset] = miv2
+ THEN extra OF p[offset] := u1 FI;
+ HEAP ITEM := p
+ END;
+
+ IF failed THEN SKIP
+ ELSE IF ptr1 IS NIL THEN ptr2
+ ELIF ptr2 IS NIL THEN ptr1
+ ELSE CASE ptr1
+ IN (PATTERN p1):
+ concat patterns (p1, PAT convert to pat (ptr2))
+ OUSE ptr2
+ IN (PATTERN p2):
+ concat patterns (PAT convert to pat (ptr1), p2)
+ OUT STRING s1 = val OF (STR convert to str (ptr1));
+ make str (s1 + val OF (STR convert to str
(ptr2)))
+ ESAC
+ FI
+ FI
+ END;
+
+ PROC convert to int = (REF ITEM ptr) REF ITEM:
+ IF failed THEN SKIP
+ ELSE IF ptr IS NIL THEN make int (0)
+ ELSE CASE ptr
+ IN (INT): ptr,
+ (PATTERN): (error ("PATTERN VALUE WHERE INTEGER
REQUIRED"); SKIP),
+ (REF STRINGITEM s):
+ (INT n := 0, d, z := ABS "0";
+ FOR i TO UPB val OF s
+ DO d := ABS (val OF s)[i] - z;
+ IF d < 0 OR d > 9
+ THEN error ("STRING NOT CONVERTIBLE TO
INTEGER") FI;
+ n := n * 10 + d
+ OD;
+ make int (n))
+ ESAC
+ FI
+ FI;
+
+ PROC convert to pat = (REF ITEM ptr) REF ITEM:
+ IF failed THEN SKIP
+ ELSE IF ptr IS NIL
+ THEN make pat comp (mstr, NIL)
+ ELSE CASE ptr
+ IN (PATTERN): ptr
+ OUT make pat comp (mstr, convert to str (ptr))
+ ESAC
+ FI
+ FI;
+
+ PROC convert to str = (REF ITEM ptr) REF ITEM:
+ IF failed THEN SKIP
+ ELSE IF ptr IS NIL THEN ptr
+ ELSE CASE ptr
+ IN (REF STRINGITEM): ptr,
+ (PATTERN): (error ("PATTERN VALUE WHERE STRING
REQUIRED"); SKIP),
+ (INT i): make str (itoa (i))
+ ESAC
+ FI
+ FI;
+
+ PROC make int = (INT val) REF ITEM:
+ IF failed THEN SKIP
+ ELSE HEAP ITEM := val
+ FI;
+
+ PROC make pat comp = (INT routine, REF ITEM arg) REF ITEM:
+ IF failed THEN SKIP
+ ELSE HEAP ITEM := HEAP[1:1]COMPONENT := COMPONENT (routine, 0,
0, SKIP, arg)
+ FI;
+
+ PROC make str = (STRING val) REF ITEM:
+ IF failed THEN SKIP
+ ELIF UPB val = 0 THEN NIL
+ ELSE INT i := 0, BOOL nf := TRUE;
+ WHILE IF (i +:= 1) <= nin
+ THEN nf := val /= val OF (STR spool [i])
+ ELSE FALSE
+ FI
+ DO SKIP OD;
+ IF nf
+ THEN IF nin = spoolsize THEN error ("TOO MANY STRINGS") FI;
+ spool[nin +:= 1] := HEAP ITEM := HEAP STRINGITEM :=
(val, NIL)
+ FI;
+ spool[i]
+ FI;
+
+ PROC break scan = (STRING str, arg) INT:
+ BEGIN # RESULT = UPB STR IF NO BREAK CHAR, LESS OTHERWISE #
+ INT j := 0;
+ FOR i TO UPB str WHILE NOT any (arg, str[i])
+ DO j := i OD;
+ j
+ END;
+
+ PROC any = (STRING str, CHAR ch) BOOL:
+ BEGIN BOOL nf;
+ FOR i TO UPB str WHILE nf := ch /= str[i] DO SKIP OD;
+ NOT nf
+ END;
+
+ interpret ((REF ITEM (prog entry) IS NIL | 1 | find label (prog
entry)))
+ END # INTERPRETATION PHASE #
+END
diff --git a/gcc/testsuite/algol68/compile/supper-1.a68
b/gcc/testsuite/algol68/compile/supper-1.a68
new file mode 100644
index 00000000000..a572f1e929f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-1.a68
@@ -0,0 +1,11 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode Some_Mode = real;
+ Some_Mode some_real := random;
+
+ puts ("Hello time for SUPPER!\n");
+ if some_real > 0.5
+ then puts ("YES\n")
+ else puts ("NO\n")
+ fi
+end
diff --git a/gcc/testsuite/algol68/compile/supper-10.a68
b/gcc/testsuite/algol68/compile/supper-10.a68
new file mode 100644
index 00000000000..5c661a677f4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-10.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+ BEGIN some_int = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-11.a68
b/gcc/testsuite/algol68/compile/supper-11.a68
new file mode 100644
index 00000000000..5c661a677f4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-11.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+ BEGIN some_int = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-12.a68
b/gcc/testsuite/algol68/compile/supper-12.a68
new file mode 100644
index 00000000000..497a88a2e66
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-12.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin for i while i < 10
+ do puts ("lala\n")
+ od
+end
diff --git a/gcc/testsuite/algol68/compile/supper-13.a68
b/gcc/testsuite/algol68/compile/supper-13.a68
new file mode 100644
index 00000000000..5e17fb4832c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-13.a68
@@ -0,0 +1,7 @@
+{ dg-options "-fstropping=supper" }
+
+{ mode_ should not be recognized as a symbol. }
+
+begin int mode_ = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-2.a68
b/gcc/testsuite/algol68/compile/supper-2.a68
new file mode 100644
index 00000000000..04d5f0f461f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-2.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo_bar = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-3.a68
b/gcc/testsuite/algol68/compile/supper-3.a68
new file mode 100644
index 00000000000..4cc711b9132
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-3.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo_bar_ = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-4.a68
b/gcc/testsuite/algol68/compile/supper-4.a68
new file mode 100644
index 00000000000..283be9a4735
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-4.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo_ = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-5.a68
b/gcc/testsuite/algol68/compile/supper-5.a68
new file mode 100644
index 00000000000..b3ffd899e5c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-5.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode Foo_bar = int;
+ Foo_bar some_int = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-6.a68
b/gcc/testsuite/algol68/compile/supper-6.a68
new file mode 100644
index 00000000000..37fc5e6f3c2
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-6.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin go to done;
+done: skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-7.a68
b/gcc/testsuite/algol68/compile/supper-7.a68
new file mode 100644
index 00000000000..a3741748b4c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-7.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin goto done;
+done: skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-8.a68
b/gcc/testsuite/algol68/compile/supper-8.a68
new file mode 100644
index 00000000000..363d9b483ca
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-8.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode Int = int;
+ Int some_int = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-9.a68
b/gcc/testsuite/algol68/compile/supper-9.a68
new file mode 100644
index 00000000000..5c661a677f4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-9.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+ BEGIN some_int = 10;
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/uniting-1.a68
b/gcc/testsuite/algol68/compile/uniting-1.a68
new file mode 100644
index 00000000000..057c4f85838
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/uniting-1.a68
@@ -0,0 +1,8 @@
+{ dg-options {-fstropping=supper} }
+begin mode JSON_Val = union (int,ref JSON_Obj),
+ JSON_Obj = struct (int je),
+
+ proc json_new_obj = JSON_Val:
+ (JSON_Obj o; o);
+ skip
+end
diff --git a/gcc/testsuite/algol68/compile/upper-1.a68
b/gcc/testsuite/algol68/compile/upper-1.a68
new file mode 100644
index 00000000000..6fb7871301f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/upper-1.a68
@@ -0,0 +1,11 @@
+# { dg-options {-fstropping=upper} } #
+
+BEGIN MODE SOME_MODE = REAL;
+ SOME_MODE some_real := random;
+
+ puts ("Hello time for SUPPER!\n");
+ IF some_real > 0.5
+ THEN puts ("YES\n")
+ ELSE puts ("NO\n")
+ FI
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-1.a68
b/gcc/testsuite/algol68/compile/warning-scope-1.a68
new file mode 100644
index 00000000000..99ae973fe90
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" } #
+
+# Potential scope violation warnings are disabled by default. #
+BEGIN PROC increase = (REF INT i) REF INT:
+ BEGIN INT j := i;
+ j # Inhibited warning. #
+ END;
+ increase (LOC INT)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-2.a68
b/gcc/testsuite/algol68/compile/warning-scope-2.a68
new file mode 100644
index 00000000000..5bbc0b37126
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-2.a68
@@ -0,0 +1,8 @@
+# { dg-options {-Wscope -fstropping=upper} } #
+BEGIN PROC increase = (REF INT i) REF INT:
+ BEGIN
+ INT j := i;
+ j # { dg-warning "scope violation" } #
+ END;
+ increase (LOC INT)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-3.a68
b/gcc/testsuite/algol68/compile/warning-scope-3.a68
new file mode 100644
index 00000000000..c5dd29562c0
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-3.a68
@@ -0,0 +1,3 @@
+# { dg-options {-Wscope -fstropping=upper} } #
+(REF INT xx;
+ xx := (INT x; x := 3)) # { dg-warning "scope violation" } #
diff --git a/gcc/testsuite/algol68/compile/warning-scope-4.a68
b/gcc/testsuite/algol68/compile/warning-scope-4.a68
new file mode 100644
index 00000000000..ae0592ed743
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-4.a68
@@ -0,0 +1,3 @@
+# { dg-options {-Wscope -fstropping=upper} } #
+(REF INT xx;
+ (INT x; xx:= x; x := 3)) # { dg-warning "scope violation" } #
diff --git a/gcc/testsuite/algol68/compile/warning-scope-5.a68
b/gcc/testsuite/algol68/compile/warning-scope-5.a68
new file mode 100644
index 00000000000..2bb5b4afe88
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-5.a68
@@ -0,0 +1,8 @@
+# { dg-options {-Wscope -fstropping=upper} } #
+# The scope violation here is due to the routine text, which is copied
+ to P, referring to a value whose range doesn't exist anymore: X #
+BEGIN (PROC REAL p;
+ (REAL x;
+ p := REAL: x * 2); # { dg-warning "scope violation" } #
+ p)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-6.a68
b/gcc/testsuite/algol68/compile/warning-scope-6.a68
new file mode 100644
index 00000000000..fa3888d6528
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-6.a68
@@ -0,0 +1,6 @@
+# { dg-options {-Wscope -fstropping=upper} } #
+BEGIN (PROC REAL p; REAL mypi := 3.14;
+ (REAL x;
+ p := REAL: mypi * 2); # No scope violation here. #
+ p)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-7.a68
b/gcc/testsuite/algol68/compile/warning-scope-7.a68
new file mode 100644
index 00000000000..b99fa85ddff
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-7.a68
@@ -0,0 +1,12 @@
+# { dg-options {-Wscope -fstropping=upper} } #
+# N,M below represent pairs of insc, outsc #
+BEGIN (INT x;
+ REF INT xx;
+ (REF INT yy;
+ INT y;
+ xx := yy; # 0,0 := 1,0. Dynamic check. #
+ yy := y; # 1,1 := 1,1. OK #
+ xx := y # 0,0 := 1,1. { dg-warning "scope violation" } #
+ )
+ )
+END
diff --git a/gcc/testsuite/algol68/compile/warning-voiding-1.a68
b/gcc/testsuite/algol68/compile/warning-voiding-1.a68
new file mode 100644
index 00000000000..f34787c2979
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-voiding-1.a68
@@ -0,0 +1,5 @@
+# { dg-options {-Wvoiding -fstropping=upper} } #
+BEGIN PROC sum = (INT a, INT b) INT:
+ ( a + b );
+ sum (10, 20) # { dg-warning "will be voided" } #
+END
diff --git a/gcc/testsuite/algol68/compile/warning-voiding-2.a68
b/gcc/testsuite/algol68/compile/warning-voiding-2.a68
new file mode 100644
index 00000000000..e3c98792c91
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-voiding-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" } #
+
+BEGIN PROC sum = (INT a, INT b) INT:
+ ( a + b );
+ sum (10, 20) # Voiding warning won't be emitted by default. #
+END
--
2.30.2
