Add new tests

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125622 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/testsuite/gnat.dg/assert1.adb b/gcc/testsuite/gnat.dg/assert1.adb
new file mode 100644 (file)
index 0000000..d761cd0
--- /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 (file)
index 0000000..bdad378
--- /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 (file)
index 0000000..3412688
--- /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 (file)
index 0000000..cf0fb5d
--- /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 (file)
index 0000000..6c972a4
--- /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 (file)
index 0000000..084ad38
--- /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 (file)
index 0000000..d0abbfa
--- /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 (file)
index 0000000..3b6829a
--- /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;