--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+BEGIN REAL r := 10.0, circum, area;
+ circum := 2 * pi * r; area := pi * r * r
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+# Transient references and declarations. #
+BEGIN FLEX[4,6]INT p;
+ # Illegal, cannot remember transient name. #
+ REF[]INT q2 = p[3,]; # { dg-error "" } #
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+
+# Transient references and declarations. #
+BEGIN FLEX[4,6]INT p;
+ # Illegal. p cannot be deflexed since it is a REF FLEX. #
+ REF[,]INT q3 = p; # { dg-error "" } #
+ SKIP
+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/>.
+
+if $tracelevel then {
+ strace $tracelevel
+}
+
+load_lib algol68-torture.exp
+
+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
+}
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN REAL e = 2.7182818284; REAL circum;
+ circum := 2 * pi * e
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT n := 10, result;
+ result := n * (n + 1) * (2 * n + 1)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Integer denotations. #
+BEGIN 000; 43; 456; 0
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Real denotations. #
+BEGIN .5; 0.5; 2.0; .001;
+ 2.3e1; 2e0; 2e+0; 2e-0
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Character denotations. #
+BEGIN "X"; "a"; "1"; "."; " "
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Identifiers. #
+BEGIN INT circum, r, ibm, a1, log2, begin;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Identity declarations. #
+BEGIN REAL e = 2.7182818284, log2 = 0.618, INT ten = 10, g = 32;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Equivalent declarations. #
+BEGIN REAL x = 2.34;
+ REF INT n = LOC INT, REF INT m = LOC INT;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Initialisation. #
+BEGIN CHAR firstchar := "A", lastchar := "Z", currentchar;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Ordinary division. #
+BEGIN ASSERT (4/2 = 2.0);
+ INT a = 4, b = 7;
+ a/b # Yields a value of mode REAL. #
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Integer division. The operator OVER (%) performs integer
+ division with truncation. #
+BEGIN ASSERT (4 % 2 = 2);
+ ASSERT (4 OVER 2 = 2);
+ ASSERT (5 % 3 = 1);
+ ASSERT (5 OVER 3 = 1);
+ INT n = -5, m = -3;
+ ASSERT (n % 3 = -1);
+ ASSERT (n % m = 1)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Integer modulus. The operator MOD (%*) performs integer modulus
+ with truncation. #
+BEGIN ASSERT (0 MOD 4 = 0);
+ ASSERT (0 %* 4 = 0);
+ ASSERT (5 %* 3 = 2);
+ INT m = 5, n = -3;
+ ASSERT (m MOD n = 2)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Exponentiation. #
+BEGIN ASSERT (2 ** 3 = 8)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Comparison operators. #
+BEGIN REAL x = 2.7, y = 3.6, z = 4.7;
+ ASSERT (x < y);
+ ASSERT ("B" /= "C")
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Comparison operators and boolean operators. #
+BEGIN INT a = 4, b = 5, c = 9, REAL x = 4.7, y = 5.7, z = 6.7;
+ ASSERT (NOT (x + y < z) AND a + b = c)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Widening. #
+BEGIN REAL x := 4, y := 7, z := 2.7;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Dereferencing and widening. #
+BEGIN INT n, REAL x = n;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Examples of assignations. #
+BEGIN REAL pi = 3.14, e = 2.71, INT n = 10, REAL circum, INT result;
+ circum := 2 * pi * e;
+ result := n * (n + 1) * ( 2 * n + 1)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Coercions and assignations. #
+BEGIN REAL y, INT n, m := 1;
+ y := n % m
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Arithmetical assignment operators. #
+BEGIN INT m, n := 4;
+ n PLUSAB 1;
+ ASSERT (n = 5)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Equivalence. #
+BEGIN INT m := 3; REF INT p = m;
+ ASSERT (m = 3 AND p = 3);
+ BEGIN INT m := 100;
+ ASSERT (m = 100 AND p = 3);
+ m -:= 1; p +:= 1
+ END;
+ ASSERT (m = 4 AND p = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# On the availability and accessibility of space. #
+BEGIN INT m := 3, INT five = 5;
+ ASSERT (m = 3);
+ BEGIN INT m := 100; CHAR five = "5";
+ m +:= 1
+ END;
+ ASSERT (m = 3 AND five = 5)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT p := 10, q := 12;
+ FROM p TO q DO (p +:= 1, q +:= 1) OD;
+ ASSERT (p = 13 AND q = 15)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Using case clauses. #
+BEGIN PROC is divisible = (INT m) BOOL:
+ BEGIN BOOL divisible := FALSE;
+ FOR i TO 4 WHILE NOT divisible
+ DO INT k = (i|3, 5, 7, 11);
+ divisible := m MOD k = 0
+ OD;
+ divisible
+ END;
+ ASSERT (is divisible (50));
+ ASSERT (is divisible (253))
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Using jumps. #
+BEGIN INT a, INT b = 0, c = 2, d = 10, BOOL e = TRUE;
+ CO The following program using jumps is equivalent to:
+ FOR a FROM b BY c TO d WHILE e DO SKIP OD
+ CO
+ BEGIN INT j := b, INT k = c, m = d;
+ next: IF (k > 0 AND j <= m) OR (k < 0 AND j >= m) OR k = 0
+ THEN INT i = j;
+ IF e
+ THEN SKIP; j +:= k; GOTO next
+ FI
+ FI;
+ ASSERT (j = 12)
+ END
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Monadic lwb and upb. #
+BEGIN INT n := 4; [n]INT a;
+ ASSERT (UPB a = 4);
+ n := 6;
+ ASSERT (UPB a = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Dyadic lwb an upb. #
+BEGIN [0:10,-4:100]REAL xx;
+ ASSERT (1 LWB xx = 0);
+ ASSERT (1 UPB xx = 10);
+ ASSERT (1 UPB xx = UPB xx);
+ ASSERT (2 LWB xx = -4);
+ ASSERT (2 UPB xx = 100)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN [4]REAL x2 := (6, 7, 8, 9);
+ ASSERT (x2[2] > 6.9);
+ ASSERT (x2[2] < 7.1);
+ x2 := (1, 1, 1, 1);
+ ASSERT(x2[2] > 0.9);
+ ASSERT(x2[2] < 1.1)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Multi-dimensional row displays. #
+BEGIN [2,3]INT aa := ((1,2,3),(4,5,6));
+ [2,3,4]REAL bb := (((1,2,3,4), (5,6,7,8), (9,10,11,12)),
+ ((13,14,15,16),(17,18,19,20),(21,22,2,24)));
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Further row displays. #
+BEGIN [4]INT a, b;
+ [4]INT c := a, d := (1,2,3,0);
+ [2,4]INT ab := (a,b), cd := ((0,0,0,0), b);
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN STRUCT (INT day, month, year) indep day = (4, 7, 1776);
+ ASSERT (day OF indep day = 4);
+ ASSERT (month OF indep day = 7);
+ ASSERT (year OF indep day = 1776);
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN []STRUCT(CHAR letter, INT integer) roman
+ = (("I",1),("V",5),("X",10),("L",50),("C",100));
+ # XXX letter OF roman should be ("I","V","X","L","C") #
+ # XXX integer OF roman whould be (1,5,10,50,100) #
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Multiple values and structures.
+
+ Having strings of different lenghts would not be valid in a variable
+ declaration, but is acceptable in an identity declaration.
+#
+BEGIN []STRUCT ([]CHAR name, INT age) family =
+ (("JOHN", 3), ("ROBERT", 1), ("CATHERINE", 4));
+ SKIP
+END
+
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Simple mode declarations. #
+BEGIN MODE INTEGER = INT;
+ MODE Z = INT, R = REAL, B = BOOL, V = VOID;
+ MODE ARRAYA = [100]INT, ARRAYB = [10,2:9]REAL;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Dynamic arrays revisited. #
+BEGIN INT p := 2, q := 10;
+ MODE M = [p:q]INT;
+ M a;
+ ASSERT (LWB a = 2 AND UPB a = 10);
+ q := 4;
+ M b;
+ ASSERT (LWB a = 2 AND UPB a = 10);
+ ASSERT (LWB b = 2 AND UPB b = 4);
+ M c = (1,2,3,4); # M is interpreted as formal declarer.
+ Bounds are ignored.
+ #
+ ASSERT (LWB c = 1 AND UPB c = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Rows of integers. #
+BEGIN [][]INT g = ((1,2,3),(4,5),(6,7,8,9));
+ ASSERT (UPB g[1] = 3 AND UPB g[2] = 2 AND UPB g[3] = 4)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Procedure declarations I. #
+BEGIN INT x = 10, y = 20, i = 2;
+ PROC xxx = (INT arg) INT: 10;
+ PROC yyy = (INT arg) INT: 20;
+ PROC zzz = (INT arg) INT: 30;
+ PROC(INT)INT f = IF x > y THEN xxx ELSE zzz FI,
+ g = CASE i IN xxx, yyy, zzz ESAC;
+ PROC(INT)INT h := IF x < y THEN xxx ELSE yyy FI;
+ ASSERT (f (100) = 30);
+ ASSERT (g (200) = 20);
+ ASSERT (h (300) = 10);
+ h := yyy;
+ ASSERT (h (300) = 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Using the factorial function in a program #
+BEGIN PROC f = (INT n) INT:
+ BEGIN INT product := 1;
+ FOR i TO n DO product *:= i OD;
+ product
+ END;
+ ASSERT (f(0) = 1);
+ ASSERT (f(1) = 1);
+ ASSERT (f(2) = 2);
+ ASSERT (f(3) = 6)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Procedure declarations III #
+BEGIN # From the ALGOL68 Revised Report. #
+ PROC my char in string = (CHAR c, REF INT i, []CHAR s) BOOL:
+ BEGIN BOOL found := FALSE;
+ FOR k FROM LWB s TO UPB s WHILE NOT found
+ DO (c = s[k] | i := k; found := TRUE) OD;
+ found
+ END;
+ ASSERT ((INT idx := 0;
+ my char in string ("o", idx, "foo")
+ ANDTH idx = 2));
+ ASSERT (my char in string ("x", LOC INT, "foo") = FALSE);
+ # Swapping function. #
+ PROC swap = (REF INT a, b) VOID:
+ (INT r = a; a := b; b := r);
+ ASSERT ((INT x := 1, y := 2;
+ swap (x, y);
+ x = 2 AND y = 1));
+ # Euclid's algorithm. #
+ PROC hcf = (INT m, n) INT:
+ BEGIN INT a := m, b := n;
+ IF a < b THEN swap (a, b) FI;
+ WHILE b /= 0
+ DO INT c = b; b := a MOD b; a := c OD;
+ a
+ END;
+ ASSERT (hcf (10, 20) = 10)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Recursive procedures. #
+BEGIN PROC f = (INT m, n) INT:
+ IF n = 0
+ THEN m
+ ELIF m < n
+ THEN f (n, m)
+ ELSE m * f (m % n, n - 1) + n * f (m - 1, n)
+ FI;
+ f (10, 20);
+ PROC a = (INT m, n) INT:
+ IF m = 0
+ THEN + 1
+ ELIF n = 0
+ THEN a (m - 1, 1)
+ ELSE a (m - 1, a (m, n - 1))
+ FI;
+ a (10, 20)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Using AND and OR #
+BEGIN ASSERT ((2r111 AND 2r101) = 2r101);
+ ASSERT ((16rff AND 2r111) = 16r7)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Comparing objects of mode BITS #
+BEGIN ASSERT (2r1010 <= 2r1110);
+ ASSERT (4r331 >= 8r74);
+ ASSERT (NOT (2r100 >= 2r011))
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Using BIN #
+BEGIN ASSERT (BIN 7 = 2r111);
+ INT i = 22;
+ ASSERT ((BITS b = BIN i; ABS (b SHL 3) + ABS (b SHL 1)) = 220)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Declarations of flexible names. #
+BEGIN FLEX[1:0]INT n;
+ ASSERT (LWB n = 1 AND UPB n = 0 AND ELEMS n = 0);
+ FLEX[4,6]INT p;
+ ASSERT (1 LWB p = 1 AND 1 UPB p = 4 AND 1 ELEMS p = 4
+ AND 2 LWB p = 1 AND 2 UPB p = 6 AND 2 ELEMS p = 6)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Null row displays an string denotations. #
+BEGIN FLEX[4]INT a, FLEX[4,6]INT b, FLEX[10]CHAR c;
+ a := ();
+ ASSERT (LWB a = 1 AND UPB a = 0);
+ b := ((),());
+ ASSERT (1 LWB b = 1 AND 1 UPB b = 2
+ AND 2 LWB b = 1 AND 2 UPB b = 0);
+ c := ();
+ c := ""
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Transient references and declarations. #
+BEGIN FLEX[4,6]INT p;
+ []INT q1 = p[3,]; # Transient name is dereferenced giving []INT #
+ REF FLEX[,]INT q5 = p; # p and q5 are different ways of accessing
+ the same name. #
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Virtual declarers. #
+BEGIN REF[]INT s;
+ STRUCT ([10]INT a, [4]REF[]INT b) c;
+ UNION (REF FLEX[]INT, PROC(INT)INT) f;
+ FLEX[4][3]INT a;
+ REF FLEX[][]INT aa = LOC FLEX[4][3]INT;
+ [4]FLEX[3]INT b;
+ REF[]FLEX[]INT bb = LOC[4]FLEX[3]INT;
+ SKIP
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN INT n := 3, m := 3;
+ REF INT w := n, z := n, REF INT y = n;
+ # Delivers TRUE since y and n deliver the same variable of mode REF
+ INT. No coercions take place.
+ #
+ ASSERT (y :=: n);
+ # Delivers TRUE. here w is dereferenced to yield n. The right
+ hand side is taken to be strong since dereferencing cannot
+ occur in a soft position.
+ #
+ ASSERT (n :=: w);
+ # Similarly delivers TRUE. Strong position is lhs. #
+ ASSERT (w :=: n);
+ # Delivers TRUE. No coercions take place. #
+ ASSERT (y ISNT m);
+ # Delivers true. w gets coerced to REF INT due to the strong
+ context introduced by the cast. No further coercions take place.
+ #
+ ASSERT (REF INT (w) :=: z);
+ # Delives true. No coercions take place. #
+ ASSERT (w :/=: z)
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+BEGIN
+ [3]INT a := (1,2,3);
+
+ CO Comparing transient or flex names using an identity relation is
+ undefined. Therefore, a[2:3] :=: a[2:3] is undefined.
+ CO
+
+ # But the following are defined. #
+ ASSERT (a[1] :=: a[1]);
+ ASSERT (a[1] :/=: a[2])
+END
--- /dev/null
+# { dg-options "-fstropping=upper" } #
+# Declarations involving global generators. #
+BEGIN REF REAL xx;
+ BEGIN REF REAL x = HEAP REAL := 4;
+ xx := x
+ END;
+ ASSERT (xx = 4)
+END
projects / thirdparty / gcc.git / commitdiff
