Add new tests

From-SVN: r125527

gcc/testsuite/gnat.dg/address_null_init.ads

+package Address_Null_Init is
+   
+   type Acc is access Integer;
+   A : Acc := new Integer'(123);
+   B : Acc;  -- Variable must be set to null (and A overwritten by null)
+   for B'Address use A'Address;
+
+end Address_Null_Init;

gcc/testsuite/gnat.dg/aggr3.adb

+--  { dg-do run }
+
+with Ada.Tags;    use Ada.Tags;
+with Ada.Text_IO; use Ada.Text_IO;
+procedure aggr3 is
+   package Pkg is
+      type Element is interface;
+      type Event is tagged record
+         V1 : Natural;
+         V2 : Natural;
+      end record;
+      function Create return Event;
+      type D_Event is new Event and Element with null record;
+      function Create return D_Event;
+   end;
+   package body Pkg is
+      function Create return Event is
+         Obj : Event;
+      begin
+         Obj.V1 := 0;
+         return Obj;
+      end;
+      function Create return D_Event is
+      begin
+         return (Event'(Create) with null record);
+      end;
+   end;
+   use Pkg;
+   procedure CW_Test (Obj : Element'Class) is
+      S : Constant String := Expanded_Name (Obj'Tag);
+   begin
+      null;
+   end;
+begin
+   CW_Test (Create);
+end;

gcc/testsuite/gnat.dg/aggr4.adb

+--  { dg-do compile }
+--  { dg-options "-gnatws" }
+
+procedure aggr4 is
+   type Byte is range 0 .. 2**8 - 1;
+   for Byte'Size use 8;
+        
+   type Time is array (1 .. 3) of Byte; 
+        
+   type UTC_Time is record 
+      Values : Time;
+   end record;
+
+   type Local_Time is record
+      Values : Time;
+   end record;
+   for Local_Time use record
+      Values at 0 range 1 .. 24;
+   end record;
+
+   LOC : Local_Time;
+   UTC : UTC_Time;
+
+begin
+   UTC.Values := LOC.Values;
+   UTC := (Values => LOC.Values);
+end;

gcc/testsuite/gnat.dg/aggr5.ads

+        
+package aggr5 is
+   type Event is limited interface;
+   type Event_Access is access all Event'Class;
+   type Q_Action_Event is limited interface and Event;
+   function Build (X : integer) return Event_Access;
+end aggr5;

gcc/testsuite/gnat.dg/aggr6.adb

+--  { dg-do compile }
+
+with aggr5;
+procedure aggr6 is
+   procedure Block is
+      Wrapper : aliased aggr5.Q_Action_Event'Class
+        := aggr5.Q_Action_Event'Class (aggr5.Build (0));
+   begin
+      null;
+   end; 
+begin
+   null;
+end;    

gcc/testsuite/gnat.dg/anon1.ads

+
+package anon1 is
+   function F return access Integer;
+end anon1;

gcc/testsuite/gnat.dg/anon2.adb

+-- { dg-do compile }
+
+with anon1;
+procedure anon2 is
+begin
+   if anon1.F /= null then
+      null;
+   end if;
+end anon2;

gcc/testsuite/gnat.dg/deques.ads

+package Deques is
+
+    type Deque (<>) is tagged limited private;
+    function Create return Deque;
+    procedure Pop (D : access Deque);
+
+    type Sequence is limited interface;
+    type P_Deque is new Deque and Sequence with private;
+    function Create return P_Deque;
+
+private
+    type Deque is tagged limited null record;
+    type P_Deque is new Deque and Sequence with null record;
+end Deques;

gcc/testsuite/gnat.dg/equal_access.adb

+--  { dg-do compile }
+
+procedure equal_access is
+   PA, PB  : access procedure := null;
+begin
+   if PA /= PB then
+      null;
+   end if;
+end;

gcc/testsuite/gnat.dg/ifaces.adb

+with Text_IO; use Text_IO;
+package body Ifaces is
+   procedure op1 (this : Root) is begin null; end;
+   procedure op2 (this : DT)   is begin null; end;
+end;

gcc/testsuite/gnat.dg/ifaces.ads

+
+package Ifaces is
+   type Iface_1 is interface;
+   procedure op1(this : Iface_1) is abstract;
+-- 
+   type Iface_2 is interface;
+   procedure op2 (this : Iface_2) is abstract;
+--    
+   type Root is new Iface_1 with record
+      m_name : String(1..4);
+   end record;
+-- 
+   procedure op1 (this : Root);
+--       
+   type DT is new Root and Iface_2 with null record;
+   procedure op2 (this : DT);
+end;

gcc/testsuite/gnat.dg/ref_type.adb

+
+--  { dg-do compile }
+
+package body ref_type is
+  type T is tagged null record;
+  procedure Print (X : T) is                                   
+  begin                                                        
+     null;
+  end;
+end ref_type;

gcc/testsuite/gnat.dg/ref_type.ads

+package ref_type is
+private
+   type T is tagged;
+   procedure Print (X : T);
+end ref_type;

gcc/testsuite/gnat.dg/rep_problem2.adb

+--  { dg-do compile }
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+procedure Rep_Problem2 is
+   
+   type Int_16 is range 0 .. 65535;
+   for Int_16'Size use 16;
+   
+   ----------------------------------------------
+      
+   type Rec_A is
+      record
+         Int_1 : Int_16;
+         Int_2 : Int_16;
+         Int_3 : Int_16;
+         Int_4 : Int_16;
+      end record;
+      
+      
+   for Rec_A use record
+      Int_1 at 0 range  0 .. 15;
+      Int_2 at 2 range  0 .. 15;
+      Int_3 at 4 range  0 .. 15;
+      Int_4 at 6 range  0 .. 15;
+   end record;
+   
+   Rec_A_Size : constant := 4 * 16;
+   
+   for Rec_A'Size use Rec_A_Size;
+   
+   ----------------------------------------------
+   
+   type Rec_B_Version_1 is
+      record
+         Rec_1 : Rec_A;
+         Rec_2 : Rec_A;
+         Int_1 : Int_16;
+      end record;
+  
+   for Rec_B_Version_1 use record
+      Rec_1 at  0 range  0 .. 63;
+      Rec_2 at  8 range  0 .. 63;
+      Int_1 at 16 range  0 .. 15;
+   end record;
+  
+   Rec_B_Size : constant := 2 * Rec_A_Size + 16;
+   
+   for Rec_B_Version_1'Size use Rec_B_Size;
+   for Rec_B_Version_1'Alignment use 2;
+
+   ----------------------------------------------
+
+   type Rec_B_Version_2 is
+      record
+         Int_1 : Int_16;
+         Rec_1 : Rec_A;
+         Rec_2 : Rec_A;
+      end record;
+   
+   for Rec_B_Version_2 use record
+      Int_1 at  0 range  0 .. 15;
+      Rec_1 at  2 range  0 .. 63;
+      Rec_2 at 10 range  0 .. 63;
+   end record;
+
+   for Rec_B_Version_2'Size use Rec_B_Size;
+   
+   ----------------------------------------------
+   
+   Arr_A_Length : constant := 2;
+   Arr_A_Size   : constant := Arr_A_Length * Rec_B_Size;
+   
+   type Arr_A_Version_1 is array (1 .. Arr_A_Length) of Rec_B_Version_1;
+   type Arr_A_Version_2 is array (1 .. Arr_A_Length) of Rec_B_Version_2;
+   
+   pragma Pack (Arr_A_Version_1);
+   pragma Pack (Arr_A_Version_2);
+   
+   for Arr_A_Version_1'Size use Arr_A_Size;
+   for Arr_A_Version_2'Size use Arr_A_Size;
+   
+   ----------------------------------------------
+
+begin
+   --  Put_Line ("Arr_A_Size =" & Arr_A_Size'Img);
+   
+   if Arr_A_Version_1'Size /= Arr_A_Size then
+      Ada.Text_IO.Put_Line
+        ("Version 1 Size mismatch! " &
+         "Arr_A_Version_1'Size =" & Arr_A_Version_1'Size'Img);
+   end if;
+   
+   if Arr_A_Version_2'Size /= Arr_A_Size then
+      Ada.Text_IO.Put_Line
+        ("Version 2 Size mismatch! " &
+         "Arr_A_Version_2'Size =" & Arr_A_Version_2'Size'Img);
+   
+   end if;
+
+end Rep_Problem2;

gcc/testsuite/gnat.dg/show_deques_priority.adb

+--  { dg-do compile }
+
+with Deques;
+procedure Show_Deques_Priority is
+    use Deques;
+
+    PD : aliased P_Deque := Create;
+
+begin
+    PD.Pop;
+end Show_Deques_Priority;

gcc/testsuite/gnat.dg/test_address_null_init.adb

+--  { dg-do run }
+--  { dg-options "-gnatws" }
+
+with Address_Null_Init;  use Address_Null_Init;
+with Ada.Text_IO;  use Ada.Text_IO;
+
+procedure Test_Address_Null_Init is
+begin
+   if B /= null then
+      Put_Line ("ERROR: B was not default initialized to null!");
+   end if;
+   
+   if A /= null then
+      Put_Line ("ERROR: A was not reinitialized to null!");
+   end if;
+end Test_Address_Null_Init;

gcc/testsuite/gnat.dg/test_ifaces.adb

+--  { dg-do run }
+
+with Ifaces; use Ifaces;
+procedure test_ifaces is
+   view2 : access Iface_2'Class;
+   obj   : aliased DT := (m_name => "Abdu");
+begin
+   view2 := Iface_2'Class(obj)'Access;
+   view2.all.op2;
+end;