diff --git a/gcc/testsuite/gnat.dg/assert1.adb b/gcc/testsuite/gnat.dg/assert1.adb new file mode 100644 index 00000000000..d761cd0d990 --- /dev/null +++ b/gcc/testsuite/gnat.dg/assert1.adb @@ -0,0 +1,39 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +pragma Assertion_Policy (Check); +with Text_IO; use Text_IO; +procedure assert1 is + type p1 is array (1 .. 113) of Boolean; + pragma Pack (p1); + type p2 is array (1 .. 13) of Boolean; + pragma Pack (p2); + type p3 is array (1 .. 113) of Boolean; + pragma Pack (p3); + for p3'size use 113; + type p4 is array (1 .. 13) of Boolean; + pragma Pack (p4); + for p4'size use 13; + v1 : p1; + v2 : p2; + v3 : p3; + v4 : p4; +begin + pragma Assert (p1'Size = 120); + pragma Assert (p2'Size = 13); + pragma Assert (p3'Size = 113); + pragma Assert (p4'Size = 13); + pragma Assert (p1'Value_Size = 120); + pragma Assert (p2'Value_Size = 13); + pragma Assert (p3'Value_Size = 113); + pragma Assert (p4'Value_Size = 13); + pragma Assert (p1'Object_Size = 120); + pragma Assert (p2'Object_Size = 16); + pragma Assert (p3'Object_Size = 120); + pragma Assert (p4'Object_Size = 16); + pragma Assert (v1'Size = 120); + pragma Assert (v2'Size = 16); + pragma Assert (v3'Size = 120); + pragma Assert (v4'Size = 16); + null; +end; diff --git a/gcc/testsuite/gnat.dg/g_tables.adb b/gcc/testsuite/gnat.dg/g_tables.adb new file mode 100644 index 00000000000..bdad37850cb --- /dev/null +++ b/gcc/testsuite/gnat.dg/g_tables.adb @@ -0,0 +1,8 @@ +-- { dg-options "-gnatws" } + +package body G_Tables is + function Create (L : Natural) return Table is + begin + return T : Table (1 .. L); + end Create; +end G_Tables; diff --git a/gcc/testsuite/gnat.dg/g_tables.ads b/gcc/testsuite/gnat.dg/g_tables.ads new file mode 100644 index 00000000000..34126882a59 --- /dev/null +++ b/gcc/testsuite/gnat.dg/g_tables.ads @@ -0,0 +1,9 @@ +generic + type Component is private; +package G_Tables is + type Table (<>) is limited private; + + function Create (L : Natural) return Table; +private + type Table is array (Positive range <>) of Component; +end G_Tables; diff --git a/gcc/testsuite/gnat.dg/sort1.adb b/gcc/testsuite/gnat.dg/sort1.adb new file mode 100644 index 00000000000..cf0fb5d5fac --- /dev/null +++ b/gcc/testsuite/gnat.dg/sort1.adb @@ -0,0 +1,27 @@ +with GNAT.Heap_Sort_G; +function sort1 (S : String) return String is + Result : String (1 .. S'Length) := S; + Temp : Character; + + procedure Move (From : Natural; To : Natural) is + begin + if From = 0 then Result (To) := Temp; + elsif To = 0 then Temp := Result (From); + else Result (To) := Result (From); + end if; + end Move; + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + if Op1 = 0 then return Temp < Result (Op2); + elsif Op2 = 0 then return Result (Op1) < Temp; + else return Result (Op1) < Result (Op2); + end if; + end Lt; + + package SP is new GNAT.Heap_Sort_G (Move, Lt); + +begin + SP.Sort (S'Length); + return Result; +end; diff --git a/gcc/testsuite/gnat.dg/sort1.ads b/gcc/testsuite/gnat.dg/sort1.ads new file mode 100644 index 00000000000..6c972a489a4 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sort1.ads @@ -0,0 +1,2 @@ +function sort1 (S : String) return String; +pragma Pure (sort1); diff --git a/gcc/testsuite/gnat.dg/sort2.adb b/gcc/testsuite/gnat.dg/sort2.adb new file mode 100644 index 00000000000..084ad38bf45 --- /dev/null +++ b/gcc/testsuite/gnat.dg/sort2.adb @@ -0,0 +1,9 @@ +-- { dg-do run } + +with sort1; +procedure sort2 is +begin + if Sort1 ("hello world") /= " dehllloorw" then + raise Program_Error; + end if; +end sort2; diff --git a/gcc/testsuite/gnat.dg/test_tables.adb b/gcc/testsuite/gnat.dg/test_tables.adb new file mode 100644 index 00000000000..d0abbfa5763 --- /dev/null +++ b/gcc/testsuite/gnat.dg/test_tables.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } +-- { dg-options "-gnatws" } + +with G_tables; +procedure test_tables is + package Inst is new G_Tables (Integer); + use Inst; + It : Inst.Table := Create (15); +begin + null; +end; diff --git a/gcc/testsuite/gnat.dg/tfren.adb b/gcc/testsuite/gnat.dg/tfren.adb new file mode 100644 index 00000000000..3b6829a967d --- /dev/null +++ b/gcc/testsuite/gnat.dg/tfren.adb @@ -0,0 +1,35 @@ +-- { dg-do run } +-- { dg-options "-gnatws" } + +procedure Tfren is + type R; + type Ar is access all R; + type R is record F1: Integer; F2: Ar; end record; + + for R use record + F1 at 1 range 0..31; + F2 at 5 range 0..63; + end record; + + procedure Foo (RR1, RR2: Ar); + + procedure Foo (RR1, RR2 : Ar) is + begin + if RR2.all.F1 /= 55 then raise program_error; end if; + end; + + R3: aliased R := (55, Null); + R2: aliased R := (44, R3'Access); + R1: aliased R := (22, R2'Access); + P: Ar := R1'Access; + + X: Ar renames P.all.F2; + Y: Ar renames X.all.F2; + +begin + P := R2'Access; + R1.F2 := R1'Access; + Foo (X, Y); + Y.F1 := -111; + if Y.F1 /= -111 then raise Constraint_Error; end if; +end Tfren;