--- /dev/null
+proc goodbye = (string name) string:
+begin string msg := "Goodbye " + name;
+ msg
+end;
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# PR UPPER PR #
+
+PROC goodbye = (STRING name) STRING:
+BEGIN
+ STRING msg := "Goodbye " + name;
+ msg
+END;
--- /dev/null
+proc hello = (string name) string:
+begin string msg := "Hello " + name;
+ msg
+end;
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# PR UPPER PR #
+
+PROC hello = (STRING name) STRING:
+BEGIN
+ STRING msg := "Hello " + name;
+ msg
+END;
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN []INT a := (1,2,3); # { dg-error "actual bounds expected" } #
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN LOC[]INT a := (1,2,3); # { dg-error "actual bounds expected" } #
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN LOC[]INT a := (1,2,3), # { dg-error "actual bounds expected" } #
+ b := (4);
+ SKIP
+END
--- /dev/null
+mode Word = union (void,real),
+ Rules = union (void,string);
+
+op LEN = (Word w) int: skip,
+LEN = (Rules r) int: skip;
+
+skip
--- /dev/null
+# { dg-options {-fstropping=upper} } #
+# pr UPPER pr #
+BEGIN NOTE This is a
+ NOTE nestable ETON comment in bold style.
+ ETON
+ SKIP
+END
--- /dev/null
+# { dg-options {-std=gnu68 -fstropping=upper} } #
+
+BEGIN MODE FOO_BAR = INT;
+ FOO_BAR foo_bar = 10;
+ SKIP
+END
--- /dev/null
+begin { This is a
+ { nestable } comment in brief style. }
+ skip
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN NOTE This is a
+ { nestable } comment in brief style.
+ ETON
+ SKIP
+END
--- /dev/null
+{ 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)" = replacement_char)
+end
--- /dev/null
+# 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
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT i := 26;
+ IF INT ii = i * 2; ii > 50 THEN
+ ii
+ ELIF i = 10 THEN
+ 100
+ FI
+END
--- /dev/null
+# { dg-options {-std=algol68 -fstropping=upper} } #
+
+BEGIN MODE FOO_BAR = INT; # { dg-error "unworthy" } #
+ FOO_BAR foo_bar = 10;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT a;
+ a := "foo" # { dg-error "cannot be coerced" } #
+END
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+module Foo = def pub int idpublic = 10;
+ int idprivate = 20;
+ skip
+ fed,
+ Bar = def pub int idpublic = 30;
+ int idprivate = 40;
+ xxx { dg-error "" }
+ fed
--- /dev/null
+{ 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
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+# Contracting mixed collateral variable and constant declarations is
+ not allowed.
+#
+(INT foo = 100, bar := 200) # { dg-error "mixed" } #
--- /dev/null
+# { 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
--- /dev/null
+module Foo =
+def skip; { dg-error "fed" }
+ skip
--- /dev/null
+# { 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
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN GOTO end;
+ ASSERT(FALSE);
+end: 0;
+ INT i = 10; # { dg-error "declaration cannot follow" } #
+ i
+END
--- /dev/null
+begin struct (int i, real r) j;
+ j := "joo" { dg-error "char.*struct \\(int i, real r\\)" }
+end
--- /dev/null
+begin long long int j;
+ j := "joo" { dg-error "char.*long long int" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN LONG LONG INT j;
+ j := "joo" { dg-error "CHAR.*LONG LONG INT" }
+END
--- /dev/null
+begin short int j;
+ j := "joo" { dg-error "char.*short int" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN SHORT INT j;
+ j := "joo" { dg-error "CHAR.*SHORT INT" }
+END
--- /dev/null
+begin short short int j;
+ j := "joo" { dg-error "char.*short short int" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN SHORT SHORT INT j;
+ j := "joo" { dg-error "CHAR.*SHORT SHORT INT" }
+END
--- /dev/null
+begin flex[1:0]int j;
+ j := "joo" { dg-error "char.*flex.*int" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN FLEX[1:0]INT j;
+ j := "joo" { dg-error "CHAR.*FLEX.*INT" }
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN STRUCT (INT i, REAL r) j;
+ j := "joo" # { dg-error "CHAR.*STRUCT \\(INT i, REAL r\\)" } #
+END
--- /dev/null
+begin union (int,real) j;
+ j := "joo" { dg-error "char.*union \\( *real *, *int *\\)" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN UNION (INT,REAL) j;
+ j := "joo" { dg-error "CHAR.*UNION \\( *REAL *, *INT *\\)" }
+END
--- /dev/null
+begin proc union (int,real) j;
+ j := "joo" { dg-error "char.*proc union \\( *real *, *int *\\)" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN PROC UNION (INT,REAL) j;
+ j := "joo" { dg-error "CHAR.*PROC UNION \\( *REAL *, *INT *\\)" }
+END
--- /dev/null
+begin long int j;
+ j := "joo" { dg-error "char.*long int" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN LONG INT j;
+ j := "joo" { dg-error "CHAR.*LONG INT" }
+END
--- /dev/null
+{ This test makes sure mode checks are carried
+ over the inside of module texts. }
+module Foo = def
+ skip
+ postlude
+ int i = "foo"; { dg-error "coerced" }
+ skip
+ fed,
+ Bar = def
+ int i = 3.14; { dg-error "coerced" }
+ skip
+ postlude
+ skip
+ fed,
+ Baz = def skip fed
--- /dev/null
+access
+ Foo { dg-error "cannot find module" }
+begin skip end
+
--- /dev/null
+{ Definitions in the def-part of a module text are visible in the
+ postlude-part, but not the other way around. }
+
+module Foo = def int i;
+ x := 20 { dg-error "" }
+ postlude
+ i := 10 { this is ok }
+ fed,
+ Bar = def int x;
+ skip
+ postlude
+ x := 20 { this is ok }
+ fed
--- /dev/null
+# { 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
--- /dev/null
+{ The string in nested comment is in one logical line. }
+begin
+ { puts ("{'n { dg-error {} }
+"); { this prints foo }}
+ skip
+end
--- /dev/null
+# { 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
--- /dev/null
+{ dg-error "unrecognized pragmat" } pr invalid Foo in "module" pr
+
+begin prio // = 8;
+ op (int,int)int // = lala;
+ proc lala = (int a, b) int: a + b;
+ proc void jeje = skip;
+ skip
+end
--- /dev/null
+pr access Foo in pr { dg-error "expected string" }
+
+begin prio // = 8;
+ op (int,int)int // = lala;
+ proc lala = (int a, b) int: a + b;
+ proc void jeje = skip;
+ skip
+end
--- /dev/null
+pr access Foo in "lala" pr
+pr access Foo in "lele" pr { dg-error "multiple" }
+
+begin prio // = 8;
+ op (int,int)int // = lala;
+ proc lala = (int a, b) int: a + b;
+ proc void jeje = skip;
+ skip
+end
--- /dev/null
+{ Publicized varifables cannot go on the stack, for obvious reasons. }
+
+module Foo =
+def
+ pub string xx;
+ pub heap string yy;
+ pub loc string zz; { dg-error "" }
+ loc string vv;
+ skip
+fed
--- /dev/null
+module Foo =
+def pub mode JORL = int;
+ pub proc plus = (int a, b) int: a + b;
+ pub proc vplus := (int a, b) int: a + b;
+ pub loc proc lvplus := (int a, b) int: a + b;
+ pub heap proc hvplus := (int a, b) int: a + b;
+ pub prio // = 8;
+ pub op // = (int a, b) int: a % b;
+ proc invalid = void:
+ (pub mode JI = void; { dg-error "" }
+ skip);
+ skip
+fed
--- /dev/null
+begin pub mode Jorl = void; { dg-error "" }
+ pub proc lala = void: skip; { dg-error "" }
+ pub proc lele := void: skip; { dg-error "" }
+ begin pub prio + = 4; { dg-error "" }
+ skip
+ end;
+ pub op // = (int a, b) int: a % b; { dg-error "" }
+ skip
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN puts ("hello '_ world") # { dg-error "invalid string break sequence" } #
+END
--- /dev/null
+begin puts ("hello '(U0000) world") # { dg-error "eight" } #
+end
--- /dev/null
+begin puts ("hello '(u00) world") # { dg-error "four" } #
+end
--- /dev/null
+begin puts ("hello '(u) world") # { dg-error "four" } #
+end
--- /dev/null
+begin puts ("hello '(u0010u0020) world") # { dg-error "" } #
+end
--- /dev/null
+begin puts ("hello '(u0010'/) world") # { dg-error "" } #
+end
--- /dev/null
+begin puts ("'") # { dg-error "" } #
+end
--- /dev/null
+begin string s =
+ "'(Uf09f94a5)"; { dg-error "Unicode" }
+ skip
+end
--- /dev/null
+begin int j;
+ j := "joo" { dg-error "char.*int" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT j;
+ j := "joo" # { dg-error "CHAR.*INT" } #
+END
--- /dev/null
+begin for i to 10 skip od { dg-error "do" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN FOR i TO 10 SKIP OD # { dg-error "DO" } #
+END
--- /dev/null
+begin if then 10 else 20 fi { dg-error "if" }
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN IF THEN 10 ELSE 20 FI # { dg-error "IF" } #
+END
--- /dev/null
+# { dg-options {-fstropping=upper} } #
+
+begin ~ end # { dg-error "" } #
--- /dev/null
+# { dg-options {-fstropping=supper} } #
+
+begin int foo__bar = 10; # { dg-error "unworthy" } #
+ skip
+end
--- /dev/null
+# { dg-options {-fstropping=supper} } #
+
+begin int _bar = 10; # { dg-error "unworthy" } #
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin int foo bar = 10; { dg-error "" }
+ skip
+end
--- /dev/null
+# { dg-options {-fstropping=supper} } #
+
+begin int foo__ = 10; # { dg-error "unworthy" } #
+ skip
+end
--- /dev/null
+# { dg-options {-fstropping=supper} } #
+
+begin mode foo_Invalid = int; # { dg-error "Invalid" } #
+ foo_Invalid some_int = 10; # { dg-error "Invalid" } #
+ skip
+end
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+# { dg-options {-fstropping=supper} } #
+
+BEGIN ~ END # { dg-error "" } #
--- /dev/null
+begin { dg-error "" }
+end
--- /dev/null
+( { dg-error "" }
+)
--- /dev/null
+begin struct(int i, real r) foo = (); { dg-error "" }
+ skip
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT a := 10;
+ LONG REAL l := a; # { dg-error "coerced" } #
+ l
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT a := 10;
+ LONG INT l := a; # { dg-error "coerced" } #
+ l
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN INT d := 0;
+ INT y := 10;
+ LONG REAL x;
+ 2
+ + (d > 0 | x | # { dg-error "" } #
+ y
+ )
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ INT d := 0;
+ LONG REAL x;
+ 2
+ + (d > 0 | x | # { dg-error "" } #
+ 10
+ )
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG INT d := 0; # { dg-error "coerced" } #
+ d
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG LONG INT d := LONG 0; # { dg-error "coerced" } #
+ d
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG REAL d := 3.14; # { dg-error "coerced" } #
+ d
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ LONG LONG REAL d := LONG 3.14; # { dg-error "coerced" } #
+ d
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN
+ INT d := 0;
+ LONG LONG REAL x;
+ 2
+ + (d > 0 | x | # { dg-error "" } #
+ 10
+ )
+END
--- /dev/null
+{ 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
--- /dev/null
+# { 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
--- /dev/null
+{ 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
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+module Argp =
+def mode ArgOpt = struct (char name, string long_name,
+ bool arg_required, proc(string)bool handler);
+
+ proc argp = (int p, [][]ArgOpt opts,
+ proc(int,string)bool no_opt_handler,
+ proc(string)void error_handler) void:
+ begin
+ proc getopt = (string prefix, string arg) ArgOpt:
+ begin ArgOpt res, bool found := false;
+ for i to UPB opts while NOT found
+ do for j to UPB opts[i] while NOT found
+ do if arg = long_name of opts[i][j]
+ OR (arg /= " " AND arg = name of opts[i][j])
+ then res := opts[i][j]; found := true
+ fi
+ od
+ od;
+ (NOT found | error_handler ("unknown option " + prefix + arg));
+ res
+ end;
+
+ bool found_dash_dash := false,
+ skip_next_opt := false,
+ continue := true;
+
+ for i from p to argc while continue
+ do string arg = argv (i);
+ if skip_next_opt
+ then skip_next_opt := false
+ elif arg = "--" AND NOT found_dash_dash
+ then found_dash_dash := true
+ elif found_dash_dash OR (UPB arg >= 1 andth arg[1] /= "-")
+ then continue := no_opt_handler (i + 1, arg)
+ elif UPB arg > 1 andth arg[2] = "-"
+ then { Long option. It may have an argument. }
+ int eqidx = char_in_string (arg, "=");
+ string optname = (eqidx > 0 | arg[3:eqidx - 1] | arg[3:]),
+ optarg = (eqidx > 0 AND UPB arg >= (eqidx + 1) | arg[eqidx + 1:]);
+ ArgOpt opt = getopt ("--", optname);
+
+ if (arg_required of opt) AND optarg = ""
+ then error_handler ("option --" + arg + " requires an argument") fi;
+ continue := (handler of opt) (optarg)
+ else { This is one or more short options. }
+ for j to UPB arg[2:]
+ do ArgOpt opt = getopt ("-", arg[j + 1]);
+ if arg_required of opt
+ then if i = argc orel (ELEMS argv (i + 1) > 1 andth argv (i + 1)[1] = "-")
+ then error_handler ("option -" + arg[2+j] + " requires an argument")
+ fi;
+ (handler of opt) (argv (i + 1));
+ skip_next_opt := true
+ else continue := (handler of opt) ("")
+ fi
+ od
+ fi
+ od
+ end;
+
+ proc char_in_string = (string s, char c) int:
+ begin int res := 0, bool found := false;
+ for i to UPB s while NOT found
+ do (s[i] = c | res := i; found := true) od;
+ res
+ end;
+
+ skip
+fed
--- /dev/null
+module Foo = def pub int idpublic = 10;
+ int idprivate = 20;
+ pub int varpublic := 100;
+ real varprivate := 3.14;
+ pub proc lala = (int a, b) int: a + b;
+ pub proc lele := (int a, b) int: a - b;
+ skip
+ fed,
+ Bar = def pub int idpublic = 30;
+ int idprivate = 40;
+ pub int varpublic := 100;
+ real varprivate := 3.14;
+ pub proc lala = (int a, b) int: a + b;
+ pub proc lele := (int a, b) int: a - b;
+ skip
+ fed
--- /dev/null
+{ dg-options "-O0 -dA" }
+
+module Foo =
+def pub mode JURL = union (void,int,real);
+ { dg-final { scan-assembler "mode extract FOO_JURL" } }
+ pub proc plus = (int a, b) int: a + b;
+ { dg-final { scan-assembler "identifier extract FOO_plus" } }
+ pub proc vplus := (int a, b) int: a + b;
+ { dg-final { scan-assembler "identifier extract FOO_vplus" } }
+ pub proc lvplus := (int a, b) int: a + b;
+ { dg-final { scan-assembler "identifier extract FOO_lvplus" } }
+ pub heap proc hvplus := (int a, b) int: a + b;
+ { dg-final { scan-assembler "identifier extract FOO_hvplus" } }
+ pub proc(int,int)int vplus2 = vplus;
+ { dg-final { scan-assembler "identifier extract FOO_vplus2" } }
+ pub proc(int,int)int lvplus2 := lvplus;
+ { dg-final { scan-assembler "identifier extract FOO_lvplus2" } }
+ pub heap proc(int,int)int hvplus2 := hvplus;
+ { dg-final { scan-assembler "identifier extract FOO_hvplus2" } }
+ pub int i;
+ { dg-final { scan-assembler "identifier extract FOO_i" } }
+ int k = 10;
+ { dg-final { scan-assembler-not "identifier extract FOO_k" } }
+ pub prio // = 8;
+ { dg-final { scan-assembler "operator extract FOO_s_s_\[0-9\]+" } }
+ pub op // = (int a, b) int: a % b;
+ { dg-final { scan-assembler "operator extract FOO_s_s_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyInt = int;
+ pub mode MyLongInt = long int;
+ pub mode MyLongLongInt = long long int;
+ pub mode MyShortInt = short int;
+ pub mode MyShortShortInt = short short int;
+ skip
+fed
+
+{ GA68_MODE_INT = 2UB }
+
+{ dg-final { scan-assembler-times "2\[\t ]+\[^0-9\]+int" 5 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0xff\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0xfe\[\t \]+\[^\n\]*sizety" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyReal = real;
+ pub mode MyLongReal = long real;
+ pub mode MyLongLongReal = long long real;
+ skip
+fed
+
+{ GA68_MODE_REAL = 3UB }
+
+{ dg-final { scan-assembler-times "\[\t \]+0x3\[\t \]+\[^\n\]*real" 3 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyString = string;
+ skip
+fed
+
+{ GA68_MODE_STRING = 14UB }
+
+{ dg-final { scan-assembler-times "\[\t \]+0xe\[\t \]+\[^\n\]*string" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyChar = char;
+ skip
+fed
+
+{ GA68_MODE_CHAR = 6UB }
+
+{ dg-final { scan-assembler-times "\[\t \]+0x6\[\t \]+\[^\n\]*char" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyBits = bits;
+ pub mode MyLongBits = long bits;
+ pub mode MyLongLongBits = long long bits;
+ pub mode MyShortBits = short bits;
+ pub mode MyShortShortBits = short short bits;
+ skip
+fed
+
+{ GA68_MODE_BITS = 4UB }
+
+{ dg-final { scan-assembler-times "4\[\t ]+\[^0-9\]+bits" 5 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0xff\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0xfe\[\t \]+\[^\n\]*sizety" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyBool = bool;
+ pub mode MyVoid = void;
+ skip
+fed
+
+{ GA68_MODE_BOOL = 7UB
+ GA68_MODE_VOID = 1UB }
+
+{ dg-final { scan-assembler-times "7\[\t ]+\[^0-9\]+bool" 1 } }
+{ dg-final { scan-assembler-times "1\[\t ]+\[^0-9\]+void" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyName = ref int;
+ skip
+fed
+
+{ GA68_MODE_NAME = 12UB }
+
+{ dg-final { scan-assembler-times "0xc\[\t ]+\[^0-9\]+ref" 1 } }
+{ dg-final { scan-assembler-times "0x2\[\t ]+\[^0-9\]+int" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyCompl = compl;
+ pub mode MyLongCompl = long compl;
+ pub mode MyLongLongCompl = long long compl;
+ skip
+fed
+
+{ GA68_MODE_CMPL = 8UB }
+
+{ dg-final { scan-assembler-times "0x8\[\t ]+\[^0-9\]+compl" 3 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x2\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0x1\[\t \]+\[^\n\]*sizety" 1 } }
+{ dg-final { scan-assembler-times "\[\t \]+0\[\t \]+\[^\n\]*sizety" 1 } }
--- /dev/null
+{ dg-options "-dA" }
+
+{ Test for mode table in module definition exports. }
+
+module Foo =
+def pub mode MyProc = proc void;
+ skip
+fed
+
+{ GA68_MODE_CMPL = 8UB }
+
+{ dg-final { scan-assembler-times "0xd\[\t ]+\[^0-9\]+proc" 1 } }
--- /dev/null
+module Foo =
+def pub mode JORL = int, JURL = union (void,int,real);
+ pub proc plus = (int a, b) int: a + b;
+ pub proc vplus := (int a, b) int: a + b;
+ pub proc lvplus := (int a, b) int: a + b;
+ pub heap proc hvplus := (int a, b) int: a + b;
+ pub proc(int,int)int vplus2 = vplus;
+ pub proc(int,int)int lvplus2 := lvplus;
+ pub heap proc(int,int)int hvplus2 := hvplus;
+ pub int i, x, y;
+ pub int k = 10;
+ pub int j := 20;
+ pub prio // = 8;
+ pub op // = (int a, b) int: a % b;
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+module Foo = def pub int foo; { dg-final { scan-assembler "FOO_foo" } }
+ int bar; { dg-final { scan-assembler "FOO_bar" } }
+ skip
+ fed,
+ Bar = def pub int foo; { dg-final { scan-assembler "BAR_foo" } }
+ int bar; { dg-final { scan-assembler "BAR_bar" } }
+ skip
+ fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
+{ dg-final { scan-assembler "BAR__prelude" } }
+{ dg-final { scan-assembler "BAR__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio + = 9;
+ op + = (int a, b) int: skip; { dg-final { scan-assembler "FOO_u_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio - = 9;
+ op - = (int a, b) int: skip; { dg-final { scan-assembler "FOO_m_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio % = 9;
+ op % = (int a, b) int: skip; { dg-final { scan-assembler "FOO_p_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio ^ = 9;
+ op ^ = (int a, b) int: skip; { dg-final { scan-assembler "FOO_c_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio & = 9;
+ op & = (int a, b) int: skip; { dg-final { scan-assembler "FOO_a_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio ~ = 9;
+ op ~ = (int a, b) int: skip; { dg-final { scan-assembler "FOO_t_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio ! = 9;
+ op ! = (int a, b) int: skip; { dg-final { scan-assembler "FOO_b_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio ? = 9;
+ op ? = (int a, b) int: skip; { dg-final { scan-assembler "FOO_q_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio > = 9;
+ op > = (int a, b) int: skip; { dg-final { scan-assembler "FOO_g_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio < = 9;
+ op < = (int a, b) int: skip; { dg-final { scan-assembler "FOO_l_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+module Foo = def pub struct (int i, real r) foo;{ dg-final { scan-assembler "FOO_foo" } }
+ struct (int i, real r) bar; { dg-final { scan-assembler "FOO_bar" } }
+ skip
+ fed,
+ Bar = def pub struct (int i, real r) foo;{ dg-final { scan-assembler "BAR_foo" } }
+ struct (int i, real r) bar; { dg-final { scan-assembler "BAR_bar" } }
+ skip
+ fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
+{ dg-final { scan-assembler "BAR__prelude" } }
+{ dg-final { scan-assembler "BAR__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio / = 9;
+ op / = (int a, b) int: skip; { dg-final { scan-assembler "FOO_s_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio = = 9;
+ op = = (int a, b) int: skip; { dg-final { scan-assembler "FOO_e_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+{ Mangling of monads, nomads and :
+ Unfortunately we cannot do all of them in a single test. }
+
+module Foo =
+def prio +:= = 9;
+ op +:= = (int a, b) int: skip; { dg-final { scan-assembler "FOO_u_o_e_\[0-9\]+" } }
+ skip
+fed
--- /dev/null
+{ dg-options "-O0" }
+
+module Foo = def pub int foo = 10; { dg-final { scan-assembler "FOO_foo" } }
+ int bar = 20; { dg-final { scan-assembler "FOO_bar" } }
+ skip
+ fed,
+ Bar = def pub int foo = 30; { dg-final { scan-assembler "BAR_foo" } }
+ int bar = 40; { dg-final { scan-assembler "BAR_bar" } }
+ skip
+ fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
+{ dg-final { scan-assembler "BAR__prelude" } }
+{ dg-final { scan-assembler "BAR__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Procedure variable declarations. }
+
+module Foo = def pub proc int foo; { dg-final { scan-assembler "FOO_foo" } }
+ proc int bar := int: skip; { dg-final { scan-assembler "FOO_bar" } }
+ skip
+ fed,
+ Bar = def pub proc int foo; { dg-final { scan-assembler "BAR_foo" } }
+ proc int bar := foo; { dg-final { scan-assembler "BAR_bar" } }
+ skip
+ fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
+{ dg-final { scan-assembler "BAR__prelude" } }
+{ dg-final { scan-assembler "BAR__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Procedure identity declarations. }
+
+module Foo = def pub proc foo = int: skip; { dg-final { scan-assembler "FOO_foo" } }
+ proc bar = int: skip; { dg-final { scan-assembler "FOO_bar" } }
+ skip
+ fed,
+ Bar = def pub proc foo = int: skip; { dg-final { scan-assembler "BAR_foo" } }
+ proc bar = int: skip; { dg-final { scan-assembler "BAR_bar" } }
+ skip
+ fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
+{ dg-final { scan-assembler "BAR__prelude" } }
+{ dg-final { scan-assembler "BAR__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Operator brief identity declarations. }
+
+module Foo = def pub op + = (int a, b) int: a + b;
+ { dg-final { scan-assembler "FOO_u_" } }
+ op - = (int a, b) int: a - b;
+ { dg-final { scan-assembler "FOO_m_" } }
+ skip
+ fed,
+ Bar = def pub op + = (int a, b) int: a + b;
+ { dg-final { scan-assembler "BAR_u_" } }
+ op - = (int a, b) int: a - b;
+ { dg-final { scan-assembler "BAR_m_" } }
+ skip
+ fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
+{ dg-final { scan-assembler "BAR__prelude" } }
+{ dg-final { scan-assembler "BAR__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Operator identity declarations. }
+
+module Foo =
+def prio // = 8;
+ pub op(int,int)int // = lala;
+ { dg-final { scan-assembler "FOO_s_s_" } }
+ proc lala = (int a, b) int: a + b;
+ prio JORL = 8, JURL = 9;
+ pub op(int,int)int JORL = lala;
+ { dg-final { scan-assembler "FOO_JORL" } }
+ op(int,int)int JURL = (int a, b) int: a - b;
+ { dg-final { scan-assembler "FOO_JORL" } }
+ skip
+fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Symbols that should _not_ include the module name. }
+
+module Foo =
+def begin string foo = "foo'n"; { dg-final { scan-assembler-not "FOO_foo" } }
+ proc printfoo = void: puts (foo); { dg-final { scan-assembler-not "FOO_printfoo" } }
+ printfoo
+ end;
+ skip
+postlude
+ int lala;
+ proc incrlala = void: lala +:= 1; { dg-final { scan-assembler-not "FOO_incrlala" } }
+ incrlala
+fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
--- /dev/null
+{ dg-options "-O0" }
+
+{ Operator symbols are numbered so having overloaded symbols in the
+ module's public range works. }
+
+module Foo =
+def prio // =9;
+ op // = (int a, b) int: a + b; { dg-final { scan-assembler "FOO_s_s_\[0-9\]+" } }
+ op // = (real a, b) real: a + b; { dg-final { scan-assembler "FOO_s_s_\[0-9\]+" } }
+ skip
+fed
+
+{ dg-final { scan-assembler "FOO__prelude" } }
+{ dg-final { scan-assembler "FOO__postlude" } }
--- /dev/null
+{ This test is to check that serial clauses and
+ enquiry clauses are properly skipped in module texts. }
+module Foo =
+def int i;
+ int j = 20;
+ string ss;
+ prio // = 8;
+ op // = (int a, b) int: a + b;
+ proc ticks = void: to i do puts ("tick'n") od;
+ i := 5
+postlude
+ if j > 5 then ticks fi;
+ (j < 0 | puts ("error'n") | puts ("success'n"))
+fed
--- /dev/null
+# 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
+
+# The programs need to be able to find the built modules, which are
+# left in objdir.
+
+global MODULES_OPTIONS
+set MODULES_OPTIONS "-I $objdir"
+
+# 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/program*.a68]] "" ""
+set dg-do-what-default ${saved-dg-do-what-default}
+
+# All done.
+dg-finish
--- /dev/null
+module Module1 =
+def
+ pub mode MyInt = int;
+ pub int beast_number := 666;
+ pub string who = "jemarch";
+ puts ("Hello from module'n")
+postlude
+ puts ("Bye from module'n")
+fed
--- /dev/null
+module Module2 =
+def prio // = 9; { Note priority is not publicized. }
+ pub op // = (int a, b) int: a + b;
+ skip
+fed
--- /dev/null
+module Module_3 =
+def pub proc foo = (int i, string s) void: skip;
+ pub mode Jorl = struct (int i, string s);
+ pub mode Jurl = union (int, string, real);
+ skip
+fed
--- /dev/null
+module Module_4 =
+def access Module_3 (foo (10, "foo"));
+ skip
+fed
--- /dev/null
+module Module_5 =
+def
+ pub mode JSON_Val = union (ref JSON_Elm,int),
+ JSON_Elm = struct (int lala);
+ skip
+fed
--- /dev/null
+module Module6 =
+ access Module5
+def pub proc getval = JSON_VAl: skip;
+ skip
+fed
--- /dev/null
+module Module7 =
+access Module5, Module6
+def pub JSON_Val val = getval;
+ skip
+fed
--- /dev/null
+module Module_8 =
+def
+ pub proc lala = ([]struct (string n, v) arg) void: skip;
+ skip
+fed
--- /dev/null
+module Module_9 =
+def
+ pub mode Foo = struct (flex[1:0]Event events);
+ pub mode Event = int;
+ skip
+fed
--- /dev/null
+{ dg-modules "module5 module6 module7" }
+
+access Module7 (skip)
--- /dev/null
+{ dg-modules "module8" }
+
+access Module_8 ( lala ((("foo", "bar"), ("baz", "quux"))) )
--- /dev/null
+{ dg-modules "module9" }
+
+access Module_9 (skip)
--- /dev/null
+{ dg-modules "module2" }
+
+access Module_2
+begin assert (2 // 3 = 5); { dg-error "no priority" }
+ skip
+end
--- /dev/null
+{ dg-modules "module1" }
+
+begin int x = access Module1 ( beast_number ),
+ y = beast_number; { dg-error "declared" }
+ skip
+end
--- /dev/null
+{ dg-modules "module3 module4" }
+{ This test accesses a Module4 that itself accesses a Module3. }
+
+access Module_4 (skip)
+
--- /dev/null
+{ dg-modules "module3" }
+
+access Module_3
+begin foo (10, "foo");
+ Jorl x = (10, "foo");
+ Jurl y = 3.14;
+ skip
+end
--- /dev/null
+{ Comment delimiters within strings get ignored. }
+begin { puts { ("{""'n"); } }
+ skip
+end
--- /dev/null
+{ The string in nested comment is in one logical line. }
+begin
+ { puts ("{'n\
+"); { this prints foo }}
+ skip
+end
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+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
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+{ 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
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+ BEGIN some_int = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+ BEGIN some_int = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin for i while i < 10
+ do puts ("lala\n")
+ od
+end
--- /dev/null
+{ dg-options "-fstropping=supper" }
+
+{ mode_ should not be recognized as a symbol. }
+
+begin int mode_ = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin int foo_bar = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin int foo_bar_ = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin int foo_ = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin mode Foo_bar = int;
+ Foo_bar some_int = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin go to done;
+done: skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin goto done;
+done: skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin mode Int = int;
+ Int some_int = 10;
+ skip
+end
--- /dev/null
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+ BEGIN some_int = 10;
+ skip
+end
--- /dev/null
+{ 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
--- /dev/null
+# { 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
--- /dev/null
+{ dg-options "-Whidden-declarations" }
+begin
+ op UPB = (union (int,string) v) int: { dg-warning "hides" }
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+end
--- /dev/null
+{ dg-options "-Whidden-declarations" }
+begin
+ op UPB = (union ([]int,string) v) int: { dg-warning "hides" }
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+end
--- /dev/null
+{ dg-options "-Whidden-declarations" }
+begin op UPB = (union (int,union(string,real)) v) int: { dg-warning "hides" }
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+end
--- /dev/null
+{ dg-options "-Whidden-declarations" }
+begin
+ op UPB = (int i, union (int,string) v) int: { dg-warning "hides" }
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+end
--- /dev/null
+{ dg-options "-Whidden-declarations=none" }
+begin real b;
+ begin int getchar = 10;
+ int b;
+ op UPB = (int i, union (int,string) v) int:
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+ end
+end
--- /dev/null
+{ dg-options "-Whidden-declarations=prelude" }
+begin real b;
+ begin int getchar = 10; { dg-warning "hides" }
+ int b;
+ op UPB = (int i, union (int,string) v) int: { dg-warning "hides" }
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+ end
+end
--- /dev/null
+{ dg-options "-Whidden-declarations=all" }
+begin real b;
+ begin int getchar = 10; { dg-warning "hides" }
+ int b; { dg-warning "hides" }
+ op UPB = (int i, union (int,string) v) int: { dg-warning "hides" }
+ (v | (string s): UPB s | 0);
+ UPB "lala"
+ end
+end
--- /dev/null
+{ dg-options "-Whidden-declarations=all" }
+
+module Foo = def int i; i := 10 postlude puts ("bye foo'n") fed,
+ Bar = def int j; j := 20
+ postlude int j; puts ("bye bar'n") fed, { dg-warning "hidden" }
+ Baz = def skip fed
--- /dev/null
+module Foo =
+def pub ref int xx = loc int := 777; { dg-warning "" }
+ pub ref int yy;
+ pub ref int zz = heap int := 888;
+ ref int vv = loc int := 999;
+ skip
+fed
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+# { dg-options {-Wscope -fstropping=upper} } #
+(REF INT xx;
+ xx := (INT x; x := 3)) # { dg-warning "scope violation" } #
--- /dev/null
+# { dg-options {-Wscope -fstropping=upper} } #
+(REF INT xx;
+ (INT x; xx:= x; x := 3)) # { dg-warning "scope violation" } #
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+# { 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
--- /dev/null
+# { dg-options {-Wvoiding -fstropping=upper} } #
+BEGIN PROC sum = (INT a, INT b) INT:
+ ( a + b );
+ sum (10, 20) # { dg-warning "will be voided" } #
+END
--- /dev/null
+# { 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
projects / thirdparty / gcc.git / commitdiff
