--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# ABS for SIZETY BITS #
+BEGIN ASSERT (255 = ABS 16rff);
+ ASSERT (LONG 255 = ABS LONG 16rff);
+ ASSERT (LONG LONG 255 = ABS LONG LONG 16rff)
+ # XXX test ABS of negative numbers (extension). #
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (ABS TRUE /= 0);
+ ASSERT (ABS FALSE = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (ABS "a" = 97)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (ABS 10 = 10);
+ ASSERT (ABS -10 = 10);
+ ASSERT (ABS SHORT 10 = SHORT 10);
+ ASSERT (ABS - SHORT 10 = SHORT 10);
+ ASSERT (ABS - SHORT SHORT 10 = SHORT SHORT 10);
+ ASSERT (ABS LONG 10 = LONG 10);
+ ASSERT (ABS - LONG 10 = LONG 10);
+ ASSERT (ABS - LONG LONG 10 = LONG LONG 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper -std=algol68" } #
+BEGIN SHORT SHORT BITS b = BIN - SHORT SHORT 2;
+ ASSERT (ABS b = SHORT SHORT INT (SKIP))
+END
--- /dev/null
+# { dg-options "-fstropping=upper -std=gnu68" } #
+BEGIN SHORT SHORT BITS b = BIN - SHORT SHORT 2;
+ ASSERT (ABS b = - SHORT SHORT 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r = 1.0;
+ LONG REAL rr = LONG 45.0;
+ LONG LONG REAL rrr = LONG LONG 60.0;
+ ASSERT (arccos (r) = 0.0);
+ long arccos (rr);
+ long long arccos (rrr)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = 10;
+ LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+ SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+ ASSERT (+i = 10);
+ ASSERT (+ii = LONG 10);
+ ASSERT (+iii = LONG LONG 10);
+ ASSERT (+ss = SHORT 10);
+ ASSERT (+sss = SHORT SHORT 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# AND for SIZETY BITS. #
+BEGIN BITS b = 16r0f0f0;
+ ASSERT ((b AND 16r0f0f) = 16r0);
+ ASSERT ((b AND 16r00ff) = 16rf0);
+ LONG BITS bb = LONG 16r0f0f0;
+ ASSERT ((bb AND LONG 16r0f0f) = LONG 16r0);
+ ASSERT ((bb AND LONG 16r00ff) = LONG 16rf0);
+ LONG LONG BITS bbb = LONG LONG 16r0f0f0;
+ ASSERT ((bbb AND LONG LONG 16r0f0f) = LONG LONG 16r0);
+ ASSERT ((bbb AND LONG LONG 16r00ff) = LONG LONG 16rf0);
+ SHORT BITS ss = SHORT 16r0f0f0;
+ ASSERT ((ss AND SHORT 16r0f0f) = SHORT 16r0);
+ ASSERT ((ss AND SHORT 16r00ff) = SHORT 16rf0);
+ SHORT SHORT BITS sss = SHORT SHORT 16r0f0f0;
+ ASSERT ((sss AND SHORT SHORT 16r0f0f) = SHORT SHORT 16r0);
+ ASSERT ((sss AND SHORT SHORT 16r00ff) = SHORT SHORT 16rf0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 10;
+ ASSERT (i /= 0 ANDTH i = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Make sure structs are copied when ascribed. #
+BEGIN MODE BAR = STRUCT (INT j, REAL r);
+ MODE FOO = STRUCT (INT i, BAR bar);
+
+ FOO f1 := (10, (20, 3.14));
+ FOO f2 = f1;
+
+ j OF bar OF f1 := 200;
+ ASSERT (j OF bar OF f1 = 200);
+ ASSERT (j OF bar OF f2 = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r = 0.0;
+ LONG REAL rr = LONG 45.0;
+ LONG LONG REAL rrr = LONG LONG 60.0;
+ ASSERT (arcsin (r) = 0.0);
+ long arcsin (rr);
+ long long arcsin (rrr)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (TRUE)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN CHAR c;
+ c := "x";
+ ASSERT (c = "x")
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i;
+ i := 20;
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN x := 100;
+ INT x;
+ ASSERT (x = 100)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REF INT j = LOC INT;
+ INT i;
+ i := j := 20;
+ ASSERT (i + j = 40)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REF INT xx;
+ INT x := 10;
+ ASSERT ((xx := (x)) = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx := x;
+ x := 20;
+ ASSERT ((xx := (INT j; x)) = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN STRUCT ([2:3]INT m, [1:5]REAL g) s;
+ g OF s:= (1.0, 2.0, 3.0, 4.0, 5.0)
+END
--- /dev/null
+begin [5]struct(char i, real r) foo;
+
+ { The stride in the single dimension of the multiple resulting
+ from the selection is not the size of a 'char'. }
+ i of foo := ("a","b","c","d","e");
+ puts ((i of foo) + "'n");
+ { Via indexing then selection. }
+ assert (i of foo[1] = "a");
+ assert (i of foo[2] = "b");
+ assert (i of foo[3] = "c");
+ assert (i of foo[4] = "d");
+ assert (i of foo[5] = "e");
+ { Via selection of multiple. }
+ assert (i of foo = "abcde");
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE NODE = STRUCT (INT one, two, three);
+ NODE top;
+ top := (10,20,30);
+ ASSERT (two OF top = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Struct containing a multiple, which must be copied when
+ the struct value is assigned. #
+BEGIN MODE FOO = STRUCT (STRING s, INT i);
+ FOO f1;
+ f1 := ("foo", 10);
+ ASSERT (i OF f1 = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r = 0.0;
+ LONG REAL rr = LONG 45.0;
+ LONG LONG REAL rrr = LONG LONG 60.0;
+ ASSERT (arctan (r) = 0.0);
+ long arctan (rr);
+ long long arctan (rrr)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL x, y;
+ REF REAL xx, yy;
+ xx := yy := x;
+
+ ASSERT (xx :=: x);
+ ASSERT (x :=: xx);
+ ASSERT (xx :/=: yy);
+ ASSERT (REF REAL (xx) :=: yy);
+ ASSERT (xx :=: REF REAL (yy));
+ ASSERT (REF REAL (xx) :=: REF REAL (yy))
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (UPB IF FALSE THEN []INT (1) ELSE [,]REAL (1) FI = 1);
+ ASSERT (2 UPB CASE 2 IN []INT (1), [,]REAL (1) ESAC = 1)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# BIN for SIZETY INTs #
+BEGIN ASSERT (BIN 255 = 16rff);
+ ASSERT (BIN LONG 255 = LONG 16rff);
+ ASSERT (BIN LONG LONG 255 = LONG LONG 16rff)
+END
--- /dev/null
+# { dg-options "-fstropping=upper -std=algol68" } #
+BEGIN ASSERT (BIN - SHORT SHORT 2 = SHORT SHORT 2r0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper -std=gnu68" } #
+BEGIN ASSERT (BIN - SHORT SHORT 2 = SHORT SHORT 2r11111110)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN BOOL t := TRUE;
+ BOOL f := FALSE;
+ ASSERT (NOT t = FALSE);
+ ASSERT (~t = FALSE);
+ ASSERT ((t AND t) = TRUE);
+ ASSERT ((t AND f) = FALSE);
+ ASSERT ((f AND f) = FALSE);
+ ASSERT ((f AND t) = FALSE);
+ ASSERT ((t OR t) = TRUE);
+ ASSERT ((t OR f) = TRUE);
+ ASSERT ((f OR f) = FALSE);
+ ASSERT ((f OR t) = TRUE);
+ ASSERT ((t XOR t) = FALSE);
+ ASSERT ((t XOR f) = TRUE);
+ ASSERT ((f XOR f) = FALSE);
+ ASSERT ((f XOR t) = TRUE)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Calling a procedure that gets a row of united values. #
+BEGIN INT num ints := 0, num reals := 0, num strings := 0;
+ PROC foo = ([]UNION(INT,REAL,STRING) d) VOID:
+ BEGIN FOR i TO UPB d
+ DO CASE d[i]
+ IN (STRING): num strings +:= 1,
+ (INT): num ints +:= 1,
+ (REAL): num reals +:= 1
+ ESAC
+ OD
+ END;
+ foo (());
+ foo (10);
+ ASSERT (num ints = 1 AND num reals = 0 AND num strings = 0);
+ num ints := 0;
+ foo (("baz", 1, 3.14, 2, 0.0, "foo"));
+ ASSERT (num ints = 2 AND num reals = 2 AND num strings = 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT control := 0;
+ PROC set control = (PROC(INT)VOID p) VOID: p (100);
+ PROC setter = (INT i) VOID: control := i;
+ PROC(INT)VOID setter 2 = (INT i) VOID: control := i + 1;
+ PROC(INT)VOID setter 3 := setter 2;
+ PROC(INT)VOID setter 4 := (INT i) VOID: control := i + 2;
+ REF PROC(INT)VOID setter 5 := setter 4;
+ set control (setter);
+ ASSERT (control = 100);
+ set control (setter 2);
+ ASSERT (control = 101);
+ control := 0;
+ set control (setter 3);
+ ASSERT (control = 101);
+ set control (setter 4);
+ ASSERT (control = 102);
+ control := 0;
+ set control (setter 5);
+ ASSERT (control = 102)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT j := 1;
+ ASSERT ((j|10,20,30|40) = 10);
+ j := 2;
+ ASSERT ((j|10,20,30|40) = 20);
+ j := 3;
+ ASSERT ((j|10,20,30|40) = 30);
+ j := 100;
+ ASSERT ((j|10,20,30|40) = 40)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 2;
+ ASSERT (CASE INT x = 10; i
+ IN x + 1,
+ x + 2,
+ x + 3
+ ESAC = 12)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT days, INT month = 2, year = 2024;
+ days := CASE month
+ IN 31, (year MOD 4 = 0 AND year MOD 100 /= 0 OR year MOD 400 = 0 | 29 | 28),
+ 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ESAC;
+ ASSERT (days = 29)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT day = 3;
+ STRING day name = (day | "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", "FRIDAY", "SATURDAY", "SUNDAY");
+ ASSERT (day name[1] = "W")
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL pie, my small real := 0.001;
+ PROC my sqrt = (REAL r) REAL: r;
+ BEGIN REAL w := 0, INT i := 1, REAL z = my sqrt (my small real / 2);
+ loop: w := w + 2 / (i * (i + 2));
+ i := i + 4;
+ IF 1/i > z THEN GO TO loop FI;
+ pie := 4 * w
+ END
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL my small real := 0.001;
+ PROC my sqrt = (REAL r) REAL: r;
+ REAL res = 4 * (REAL w := 0, INT i := 1; REAL z = my sqrt (my small real / 2);
+ loop: w := w + 2/(i * (i + 2)); i := i + 4;
+ IF 1/i > z THEN loop FI;
+ w);
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 10;
+ (i, i + 1, i + 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 10;
+ (
+ BEGIN
+ (i + 1, i +:= 1, i + 2)
+ END
+ );
+ ASSERT (i = 11)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 10;
+ (
+ i +:= 1;
+ BEGIN
+ (i + 1, (i +:= 1, i + 10, i + 11, SKIP), i + 2)
+ END;
+ i +:= i
+ );
+ ASSERT (i = 24)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN (SKIP,SKIP)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x, y, z;
+ (x := 1, y := 2, z := 3);
+ ASSERT (x = 1 AND y = 2 AND z = 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i;
+ PROC side = INT: (i := 1; i := 2; i);
+ PROC add = (INT ii, INT jj) INT: ii + jj;
+ INT res = add (side, side);
+ # can be 3 or 4 due to collateral evaluation of arguments. #
+ ASSERT (res = 3 OR res = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i;
+ BEGIN (i := 20 EXIT
+cont: i := 30
+ );
+ i +:= 1
+ END;
+ ASSERT (i = 21)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 20;
+ REF INT xx := x;
+ REF REF INT xxx;
+ REF INT i := (x := 10; xxx := xx EXIT foo: xxx EXIT bar: xxx := xx);
+ ASSERT (i = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = (foo;
+ 10 EXIT
+foo: 20 EXIT
+bar: 30);
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = ((((foo; 10 EXIT foo: 20 EXIT bar: 30))));
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := (foo; 10 EXIT foo: 20 EXIT bar: 30);
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x;
+ REF INT i := (foo; x := 10 EXIT foo: x := 20 EXIT bar: x := 30);
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 20;
+ REF INT i := (foo; x := 10 EXIT foo: x EXIT bar: x := 30);
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 20;
+ REF INT i := (x := 10 EXIT foo: x EXIT bar: x := 30);
+ ASSERT (i = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 20;
+ REF INT i := (x EXIT foo: x EXIT bar: x := 30);
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 20;
+ REF INT xx := x;
+ REF INT i := (xx EXIT foo: xx EXIT bar: xx := x);
+ ASSERT (i = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 10, x;
+ IF i > 5 THEN x := i FI;
+ ASSERT (x = i)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 10, x;
+ IF i < 5 THEN x = i FI;
+ ASSERT (x /= i)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 5;
+ IF i = 5
+ THEN 0
+ ELSE ASSERT (FALSE); 1
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Declarations in enquiry clause. #
+(INT i; i := 3 ; i := 2; i /= i | ASSERT (FALSE); 1 | 0)
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Closed clauses in enquiry clause. #
+((INT i; (i := 3 ; i := 2); ((i /= i))) | ASSERT (FALSE); 1 | 0)
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Nested conditional clauses #
+BEGIN
+ INT i = 10;
+ IF i > 5 THEN
+ IF i < 15 THEN
+ IF i > 11 THEN
+ ASSERT (FALSE);
+ 1
+ ELSE
+ 0
+ FI
+ FI
+ ELSE
+ IF i > 100 THEN
+ ASSERT (FALSE);
+ 1
+ ELSE
+ ASSERT (FALSE);
+ 1
+ FI
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Nested conditional clauses #
+BEGIN
+ INT i = 12;
+ IF i > 5 THEN
+ IF i < 15 THEN
+ IF i > 11 THEN
+ 0
+ ELSE
+ ASSERT (FALSE);
+ 1
+ FI
+ FI
+ ELSE
+ IF i > 100 THEN
+ ASSERT (FALSE);
+ 1
+ ELSE
+ ASSERT (FALSE);
+ 1
+ FI
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# ELIF #
+BEGIN
+ INT i = 12;
+ IF i > 20 THEN
+ 1
+ ELIF i > 5 THEN
+ BEGIN
+ IF FALSE THEN
+ ASSERT (FALSE);
+ 1
+ ELSE
+ 0
+ FI
+ END
+ ELIF i < 10 THEN
+ ASSERT (FALSE);
+ 1
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# ELIF with ELSE #
+BEGIN
+ INT i = 12;
+ IF i > 20 THEN
+ 1
+ ELIF i > 12 THEN
+ BEGIN
+ IF FALSE THEN
+ ASSERT (FALSE);
+ 1
+ ELSE
+ ASSERT (FALSE);
+ 1
+ FI
+ END
+ ELIF i < 10 THEN
+ ASSERT (FALSE);
+ 1
+ ELSE
+ 0
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE DATUM = UNION(INT,REAL,CHAR);
+ DATUM datum := 10;
+ INT i = CASE datum
+ IN (REAL): 2,
+ (INT i): i + 1,
+ (CHAR): 3
+ ESAC;
+ ASSERT (i = 11)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE DATUM = UNION(INT,REAL,CHAR);
+ DATUM datum := "X";
+ INT i = CASE datum
+ IN (REAL): 2,
+ (INT val): val + 1
+ OUT INT x = 100;
+ x + 10
+ ESAC;
+ ASSERT (i = 110)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE DATUM = UNION(INT,REAL,CHAR);
+ DATUM datum := 20;
+ INT i = CASE INT i = 10; datum
+ IN (REAL): 2,
+ (INT val): val + i
+ OUT INT x = 100;
+ x + 10
+ ESAC;
+ ASSERT (i = 30)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN []UNION(INT,STRING,REAL) datum = (10, 3.14, "foo", 200);
+ ASSERT (CASE datum[1] IN (INT): 100 ESAC = 100);
+ ASSERT (CASE datum[2] IN (REAL): 200 ESAC = 200);
+ ASSERT (CASE datum[3] IN (STRING): 300 ESAC = 300);
+ ASSERT (CASE datum[4] IN (INT): 400 ESAC = 400)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN UNION(CHAR,BOOL,INT,REAL) cbira := "X";
+ IF CASE cbira
+ IN (BOOL b): b,
+ (INT i): i > 0,
+ (REAL r): r > 0
+ OUT FALSE
+ ESAC
+ THEN # We get here if cbira was not a CHAR and was otherwise
+ TRUE or >0, as the case may be.
+ #
+ ASSERT (FALSE)
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN UNION (CHAR,BOOL,REAL) cbra = 3.14, UNION (INT,REAL) ira = 10;
+ IF (cbra | (CHAR): FALSE, (BOOL b): b
+ |: ira | (INT i): i > 0, (REAL r): r > 0)
+ THEN SKIP
+ ELSE ASSERT (FALSE)
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN UNION (CHAR,BOOL,REAL) cbra = 3.14, UNION (INT,REAL) ira = -10;
+ IF (cbra | (CHAR): FALSE, (BOOL b): b
+ |: ira | (INT i): i > 0, (REAL r): r > 0)
+ THEN ASSERT (FALSE)
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE JORL = STRUCT (UNION(INT,REAL) i, REF JORL next);
+ REF JORL p := HEAP JORL := (10, HEAP JORL := (20.0, NIL));
+ p := HEAP JORL := (30, p);
+ INT num ints := 0, num reals := 0;
+ WHILE REF JORL (p) ISNT NIL
+ DO CASE i OF p IN (INT): num ints +:= 1, (REAL): num reals +:= 1 ESAC;
+ p := next OF p
+ OD;
+ ASSERT (num ints = 2 AND num reals = 1)
+END
--- /dev/null
+begin union (int, bool, string) foo = 666;
+ case foo
+ in (union(int,string) bar):
+ case bar
+ in (int i): assert (i = 666),
+ (string s): assert (false)
+ esac,
+ (bool baz): assert (false)
+ esac
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN COMPL z = 4.0I5.0;
+ CONJ z;
+ LONG COMPL zz = LONG 4.0 I LONG 6.0;
+ CONJ zz;
+ LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0;
+ CONJ zzz;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r = 0.0;
+ LONG REAL rr = LONG 45.0;
+ LONG LONG REAL rrr = LONG LONG 60.0;
+ ASSERT (cos (r) = 1.0);
+ long cos (rr);
+ long long cos (rrr)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Tests a jump out of the elaboration of a declarer. #
+BEGIN STRING month = CASE 13
+ IN "Jan", "Feb","March","April","May","June",
+ "July","Aug","Sept", "Oct", "Nov","Dec",
+ stop
+ ESAC;
+ ASSERT (FALSE)
+END
--- /dev/null
+begin int n := 1;
+ { The actual-declarer below should be
+ elaborated only once. }
+ [1: n +:= 1]real a, b;
+ assert (n = 2)
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x = 100;
+ PROC foo = INT: (INT i = 10, j = 20; PROC bar = INT: 100; i + j + bar);
+ ASSERT (foo = 130)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Procedure variables. #
+BEGIN INT x = 100;
+ PROC foo := INT: (INT i = 10, j = 20; PROC bar := INT: 100; i + j + bar);
+ ASSERT (foo = 130)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ INT res := (REF INT xx := x; xx);
+ ASSERT (res = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx := x;
+ x := 20;
+ ASSERT (xx = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ INT y := 20;
+ REF INT xx := x;
+ CO This makes xx to refer to y
+ REF REF INT := REF INT
+ CO
+ xx := y;
+ y := 30;
+ ASSERT (xx = 30)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ INT y := 20;
+ REF INT xx := x;
+ # This sets x to the current value of y #
+ REF INT (xx) := y;
+ ASSERT (x = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx := x;
+ REF REF INT xxx := xx;
+ ASSERT (x = 10);
+ ASSERT (xx = 10);
+ ASSERT (xxx = 10);
+ ASSERT ((x) = 10);
+ ASSERT ((xx) = 10);
+ ASSERT ((xxx) = 10);
+ ASSERT (x + 1 = 11);
+ ASSERT (xx + 1 = 11);
+ ASSERT (xxx + 1 = 11);
+ ASSERT ((x + 1) = 11);
+ ASSERT ((xx + 1) = 11);
+ ASSERT ((xxx + 1) = 11);
+ ASSERT ((x := x) = 10);
+ ASSERT ((xx := x) = 10);
+ ASSERT ((xxx := xx) = 10);
+ ASSERT ((x := x) + 1 = 11);
+ ASSERT ((xx := x) + 1 = 11);
+ ASSERT ((xxx := xx) + 1 = 11);
+ x := 20;
+ ASSERT (x = 20);
+ ASSERT (xx = 20);
+ ASSERT (xxx = 20);
+ ASSERT ((x) = 20);
+ ASSERT ((xx) = 20);
+ ASSERT ((xxx) = 20);
+ ASSERT (x + 1 = 21);
+ ASSERT (xx + 1 = 21);
+ ASSERT (xxx + 1 = 21);
+ ASSERT ((x + 1) = 21);
+ ASSERT ((xx + 1) = 21);
+ ASSERT ((xxx + 1) = 21);
+ ASSERT ((x := x) = 20);
+ ASSERT ((xx := x) = 20);
+ ASSERT ((xxx := xx) = 20);
+ ASSERT ((x := x) + 1 = 21);
+ ASSERT ((xx := x) + 1 = 21);
+ ASSERT ((xxx := xx) + 1 = 21)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Dereferencing of struct fields. #
+BEGIN MODE S = STRUCT (REF INT x, REF REF INT xx, REF REF REF INT xxx);
+
+ INT x := 10;
+ REF INT xx := x;
+ REF REF INT xxx := xx;
+
+ S s = (x, xx, xxx);
+
+ ASSERT (x OF s = 10);
+ ASSERT (xx OF s = 10);
+ ASSERT (xxx OF s = 10);
+ ASSERT ((x) = 10);
+ ASSERT ((xx) = 10);
+ ASSERT ((xxx) = 10);
+ ASSERT (x OF s + 1 = 11);
+ ASSERT (xx OF s + 1 = 11);
+ ASSERT (xxx OF s + 1 = 11);
+ ASSERT ((x OF s + 1) = 11);
+ ASSERT ((xx OF s + 1) = 11);
+ ASSERT ((xxx OF s + 1) = 11);
+ ASSERT ((x OF s := x) = 10);
+ ASSERT ((xx OF s := x) = 10);
+ ASSERT ((xxx OF s := xx) = 10);
+ ASSERT ((x OF s := x) + 1 = 11);
+ ASSERT ((xx OF s := x) + 1 = 11);
+ ASSERT ((xxx OF s := xx) + 1 = 11);
+ x OF s := 20;
+ ASSERT (x OF s = 20);
+ ASSERT (xx OF s = 20);
+ ASSERT (xxx OF s = 20);
+ ASSERT ((x) = 20);
+ ASSERT ((xx) = 20);
+ ASSERT ((xxx) = 20);
+ ASSERT (x OF s + 1 = 21);
+ ASSERT (xx OF s + 1 = 21);
+ ASSERT (xxx OF s + 1 = 21);
+ ASSERT ((x OF s + 1) = 21);
+ ASSERT ((xx OF s + 1) = 21);
+ ASSERT ((xxx OF s + 1) = 21);
+ ASSERT ((x OF s := x) = 20);
+ ASSERT ((xx OF s := x) = 20);
+ ASSERT ((xxx OF s := xx) = 20);
+ ASSERT ((x OF s := x) + 1 = 21);
+ ASSERT ((xx OF s := x) + 1 = 21);
+ ASSERT ((xxx OF s := xx) + 1 = 21)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Dereferencing of struct fields. Version with sub-names. #
+BEGIN MODE S = STRUCT (INT x, REF INT xx, REF REF INT xxx);
+
+ INT x := 10;
+ REF INT xx := x;
+ REF REF INT xxx := xx;
+
+ S s := (x, xx, xxx);
+
+ ASSERT (x OF s = 10);
+ ASSERT (xx OF s = 10);
+ ASSERT (xxx OF s = 10);
+ ASSERT ((x) = 10);
+ ASSERT ((xx) = 10);
+ ASSERT ((xxx) = 10);
+ ASSERT (x OF s + 1 = 11);
+ ASSERT (xx OF s + 1 = 11);
+ ASSERT (xxx OF s + 1 = 11);
+ ASSERT ((x OF s + 1) = 11);
+ ASSERT ((xx OF s + 1) = 11);
+ ASSERT ((xxx OF s + 1) = 11);
+ ASSERT ((x OF s := x) = 10);
+ ASSERT ((xx OF s := xx) = 10);
+ ASSERT ((xxx OF s := xxx) = 10);
+ ASSERT ((x OF s := x) + 1 = 11);
+ ASSERT ((xx OF s := xx) + 1 = 11);
+ ASSERT ((xxx OF s := xxx) + 1 = 11);
+ x := 20;
+ ASSERT (x OF s = 10);
+ ASSERT (xx OF s = 20);
+ ASSERT (xxx OF s = 20);
+ ASSERT ((x) = 20);
+ ASSERT ((xx) = 20);
+ ASSERT ((xxx) = 20);
+ ASSERT (x OF s + 1 = 11);
+ ASSERT (xx OF s + 1 = 21);
+ ASSERT (xxx OF s + 1 = 21);
+ ASSERT ((x OF s + 1) = 11);
+ ASSERT ((xx OF s + 1) = 21);
+ ASSERT ((xxx OF s + 1) = 21);
+ ASSERT ((x OF s := x) = 20);
+ ASSERT ((xx OF s := xx) = 20);
+ ASSERT ((xxx OF s := xxx) = 20);
+ ASSERT ((x OF s := x) + 1 = 21);
+ ASSERT ((xx OF s := xx) + 1 = 21);
+ ASSERT ((xxx OF s := xxx) + 1 = 21)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Dereferencing of struct fields. Version with sub-names and
+ explicit assignations instead of initialization in variable declaration. #
+BEGIN MODE S = STRUCT (INT x, REF INT xx, REF REF INT xxx);
+
+ INT x := 10;
+ REF INT xx := x;
+ REF REF INT xxx := xx;
+
+ S s;
+
+ x OF s := x;
+ xx OF s := xx;
+ xxx OF s := xxx;
+
+ ASSERT (x OF s = 10);
+ ASSERT (xx OF s = 10);
+ ASSERT (xxx OF s = 10);
+ ASSERT ((x) = 10);
+ ASSERT ((xx) = 10);
+ ASSERT ((xxx) = 10);
+ ASSERT (x OF s + 1 = 11);
+ ASSERT (xx OF s + 1 = 11);
+ ASSERT (xxx OF s + 1 = 11);
+ ASSERT ((x OF s + 1) = 11);
+ ASSERT ((xx OF s + 1) = 11);
+ ASSERT ((xxx OF s + 1) = 11);
+ ASSERT ((x OF s := x) = 10);
+ ASSERT ((xx OF s := xx) = 10);
+ ASSERT ((xxx OF s := xxx) = 10);
+ ASSERT ((x OF s := x) + 1 = 11);
+ ASSERT ((xx OF s := xx) + 1 = 11);
+ ASSERT ((xxx OF s := xxx) + 1 = 11);
+ x := 20;
+ ASSERT (x OF s = 10);
+ ASSERT (xx OF s = 20);
+ ASSERT (xxx OF s = 20);
+ ASSERT ((x) = 20);
+ ASSERT ((xx) = 20);
+ ASSERT ((xxx) = 20);
+ ASSERT (x OF s + 1 = 11);
+ ASSERT (xx OF s + 1 = 21);
+ ASSERT (xxx OF s + 1 = 21);
+ ASSERT ((x OF s + 1) = 11);
+ ASSERT ((xx OF s + 1) = 21);
+ ASSERT ((xxx OF s + 1) = 21);
+ ASSERT ((x OF s := x) = 20);
+ ASSERT ((xx OF s := xx) = 20);
+ ASSERT ((xxx OF s := xxx) = 20);
+ ASSERT ((x OF s := x) + 1 = 21);
+ ASSERT ((xx OF s := xx) + 1 = 21);
+ ASSERT ((xxx OF s := xxx) + 1 = 21)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = 10;
+ LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+ ASSERT (i / 2 = 5.0);
+ ASSERT (ii / LONG 2 = LONG 5.0);
+ ASSERT (iii / LONG LONG 2 = LONG LONG 5.0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r := 3.14;
+ r DIVAB 2.0;
+ r /:= 2.0;
+ LONG REAL rr := LONG 3.14;
+ rr DIVAB LONG 2.0;
+ rr /:= LONG 2.0;
+ LONG LONG REAL rrr := LONG LONG 3.14;
+ rrr DIVAB LONG LONG 2.0;
+ rrr /:= LONG LONG 2.0
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# ELEM for SIZETY BITS #
+BEGIN BITS b = 2r1010;
+ ASSERT ((bits width - 1) ELEM b);
+ ASSERT (NOT ((bits width - 2) ELEM b));
+ LONG BITS bb = LONG 2r1010;
+ ASSERT ((long bits width - 1) ELEM bb);
+ ASSERT (NOT ((long bits width - 2) ELEM bb));
+ LONG LONG BITS bbb = LONG LONG 2r1010;
+ ASSERT ((long long bits width - 1) ELEM bbb);
+ ASSERT (NOT ((long long bits width - 2) ELEM bbb));
+ SHORT BITS ss = SHORT 2r1010;
+ ASSERT ((short bits width - 1) ELEM ss);
+ ASSERT (NOT ((short bits width - 2) ELEM ss));
+ SHORT SHORT BITS sss = SHORT SHORT 2r1010;
+ ASSERT ((short short bits width - 1) ELEM sss);
+ ASSERT (NOT ((short short bits width - 2) ELEM sss))
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (ELEMS "foo" = 3);
+ ASSERT (ELEMS "" = 0);
+ ASSERT (1 ELEMS "foo" = 3);
+ ASSERT (1 ELEMS "" = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Flat and ultra-flat multiples. #
+BEGIN [3,10:3]INT arr;
+ ASSERT (2 ELEMS arr = 0);
+ [1:0]INT arr2;
+ ASSERT (ELEMS arr2 = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL x = 3.14, y = 3.80;
+ LONG REAL xx = LONG 3.14, yy = LONG 3.80;
+ LONG LONG REAL xxx = LONG LONG 3.14, yyy = LONG LONG 3.80;
+ ASSERT (ENTIER x = 3 AND ENTIER y = 3);
+ ASSERT (ENTIER xx = LONG 3 AND ENTIER yy = LONG 3);
+ ASSERT (ENTIER xxx = LONG LONG 3 AND ENTIER yyy = LONG LONG 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for SIZETY INTs #
+BEGIN ASSERT (max int /= 0);
+ (INT max int = 10; ASSERT (max int = 10));
+ ASSERT (long max int >= LENG max int);
+ ASSERT (long long max int >= LENG long max int);
+ ASSERT (min int /= 0);
+ ASSERT (long min int <= LENG min int);
+ ASSERT (long long min int <= LENG long min int)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for SIZETY REALs #
+BEGIN ASSERT (max real /= 0.0);
+ ASSERT (long max real >= LENG max real);
+ ASSERT (long long max real >= LENG long max real);
+ ASSERT (min real /= 0.0);
+ ASSERT (long min real <= LENG min real);
+ ASSERT (long long min real <= LENG long min real);
+ ASSERT (small real > 0.0);
+ ASSERT (long small real > LONG 0.0);
+ ASSERT (long long small real > LONG LONG 0.0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for SIZETY BITS #
+BEGIN ASSERT (bits width > 0);
+ ASSERT (long bits width >= bits width);
+ ASSERT (long long bits width >= long bits width);
+ ASSERT (short bits width <= bits width);
+ ASSERT (short short bits width <= short bits width)
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for pi constants. #
+BEGIN ASSERT (pi > 3.0 AND pi < 4.0);
+ ASSERT (long pi > LONG 3.0 AND long pi < LONG 4.0);
+ ASSERT (long long pi > LONG LONG 3.0 AND long long pi < LONG LONG 4.0)
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for certain particular characters. #
+BEGIN ASSERT (null character /= blank);
+ ASSERT (max abs char = ABS 16r10ffff)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for SIZETY BITs #
+BEGIN ASSERT (max bits /= 10r0);
+ # XXX use LENG max bits below #
+ ASSERT (long max bits >= LONG 10r0);
+ ASSERT (long long max bits >= LONG LONG 10r0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for widths #
+BEGIN ASSERT (int width > 0);
+ ASSERT (long int width > 0);
+ ASSERT (long long int width > 0);
+ ASSERT (short int width > 0);
+ ASSERT (short short int width > 0);
+ ASSERT (real width > 0);
+ ASSERT (long real width > 0);
+ ASSERT (long long real width > 0)
+CO exp width;
+ long exp width;
+ long long exp width;
+CO
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (flip = "T");
+ ASSERT (flop = "F");
+ ASSERT (error char = "*");
+ ASSERT (ABS invalid char = ABS 16rfffd)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN BITS b, LONG BITS bb = LONG 16rff, LONG LONG BITS bbb;
+ SHORT BITS ss = SHORT 16rff, SHORT SHORT BITS sss;
+ ASSERT (b = 2r0);
+ ASSERT (bb EQ LONG 8r377);
+ ASSERT (bbb = LONG LONG 8r0);
+ ASSERT (ss EQ SHORT 8r377);
+ ASSERT (sss = SHORT SHORT 8r0)
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT ("a" = "a")
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = 12;
+ LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+ SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+ ASSERT (12 = i);
+ ASSERT (ii = LONG 12);
+ ASSERT (iii = LONG LONG 12);
+ ASSERT (s = SHORT 12);
+ ASSERT (ss = SHORT SHORT 12)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN STRING foo = "foo", bar = "bar", quux = "quux";
+ # = #
+ ASSERT ("" = "");
+ ASSERT ("foo" = foo);
+ ASSERT (NOT (foo = bar));
+ ASSERT (NOT (foo = quux));
+ ASSERT (NOT (quux = foo));
+ # EQ #
+ ASSERT ("" EQ "");
+ ASSERT ("foo" EQ foo);
+ ASSERT (NOT (foo EQ bar));
+ ASSERT (NOT (foo EQ quux));
+ ASSERT (NOT (quux EQ foo))
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [,]CHAR matrix = (("1", "2", "3"),
+ ("4", "5", "6"),
+ ("7", "8", "9"));
+ ASSERT (matrix[1:3,2] = "258")
+END
--- /dev/null
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# 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/>.
+
+# Execute tests, torture testing.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+load_lib algol68-torture.exp
+load_lib torture-options.exp
+
+torture-init
+set-torture-options $TORTURE_OPTIONS
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] {
+ # If we're only testing specific files and this isn't one of them, skip it.
+ if ![runtest_file_p $runtests $testcase] then {
+ continue
+ }
+ algol68-torture-execute $testcase
+ set algol68_compile_args ""
+}
+
+torture-finish
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# The Most Contrived Factorial Program
+ By John P. Baker
+ University of Bristol.
+
+ Published in the Algol Bulletin 42.
+ http://jemarch.net/algol-bulletin-42.pdf
+
+ Version adapted for GCC.
+#
+
+BEGIN INT one = 1, two = 2, three = 3, four = 4, five = 5,
+ six = 6, seven = 7, eight = 8, nine = 9, ten = 10,
+ eleven = 11, twelve = 12;
+ INT a = one;
+ PRIO ME=5, LOVE=7, MY=7, LORDS=7, LADIES=7,
+ PIPERS=7, DRUMMERS=7, MAIDS=7, SWANS=7, GEESE=7,
+ GOLD=7, COLLY=7, FRENCH=7, TURTLE=7, PARTRIDGE=6;
+ BOOL sent to := TRUE;
+ OP THE = (BOOL a) BOOL: a,
+ TWELFTH = (INT a) BOOL: a = twelve,
+ ELEVENTH = (INT a) BOOL: a = eleven,
+ TENTH = (INT a) BOOL: a = ten,
+ NINTH = (INT a) BOOL: a = nine,
+ EIGHTH = (INT a) BOOL: a = eight,
+ SEVENTH = (INT a) BOOL: a = seven,
+ SIXTH = (INT a) BOOL: a = six,
+ FIFTH = (INT a) BOOL: a = five,
+ FOURTH = (INT a) BOOL: a = four,
+ THIRD = (INT a) BOOL: a = three,
+ SECOND = (INT a) BOOL: a = two,
+ FIRST = (INT a) BOOL: a = one;
+ OP ME = (BOOL a, INT b) VOID: SKIP; # XXX when transput done (a|print(b)) #
+ OP LOVE = (BOOL a, b) BOOL: (a|b|FALSE),
+ MY = (BOOL a, b) BOOL: a LOVE b;
+ OP AND = (INT a) INT: a;
+ MODE DATE = STRUCT (INT day, month);
+ LOC DATE christmas := (25, 12);
+ OP LORDS = (INT a, b) INT: a * b,
+ LADIES = (INT a, b) INT: a * b,
+ PIPERS = (INT a, b) INT: a * b,
+ DRUMMERS = (INT a, b) INT: a * b,
+ MAIDS = (INT a, b) INT: a * b,
+ SWANS = (INT a, b) INT: a * b,
+ GEESE = (INT a, b) INT: a * b,
+ GOLD = (INT a, b) INT: a * b,
+ COLLY = (INT a, b) INT: a * b,
+ FRENCH = (INT a, b) INT: a * b,
+ TURTLE = (INT a, b) INT: a * b;
+ OP LEAPING = (INT a) INT: a,
+ DANCING = (INT a) INT: a,
+ PIPING = (INT a) INT: a,
+ DRUMMING = (INT a) INT: a,
+ MILKING = (INT a) INT: a,
+ SWIMMING = (INT a) INT: a,
+ LAYING = (INT a) INT: a,
+ RINGS = (INT a) INT: a,
+ BIRDS = (INT a) INT: a,
+ HENS = (INT a) INT: a,
+ DOVES = (INT a) INT: a;
+ OP PARTRIDGE = (INT a, b) INT: a + b;
+ INT in a pear tree = 0;
+
+ # Now we are ready... #
+
+ THE FIRST day OF christmas MY TRUE LOVE sent to ME
+ a PARTRIDGE in a pear tree;
+
+ THE SECOND day OF christmas MY TRUE LOVE sent to ME
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE THIRD day OF christmas MY TRUE LOVE sent to ME
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE FOURTH day OF christmas MY TRUE LOVE sent to ME
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE FIFTH day OF christmas MY TRUE LOVE sent to ME
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE SIXTH day OF christmas MY TRUE LOVE sent to ME
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE SEVENTH day OF christmas MY TRUE LOVE sent to ME
+ seven SWANS SWIMMING
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE EIGHTH day OF christmas MY TRUE LOVE sent to ME
+ eight MAIDS MILKING
+ seven SWANS SWIMMING
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE NINTH day OF christmas MY TRUE LOVE sent to ME
+ nine DRUMMERS DRUMMING
+ eight MAIDS MILKING
+ seven SWANS SWIMMING
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE TENTH day OF christmas MY TRUE LOVE sent to ME
+ ten PIPERS PIPING
+ nine DRUMMERS DRUMMING
+ eight MAIDS MILKING
+ seven SWANS SWIMMING
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE ELEVENTH day OF christmas MY TRUE LOVE sent to ME
+ eleven LADIES DANCING
+ ten PIPERS PIPING
+ nine DRUMMERS DRUMMING
+ eight MAIDS MILKING
+ seven SWANS SWIMMING
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ THE TWELFTH day OF christmas MY TRUE LOVE sent to ME
+ twelve LORDS LEAPING
+ eleven LADIES DANCING
+ ten PIPERS PIPING
+ nine DRUMMERS DRUMMING
+ eight MAIDS MILKING
+ seven SWANS SWIMMING
+ six GEESE LAYING
+ five GOLD RINGS
+ four COLLY BIRDS
+ three FRENCH HENS
+ two TURTLE DOVES AND
+ a PARTRIDGE in a pear tree;
+
+ SKIP
+END
+
--- /dev/null
+{ Assigning to the flexible name replaces the descriptor
+ as well as the elements. }
+begin [10:0]int flat1;
+ flex[10:-10]int flat2;
+ flat2 := flat1;
+ assert (UPB flat2 = 0 AND LWB flat2 = 10)
+end
--- /dev/null
+{ Assigning to the flexible name replaces the descriptor
+ as well as the elements. }
+begin [1:20,10:0]int flat1;
+ flex[100:200,10:-10]int flat2;
+ flat2 := flat1;
+ assert (1 UPB flat2 = 20 AND 1 LWB flat2 = 1);
+ assert (2 UPB flat2 = 0 AND 2 LWB flat2 = 10)
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN FLEX[3]INT list := (1,2,3);
+ list[2] := 20;
+ ASSERT (list[2] = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Rowing to flexible rows. #
+BEGIN FLEX[]INT list = 10;
+ ASSERT (list[1] = 10);
+ FLEX[,]INT table = 10;
+ ASSERT (table[1,1] = 10)
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Slicing flexible names. #
+BEGIN FLEX[]INT list = (1,2,3);
+ FLEX[]INT sliced = list[2:3];
+ ASSERT (LWB sliced = 1 AND UPB sliced = 2);
+ ASSERT (sliced[1] = 2 AND sliced[2] = 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Rowing to flexible rows. #
+BEGIN FLEX[3]INT list := (1,2,3);
+ list := (10,20,30,40);
+ ASSERT (list[4] = 40)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN FLEX[1:0]INT a;
+ ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0);
+ a := (1,2,3);
+ ASSERT (LWB a = 1 AND UPB a = 3 AND a[1] = 1 AND a[2] = 2 AND a[3] = 3);
+ a := (10,a[2],a[3]);
+ ASSERT (LWB a = 1 AND UPB a = 3 AND a[1] = 10 AND a[2] = 2 AND a[3] = 3);
+ a := 100;
+ ASSERT (LWB a = 1 AND UPB a = 1 AND a[1] = 100);
+ a := ();
+ ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN OP JORL = (INT a, b) INT: a + b;
+ OP JORL = (REAL a, b) REAL: a + b;
+ OP JORL = ([]CHAR s) INT: ELEMS s;
+ PRIO JORL = 6;
+ ASSERT (10 JORL 20 = 30);
+ ASSERT (REAL r = 3.14 JORL REAL (1); r > 4.13 AND r < 4.15);
+ ASSERT (JORL "foo" = 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i;
+ PROC side = INT: (i := 1; i := 2; i);
+ INT res = side + side;
+ # Can be either due to collateral elaboration in the formula above. #
+ ASSERT (res = 3 OR res = 4)
+END
--- /dev/null
+begin assert (fsize (-1) = - long long 1)
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = 12;
+ LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+ SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+ ASSERT (i >= 10);
+ ASSERT (ii GE LONG 10);
+ ASSERT (iii >= LONG LONG 12);
+ ASSERT (s >= SHORT 12);
+ ASSERT (ss >= SHORT SHORT 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [,]CHAR matrix = (("1", "0", "1"),
+ ("4", "0", "4"),
+ ("7", "0", "7"));
+ ASSERT (matrix[1:3,1] >= matrix[1:3,3]);
+ ASSERT (("1","4","7") >= matrix[1:3,3])
+END
--- /dev/null
+begin flex[10:-10]int je;
+ int num_fields = 3;
+ assert (UPB je = -10 AND LWB je = 10 AND ELEMS je = 0);
+
+ [1:num_fields][1:num_fields]string fields;
+ for i to num_fields
+ do for j to num_fields
+ do assert (fields[i][j] = "") od
+ od
+end
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT jorl;
+ REF INT var = HEAP INT;
+ var := jorl := 10;
+ ASSERT (var = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT jorl;
+ REF INT var := HEAP INT;
+ var := jorl := 10;
+ ASSERT (var = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT jorl;
+ INT var := HEAP INT := 15; # The generated name goes away #
+ ASSERT (var = 15)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REF BOOL x = HEAP BOOL;
+ ASSERT (x = FALSE);
+ x := TRUE;
+ ASSERT (x = TRUE)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REF INT x = HEAP INT := 4;
+ ASSERT (x = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REF REAL x = HEAP REAL := 4;
+ ASSERT (x > 3.9 AND x < 4.1)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN HEAP STRUCT(INT i, REAL r) foo;
+ ASSERT (i OF foo = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN HEAP STRUCT([10]INT i, REAL r) foo;
+ FOR i FROM LWB i OF foo TO UPB i OF foo
+ DO ASSERT ((i OF foo)[i] = 0) OD
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN HEAP STRUCT([10]INT i, STRING s) foo;
+ FOR i FROM LWB i OF foo TO UPB i OF foo
+ DO ASSERT ((i OF foo)[i] = 0) OD
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT jorl;
+ REF INT var = LOC INT;
+ var := jorl := 10;
+ ASSERT (var = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT jorl;
+ REF INT var := LOC INT;
+ var := jorl := 10;
+ ASSERT (var = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT jorl;
+ INT var := LOC INT := 15; # The generated name goes away #
+ ASSERT (var = 15)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE NODE = STRUCT (INT code, REF NODE next);
+
+ NODE top := (10, NIL);
+ next OF top := LOC NODE := (20, NIL);
+ ASSERT (code OF top = 10);
+ ASSERT (code OF next OF top = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE JORL = [(INT x; x + 1)]INT;
+ JORL xx;
+ ASSERT (ELEMS xx = 1 AND xx[1] = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN UNION(INT,REAL,[]INT,CHAR) datux;
+ ASSERT (CASE datux
+ IN (INT): 10,
+ (REAL): 20,
+ (CHAR): 30,
+ ([]INT): 40
+ ESAC = 0);
+ []INT ja = (1,2,3);
+ datux := ja;
+ ASSERT (CASE datux
+ IN (INT): 10,
+ (REAL): 20,
+ (CHAR): 30,
+ ([]INT): 40
+ ESAC = 40)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# pr UPPER pr #
+BEGIN [10]UNION(INT,REAL,[]INT,CHAR) datux;
+ FOR i FROM LWB datux TO UPB datux
+ DO ASSERT (CASE datux[i]
+ IN (INT): 10,
+ (REAL): 20,
+ (CHAR): 30,
+ ([]INT): 40
+ ESAC = 0);
+ []INT ja = (1,2,3);
+ datux[i] := ja;
+ ASSERT (CASE datux[i]
+ IN (INT): 10,
+ (REAL): 20,
+ (CHAR): 30,
+ ([]INT): 40
+ ESAC = 40)
+ OD
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# An union generated from SKIP has -1 as overhead. #
+BEGIN MODE JSONVAL = UNION (JSONOBJ,JSONSTR),
+ JSONSTR = STRING,
+ JSONOBJ = STRUCT (REF JSONFLD fields),
+ JSONFLD = STRUCT (JSONVAL value, REF JSONFLD next);
+
+ JSONFLD fields;
+ ASSERT (CASE value OF fields
+ IN (JSONSTR s): "string",
+ (JSONOBJ o): "object"
+ OUT "fuckyou"
+ ESAC = "fuckyou")
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 0;
+beg: IF (i < 5)
+ THEN i +:= 1;
+ GOTO beg
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN GOTO end;
+ ASSERT(FALSE);
+end: SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN
+ INT i := 0;
+ beginning:
+ IF (i < 5) THEN
+ i +:= 1;
+ GO TO beginning
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN
+ INT i := 0;
+ beginning:
+ IF (i < 5) THEN
+ i +:= 1;
+ beginning
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN PROC is prime = (INT m) BOOL:
+ BEGIN IF m < 2
+ THEN puts ("program terminated because m is less than 2\n");
+ GOTO stop
+ FI;
+
+ BOOL factor found := NOT (ODD m OR m = 2);
+ FOR i FROM 3 BY 2 TO m - 1 WHILE NOT factor found
+ DO factor found := m MOD i = 0 OD;
+ factor found
+ END;
+
+ ASSERT (is prime (1));
+ ASSERT (is prime (3));
+ ASSERT (is prime (71));
+ ASSERT (is prime (97));
+ is prime (0);
+ ASSERT (FALSE) # Should jump to stop in the standard postlude. #
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = 12;
+ LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+ SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+ ASSERT (i > 10);
+ ASSERT (ii GT LONG 10);
+ ASSERT (iii > LONG LONG 10);
+ ASSERT (s > SHORT 10);
+ ASSERT (ss > SHORT SHORT 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [,]CHAR matrix = (("1", "0", "1"),
+ ("4", "0", "4"),
+ ("7", "0", "6"));
+ ASSERT (matrix[1:3,1] > matrix[1:3,3]);
+ ASSERT (("1","4","7") > matrix[1:3,3])
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN COMPL z = 4I5;
+ LONG COMPL zz = LONG 4 I LONG 6;
+ LONG LONG COMPL zzz = LONG LONG 4 I LONG LONG7;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN COMPL z = 4.0I5.0;
+ LONG COMPL zz = LONG 4.0 I LONG 6.0;
+ LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN PROC a = REAL: b := c;
+ REAL b := 1, c := 2;
+ REAL x := a;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# The identification of c in the assignation marked with XXX works.
+ In some Algol 68 systems the assignation may fail or result in UB,
+ because the storage of the REF REAL c doesn't exist yet. In GNU
+ Algol 68 this works and the value yielded by c is guaranteed to be
+ zero.
+#
+
+BEGIN REAL b;
+ b := c; # XXX #
+ ASSERT (b = 0);
+ REAL c;
+ c := b
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx = x := 20;
+ ASSERT (xx = 20);
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx = x;
+ ASSERT (xx = 10);
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx = (x := 20);
+ ASSERT (xx = 20);
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT x := 10;
+ REF INT xx = ((x));
+ ASSERT (xx = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN MODE FOO = STRUCT (STRING s, INT i);
+ FOO f1 = ("foo", 10);
+ ASSERT (i OF f1 = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN []INT foo = (1,2,3);
+ ASSERT (ELEMS foo = 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [][]INT foo = ((1,2,3),(4,5,6));
+ ASSERT (ELEMS foo = 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [3]INT a := (1,2,3);
+ REF[]INT nn = a; # No copy happens here. #
+ nn[1] := 200;
+ ASSERT (a[1] = 200)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [:]INT foo = (1,2,3);
+ ASSERT (ELEMS foo = 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN []INT a = ();
+ ASSERT (UPB a = 0);
+ ASSERT (LWB a = 1);
+ ASSERT (ELEMS a = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [,,]INT a = ();
+ ASSERT (1 UPB a = 0);
+ ASSERT (1 LWB a = 1);
+ ASSERT (1 ELEMS a = 0);
+ ASSERT (2 UPB a = 0);
+ ASSERT (2 LWB a = 1);
+ ASSERT (2 ELEMS a = 0);
+ ASSERT (3 UPB a = 0);
+ ASSERT (3 LWB a = 1);
+ ASSERT (3 ELEMS a = 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN PROC foo = ([]INT a) VOID: (ASSERT (ELEMS a = 0));
+ foo ([]INT())
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN PROC foo = ([]INT a) VOID: (ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0));
+ foo (())
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# An identity declaration shall make a copy of the struct value being
+ ascribed. #
+BEGIN MODE FOO = STRUCT (STRING s, INT n);
+ FOO f1 := ("foo", 10);
+ FOO f2 = f1;
+ f1 := ("bar", 20);
+ ASSERT (n OF f1 = 20);
+ ASSERT (n OF f2 = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN infinity;
+ minus infinity
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# <= and => for SIZETY BITS #
+BEGIN ASSERT (16rff <= 16rffff);
+ ASSERT (2r101 LE 2r111);
+ ASSERT (2r111 >= 2r101);
+ ASSERT (16rffff GE 16rff);
+
+ ASSERT (LONG 16rff <= LONG 16rffff);
+ ASSERT (LONG 2r101 LE LONG 2r111);
+ ASSERT (LONG 2r111 >= LONG 2r101);
+ ASSERT (LONG 16rffff GE LONG 16rff);
+
+ ASSERT (LONG LONG 16rff <= LONG LONG 16rffff);
+ ASSERT (LONG LONG 2r101 LE LONG LONG 2r111);
+ ASSERT (LONG LONG 2r111 >= LONG LONG 2r101);
+ ASSERT (LONG LONG 16rffff GE LONG LONG 16rff)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i = 12;
+ LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+ SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+ ASSERT (i <= 13);
+ ASSERT (ii LE LONG 13);
+ ASSERT (iii <= LONG LONG 13);
+ ASSERT (s <= SHORT 12);
+ ASSERT (ss <= SHORT SHORT 13)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [,]CHAR matrix = (("1", "Z", "1"),
+ ("4", "Y", "4"),
+ ("7", "X", "9"));
+ ASSERT (matrix[1:3,1] <= matrix[1:3,3]);
+ ASSERT (("1","4","9") <= matrix[1:3,3])
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# SHORTEN and LENG on SIZETY BITS #
+BEGIN ASSERT (LENG 16rff = LONG 16rff);
+ ASSERT (SHORTEN LONG 16rffff = 16rffff);
+ ASSERT (LENG LONG 16rffff = LONG LONG 16rffff);
+ ASSERT (SHORTEN LONG LONG 16rffff = LONG 16rffff)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for SIZETY INTs #
+BEGIN # LENG #
+ (SHORT SHORT INT iii = short short max int; ASSERT (LENG iii = LENG short short max int));
+ (SHORT INT ii = short max int; ASSERT (LENG ii = LENG short max int));
+ (INT i = max int; ASSERT (LENG i = LENG max int));
+ (LONG INT ii = long max int; ASSERT (LENG ii = LENG long max int));
+ # SHORTEN #
+ (SHORT INT i = SHORT 10; SHORT SHORT INT ii = SHORT SHORT 100; ASSERT (ii + SHORTEN i = SHORT SHORT 110));
+ IF int shorths > 2
+ THEN (SHORT INT ii = LENG short short max int - SHORT 2;
+ ASSERT (SHORTEN ii = short short max int - SHORT SHORT 2));
+ (SHORT INT ii = LENG short short max int + SHORT 1; ASSERT (SHORTEN ii = short short max int));
+ (SHORT INT ii = LENG short short min int - SHORT 1; ASSERT (SHORTEN ii = short short min int))
+ FI;
+ (INT i = LENG short max int - 2; ASSERT (SHORTEN i = SHORTEN max int - SHORT 2));
+ (INT i = LENG short max int + 1; ASSERT (SHORTEN i = SHORTEN max int));
+ (INT i = LENG short min int - 1; ASSERT (SHORTEN i = SHORTEN min int));
+ (LONG INT ii = LENG max int - LONG 2; ASSERT (SHORTEN ii = max int - 2));
+ (LONG INT ii = LENG max int + LONG 1; ASSERT (SHORTEN ii = max int));
+ (LONG INT ii = LENG min int - LONG 1; ASSERT (SHORTEN ii = min int));
+ IF int lengths > 2
+ THEN (LONG LONG INT ii = LENG long max int - LONG LONG 2; ASSERT (SHORTEN ii = long max int - LONG 2));
+ (LONG LONG INT ii = LENG long max int + LONG LONG 1; ASSERT (SHORTEN ii = long max int));
+ (LONG LONG INT ii = LENG long min int - LONG LONG 1; ASSERT (SHORTEN ii = long min int))
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Environment enquiries for SIZETY REALs #
+BEGIN # LENG #
+ (REAL i = max real; ASSERT (LENG i = LENG max real));
+ (LONG REAL ii = long max real; ASSERT (LENG ii = LENG long max real));
+
+ # SHORTEN #
+ (LONG REAL ii = LENG max real - LONG 2.0; ASSERT (SHORTEN ii = max real - 2.0));
+ (LONG REAL ii = LENG max real + LONG 1.0; ASSERT (SHORTEN ii = max real));
+ (LONG REAL ii = LENG min real - LONG 1.0; ASSERT (SHORTEN ii = min real));
+ IF (long long max real > LENG long max real)
+ THEN (LONG LONG REAL ii = LENG long max real - LONG LONG 2.0;
+ ASSERT (SHORTEN ii = long max real - LONG 2.0));
+ (LONG LONG REAL ii = LENG long max real + LONG LONG 1.0; ASSERT (SHORTEN ii = long max real));
+ (LONG LONG REAL ii = LENG long min real - LONG LONG 1.0; ASSERT (SHORTEN ii = long min real))
+ FI
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN ASSERT (int lengths > 0);
+ ASSERT (int shorths > 0);
+ ASSERT (bits lengths > 0);
+ ASSERT (bits shorths > 0);
+ ASSERT (real lengths > 0);
+ ASSERT (real shorths > 0)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT num ints := 0, num chars := 0;
+ PROC collect stats = (REF CONS tree) VOID:
+ BEGIN REF CONS e := tree;
+ WHILE REF CONS (e) ISNT NIL
+ DO CASE car OF e
+ IN (CHAR c): num chars +:= 1,
+ (INT): num ints +:= 1,
+ (REF CONS s): collect stats (s)
+ ESAC;
+ e := cdr OF e
+ OD
+ END;
+ MODE ATOM = UNION (CHAR, INT);
+ MODE CONS = STRUCT (UNION (ATOM, REF CONS) car, REF CONS cdr);
+ PROC list = ([]UNION (ATOM, REF CONS) item) REF CONS:
+ BEGIN REF CONS a := NIL;
+ FOR i FROM UPB item BY -1 TO 1
+ DO a := HEAP CONS := (item[i], a) OD;
+ a
+ END;
+ REF CONS expression := list (("X", "+", list (("Y", "x", 2))));
+ collect stats (expression);
+ ASSERT (num ints = 1 AND num chars = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT num constants := 0, num vars := 0, num operators := 0;
+ PROC collect stats = (REF EXPRESSION expr) VOID:
+ BEGIN CASE left OF expr
+ IN (INT): num constants +:= 1,
+ (CHAR): num vars +:= 1,
+ (REF EXPRESSION s): collect stats (s)
+ ESAC;
+ num operators +:= 1;
+ CASE right OF expr
+ IN (INT): num constants +:= 1,
+ (CHAR): num vars +:= 1,
+ (REF EXPRESSION s): collect stats (s)
+ ESAC
+ END;
+ MODE OPERAND = UNION (CHAR,INT,REF EXPRESSION),
+ EXPRESSION = STRUCT (OPERAND left, CHAR operator, OPERAND right);
+ REF EXPRESSION expression := HEAP EXPRESSION := ("X", "+", HEAP EXPRESSION := ("Y", "x", 2));
+ collect stats (expression);
+ ASSERT (num constants = 1 AND num vars = 2 AND num operators = 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r = 1.0;
+ LONG REAL rr = LONG 2.0;
+ LONG LONG REAL rrr = LONG LONG 60.0;
+ ASSERT (ln (r) = 0.0);
+ long ln (rr);
+ long long ln (rrr)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL r = 1.0;
+ LONG REAL rr = LONG 2.0;
+ LONG LONG REAL rrr = LONG LONG 60.0;
+ ASSERT (log (r) = 0.0);
+ long log (rr);
+ long long log (rrr)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 0;
+ DO i +:= 1; IF i = 5 THEN exit FI
+ OD;
+exit: ASSERT (i = 5)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 0, n := 2;
+ FOR a FROM n BY 2 TO n + 2 DO i +:= a OD;
+ ASSERT (i = 2 + 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Negative steps towards minus infinity. #
+BEGIN INT i := 0, n := -5;
+ BY -1 TO n - 1 DO i -:= 1 OD;
+ ASSERT (i = -8)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 0, n := 5;
+ FOR a TO n WHILE a < 3 DO i +:= 1 OD;
+ ASSERT (i = 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT i := 0;
+ FOR a FROM 2 BY 1 WHILE a <= 10
+ DO i +:= 1 OD;
+ ASSERT (i = 9)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# The while-part shall not be elaborated if the iterator is exhausted. #
+BEGIN STRING s = "abc", INT j := 0;
+ FOR i TO UPB s WHILE s[i] /= "x"
+ DO j +:= 1 OD;
+ ASSERT (j = 3)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# While loop. #
+BEGIN INT i := 0;
+ WHILE INT j = 5; i < j
+ DO i +:= 1 OD;
+ ASSERT (i = 5)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Nested loops. #
+BEGIN INT i := 10, res := 0;
+ WHILE i > 0
+ DO INT j := 10;
+ WHILE j > 0
+ DO res +:= 1;
+ j -:= 1
+ OD;
+ ASSERT (j = 0);
+ i -:= 1;
+ OD;
+ ASSERT (i = 0 AND res = 100)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Nested loops and j on outside range. #
+BEGIN INT i := 10, j := 10, res := 0;
+ WHILE i > 0
+ DO j := 10;
+ WHILE j > 0
+ DO res +:= 1;
+ j -:= 1
+ OD;
+ i -:= 1
+ OD;
+ ASSERT (i = 0 AND j = 0 AND res = 100)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Skip in loop. #
+BEGIN INT i := 0;
+ WHILE i +:= 1; i < 10
+ DO SKIP OD;
+ ASSERT (i = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# The range of the while-part shall cover the do-part. #
+BEGIN INT i := 0;
+ WHILE INT incr = 2; i < 10
+ DO i +:= incr OD;
+ ASSERT (i = 10)
+END
projects / thirdparty / gcc.git / commitdiff
