Add new tests.

From-SVN: r127554

11 files changed, 204 insertions, 0 deletions

diff --git a/gcc/testsuite/gnat.dg/access3.adb b/gcc/testsuite/gnat.dg/access3.adb
new file mode 100644
index 0000000..db109b3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/access3.adb
@@ -0,0 +1,16 @@
+
+package body access3 is
+   
+   type IT_Access is not null access all IT'Class;
+   for IT_Access'Storage_Size use 0;
+   
+   procedure Op
+     (Obj_T2 : in out T2;
+      Obj_IT : not null access IT'Class)
+   is 
+      X : constant IT_Access := Obj_IT.all'Unchecked_Access;
+   begin
+      null;
+   end Op;
+
+end access3;
diff --git a/gcc/testsuite/gnat.dg/access3.ads b/gcc/testsuite/gnat.dg/access3.ads
new file mode 100644
index 0000000..18d453b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/access3.ads
@@ -0,0 +1,11 @@
+
+package access3 is
+   type IT is limited interface;
+   type T is limited new IT with null record;
+   
+   type T2 is tagged limited null record;
+   
+   procedure Op
+     (Obj_T2 : in out T2;
+      Obj_IT : not null access IT'Class);
+end access3;
diff --git a/gcc/testsuite/gnat.dg/access4.adb b/gcc/testsuite/gnat.dg/access4.adb
new file mode 100644
index 0000000..2b00627
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/access4.adb
@@ -0,0 +1,9 @@
+--  { dg-do run }
+
+with access3; use access3;
+procedure access4 is
+   Obj_IT : aliased T;
+   Obj_T2 : T2;
+begin
+   Obj_T2.Op (Obj_IT'Access);
+end;
diff --git a/gcc/testsuite/gnat.dg/bad_array.adb b/gcc/testsuite/gnat.dg/bad_array.adb
new file mode 100644
index 0000000..5d49f9b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/bad_array.adb
@@ -0,0 +1,7 @@
+--  { dg-do compile }
+
+procedure Bad_Array is
+   A1 : array(Character range <> ) of Character := ( 'a', 'b', 'c' );
+begin
+   null;
+end Bad_Array;
diff --git a/gcc/testsuite/gnat.dg/discr4.adb b/gcc/testsuite/gnat.dg/discr4.adb
new file mode 100644
index 0000000..859daaf
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/discr4.adb
@@ -0,0 +1,47 @@
+--  { dg-do run }
+--  { dg-options "-gnatws" }
+
+procedure discr4 is
+   package Pkg is
+      type Rec_Comp (D : access Integer) is record
+         Data : Integer;
+      end record;
+--
+      type I is interface;
+      procedure Test (Obj : I) is abstract;
+--
+      Num : aliased Integer := 10;
+--
+      type Root (D : access Integer) is tagged record
+         C1 : Rec_Comp (D);           --  test
+      end record;
+--
+      type DT is new Root and I with null record;
+--
+      procedure Dummy (Obj : DT);
+      procedure Test  (Obj : DT);
+   end;
+--
+   package body Pkg is
+      procedure Dummy (Obj : DT) is
+      begin
+         raise Program_Error;
+      end;
+--
+      procedure Test (Obj : DT) is
+      begin
+         null;
+      end;
+   end;
+--
+   use Pkg;
+--
+   procedure CW_Test (Obj : I'Class) is
+   begin
+      Obj.Test;
+   end;
+--
+   Obj : DT (Num'Access);
+begin
+   CW_Test (Obj);
+end;
diff --git a/gcc/testsuite/gnat.dg/dispatch2.adb b/gcc/testsuite/gnat.dg/dispatch2.adb
new file mode 100644
index 0000000..ed57b13
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/dispatch2.adb
@@ -0,0 +1,10 @@
+--  { dg-do run }
+
+with dispatch2_p; use dispatch2_p;
+procedure dispatch2 is
+   Obj : Object_Ptr := new Object;
+begin
+   if Obj.Get_Ptr /= Obj.Impl_Of then
+      raise Program_Error;
+   end if;
+end;
diff --git a/gcc/testsuite/gnat.dg/dispatch2_p.adb b/gcc/testsuite/gnat.dg/dispatch2_p.adb
new file mode 100644
index 0000000..243c3ca
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/dispatch2_p.adb
@@ -0,0 +1,7 @@
+--
+package body dispatch2_p is
+  function Impl_Of (Self : access Object) return Object_Ptr is
+  begin
+    return Object_Ptr (Self);
+  end Impl_Of;
+end;
diff --git a/gcc/testsuite/gnat.dg/dispatch2_p.ads b/gcc/testsuite/gnat.dg/dispatch2_p.ads
new file mode 100644
index 0000000..e7852b4
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/dispatch2_p.ads
@@ -0,0 +1,8 @@
+package dispatch2_p is
+  type Object     is tagged null record;
+  type Object_Ptr is access all Object'CLASS;
+--
+  function Impl_Of (Self : access Object) return Object_Ptr;
+  function Get_Ptr (Self : access Object) return Object_Ptr
+    renames Impl_Of;
+end;
diff --git a/gcc/testsuite/gnat.dg/renaming2.adb b/gcc/testsuite/gnat.dg/renaming2.adb
new file mode 100644
index 0000000..0ec89c2
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/renaming2.adb
@@ -0,0 +1,61 @@
+--  { dg-do run }
+--  { dg-options "-gnatws" }
+
+with Text_IO;
+procedure renaming2 is
+    type RealNodeData;
+    type RefRealNodeData is access RealNodeData;
+
+    type ExpressionEntry;
+    type RefExpression is access ExpressionEntry;
+
+    type RefDefUseEntry is access Natural;
+    
+    type ExpressionEntry is
+    record
+        Number : RefDefUseEntry;
+        Id     : Integer;
+    end record;
+   
+    type RealNodeData is
+    record
+        Node   : RefExpression;
+        Id     : Integer; 
+    end record;
+            
+    for ExpressionEntry use
+    record
+        Number at 0 range  0 .. 63;
+        Id     at 8 range  0 .. 31;
+    end record ;
+        
+    for RealNodeData use
+    record
+        Node   at  0 range  0 .. 63;
+        Id     at 8 range  0 .. 31;
+    end record ;
+        
+    U_Node : RefDefUseEntry := new Natural'(1); 
+    E_Node : RefExpression := new ExpressionEntry'(Number => U_Node,
+                                                   Id => 2);
+    R_Node : RefRealNodeData := new RealNodeData'(Node => E_Node, 
+                                                   Id => 3);
+        
+    procedure test_routine (NodeRealData : RefRealNodeData)
+    is  
+        OldHead   : RefDefUseEntry renames NodeRealData.all.Node.all.Number;
+        OldHead1  : constant RefDefUseEntry := OldHead;
+    begin
+      NodeRealData.all.Node := new ExpressionEntry'(Number => null, Id => 4);
+      declare                                                   
+        OldHead2 : constant RefDefUseEntry := OldHead;
+      begin
+        if OldHead1 /= OldHead2
+        then
+          Text_IO.Put_Line (" OldHead changed !!!");
+        end if;
+      end;
+    end;
+begin
+  test_routine (R_Node);
+end;
diff --git a/gcc/testsuite/gnat.dg/specs/gnati.ads b/gcc/testsuite/gnat.dg/specs/gnati.ads
new file mode 100644
index 0000000..72eff6e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/gnati.ads
@@ -0,0 +1,13 @@
+--  { dg-do compile }
+--  { dg-options "-gnatI" }
+
+package gnati is
+   type j is range 1 .. 50;
+   for j'size use 1;
+   type n is new integer;
+   for n'alignment use -99;
+   type e is (a, b);
+   for e use (1, 1);
+   type r is record x : integer; end record;
+   for r use record x at 0 range 0 .. 0; end record;
+end gnati;
diff --git a/gcc/testsuite/gnat.dg/warn3.adb b/gcc/testsuite/gnat.dg/warn3.adb
new file mode 100644
index 0000000..66cc79b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/warn3.adb
@@ -0,0 +1,15 @@
+--  { dg-do compile }
+--  { dg-options "-gnatwu" }
+
+with Ada.Command_Line; use Ada.Command_Line;
+with Text_IO; use Text_IO;
+procedure warn3 is
+   type Weekdays is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);
+begin
+   if Argument_Count > 0 then
+      Put_Line
+        (Argument (1) & " is weekday number"
+         & Integer'Image
+            (Weekdays'Pos (Weekdays'Value (Argument (1)))));
+   end if;
+end;