Add new Ada test cases.

From-SVN: r118332

gcc/testsuite/gnat.dg/abstract_with_anonymous_result.adb

@@ -0,0 +1,37 @@
+-- { dg-do run }
+
+procedure Abstract_With_Anonymous_Result is
+
+   package Pkg is
+      type I is abstract tagged null record;
+      type Acc_I_Class is access all I'Class;
+      function Func (V : I) return access I'Class is abstract;
+      procedure Proc (V : access I'Class);
+      type New_I is new I with null record;
+      function Func (V : New_I) return access I'Class;
+   end Pkg;
+
+   package body Pkg is
+      X : aliased New_I;
+
+      procedure Proc (V : access I'Class) is begin null; end Proc;
+
+      function Func (V : New_I) return access I'Class is
+      begin
+         X := V;
+         return X'Access;
+      end Func;
+   end Pkg;
+
+   use Pkg;
+
+   New_I_Obj : aliased New_I;
+
+   procedure Proc2 (V : access I'Class) is
+   begin
+      Proc (Func (V.all));  -- Call to Func causes gigi abort 122
+   end Proc2;
+
+begin
+   Proc2 (New_I_Obj'Access);
+end Abstract_With_Anonymous_Result;

gcc/testsuite/gnat.dg/access_discr.adb

@@ -0,0 +1,22 @@
+-- { dg-do compile }
+
+procedure access_discr is
+   
+   type One;
+   
+   type Iface is limited interface;
+   type Base  is tagged limited null record;
+   
+   type Two_Alone (Parent : access One) is limited null record;
+   type Two_Iface (Parent : access One) is limited new Iface with null record;
+   type Two_Base (Parent : access One) is new Base with null record;
+   
+   type One is record
+      TA : Two_Alone (One'Access);
+      TI : Two_Iface (One'Access); --  OFFENDING LINE
+      TB : Two_Base (One'Access);
+   end record;
+
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/access_func.adb

@@ -0,0 +1,10 @@
+-- { dg-do compile }
+
+procedure access_func is
+    type Abomination is access
+       function (X : Integer) return access
+       function (Y : Float) return access
+       function return Integer;
+begin
+    null;
+end;

gcc/testsuite/gnat.dg/align_check.adb

@@ -0,0 +1,21 @@
+-- { dg-do run }
+
+with System; 
+procedure align_check is
+   N_Allocated_Buffers : Natural := 0;
+--      
+   function New_Buffer (N_Bytes : Natural) return System.Address is
+   begin   
+      N_Allocated_Buffers := N_Allocated_Buffers + 1;
+      return System.Null_Address;
+   end;    
+--      
+   Buffer_Address : constant System.Address := New_Buffer (N_Bytes => 8);
+   N : Natural;
+   for N'Address use Buffer_Address;
+--      
+begin   
+   if N_Allocated_Buffers /= 1 then
+      raise Program_Error;
+   end if; 
+end;    

gcc/testsuite/gnat.dg/alignment1.adb

@@ -0,0 +1,16 @@
+-- { dg-do run }
+-- { dg-options "-gnatws" }
+
+procedure alignment1 is
+
+  type My_Integer is record
+    Element : Integer;
+  end record;
+
+  F : My_Integer;
+
+begin
+  if F'Alignment /= F.Element'Alignment then
+    raise Program_Error;
+  end if;
+end;

gcc/testsuite/gnat.dg/biased_uc.adb

@@ -0,0 +1,54 @@
+-- { do-do run }
+-- { do-options "-gnatws" }
+
+with Unchecked_Conversion;
+procedure biased_uc is
+begin
+    --  Case (f) target type is biased, source is unbiased
+
+    declare 
+       type a is new integer range 0 .. 255; 
+       for a'size use 8;
+
+       type b is new integer range 200 .. 455; 
+       for b'size use 8;
+
+       av : a; 
+       bv : b; 
+
+       for av'size use 8;
+       for bv'size use 8;
+
+       function a2b is new Unchecked_Conversion (a,b);
+
+    begin   
+       bv := a2b (200);
+       if bv = 200 then
+          raise Program_Error;
+       end if; 
+    end;    
+
+    --  Case (g) target type is biased, source object is biased
+
+    declare 
+       type a is new integer range 1 .. 256; 
+       for a'size use 16; 
+
+       type b is new integer range 1 .. 65536;
+       for b'size use 16;
+
+       av : a;
+       bv : b;
+
+       for av'size use 8;
+       for bv'size use 16;
+
+       function a2b is new Unchecked_Conversion (a,b);
+
+    begin
+       bv := a2b (1);
+       if bv /= 2 then
+          raise Program_Error;
+       end if;
+    end;
+end;

gcc/testsuite/gnat.dg/capture_value.adb

@@ -0,0 +1,16 @@
+-- { dg-do run }
+
+procedure capture_value is
+   x : integer := 0;
+begin
+   declare
+      z : integer renames x;
+   begin
+      z := 3;
+      x := 5;
+      z := z + 1;
+      if z /= 6 then
+         raise Program_Error;
+      end if;
+   end;
+end;

gcc/testsuite/gnat.dg/case_null.adb

@@ -0,0 +1,16 @@
+-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+package body Case_Null is
+   procedure P1 (X : T) is
+   begin
+      case X is
+         when S1 =>
+           null;
+         when e =>
+           null;
+         when others =>
+           null;
+      end case;
+   end P1;
+end Case_Null;

gcc/testsuite/gnat.dg/case_null.ads

@@ -0,0 +1,11 @@
+package Case_Null is
+   type T is (a, b, c, d, e);
+
+   subtype S is T range b .. d;
+
+   subtype S1 is S range a .. d;
+   --  Low bound out of range of base subtype.
+
+   procedure P1 (X : T);
+
+end Case_Null;

gcc/testsuite/gnat.dg/class_wide.adb

@@ -0,0 +1,26 @@
+-- { dg-do compile }
+
+procedure class_wide is
+    package P is
+       type T is tagged null record;
+       procedure P1 (x : T'Class);
+       procedure P2 (x : access T'Class);
+    end P;
+    package body P is
+        procedure P1 (x : T'Class) is 
+       begin 
+          null;
+       end;
+       procedure P2 (x : access T'Class) is
+       begin
+          null;
+       end;
+    end P;
+    use P;
+    a : T;
+    type Ptr is access T;
+    b : Ptr := new T;
+begin
+    A.P1;
+    B.P2;
+end;

gcc/testsuite/gnat.dg/conv_real.adb

@@ -0,0 +1,18 @@
+-- { dg-do run }
+
+with Interfaces; use Interfaces;
+procedure Conv_Real is
+   Small : constant := 10.0**(-9);
+   type Time_Type is delta Small range -2**63 * Small .. (2**63-1) * Small;
+   for Time_Type'Small use Small;
+   for Time_Type'Size use 64; 
+   procedure Cache (Seconds_Per_GDS_Cycle : in Time_Type) is
+      Cycles_Per_Second : constant Time_Type  := (1.0 / Seconds_Per_GDS_Cycle);
+   begin   
+      if Integer_32 (Seconds_Per_GDS_Cycle * Cycles_Per_Second) /= 1 then
+         raise Program_Error;
+      end if; 
+   end Cache;
+begin   
+   Cache (0.035);
+end;

gcc/testsuite/gnat.dg/curr_task.adb

@@ -0,0 +1,134 @@
+-- { dg-do run }
+-- { dg-options "-gnatws" }
+
+with Ada.Exceptions;
+with Ada.Text_IO;
+with Ada.Task_Identification;
+
+procedure Curr_Task is
+
+   use Ada.Task_Identification;
+
+   --  Simple semaphore
+
+   protected Semaphore is
+      entry Lock;
+      procedure Unlock;
+   private
+      TID        : Task_Id := Null_Task_Id;
+      Lock_Count : Natural := 0;
+   end Semaphore;
+
+   ----------
+   -- Lock --
+   ----------
+
+   procedure Lock is
+   begin
+      Semaphore.Lock;
+   end Lock;
+
+   ---------------
+   -- Semaphore --
+   ---------------
+
+   protected body Semaphore is
+
+      ----------
+      -- Lock --
+      ----------
+
+      entry Lock when Lock_Count = 0
+        or else TID = Current_Task
+      is
+      begin
+         if not
+           (Lock_Count = 0
+            or else TID = Lock'Caller)
+         then
+            Ada.Text_IO.Put_Line
+              ("Barrier leaks " & Lock_Count'Img
+                 & ' ' & Image (TID)
+                 & ' ' & Image (Lock'Caller));
+         end if;
+
+         Lock_Count := Lock_Count + 1;
+         TID := Lock'Caller;
+      end Lock;
+
+      ------------
+      -- Unlock --
+      ------------
+
+      procedure Unlock is
+      begin
+         if TID = Current_Task then
+            Lock_Count := Lock_Count - 1;
+         else
+            raise Tasking_Error;
+         end if;
+      end Unlock;
+
+   end Semaphore;
+
+   ------------
+   -- Unlock --
+   ------------
+
+   procedure Unlock is
+   begin
+      Semaphore.Unlock;
+   end Unlock;
+
+   task type Secondary is
+      entry Start;
+   end Secondary;
+
+   procedure Parse (P1 : Positive);
+
+   -----------
+   -- Parse --
+   -----------
+
+   procedure Parse (P1 : Positive) is
+   begin
+      Lock;
+      delay 0.01;
+
+      if P1 mod 2 = 0 then
+         Lock;
+         delay 0.01;
+         Unlock;
+      end if;
+
+      Unlock;
+   end Parse;
+
+   ---------------
+   -- Secondary --
+   ---------------
+
+   task body Secondary is
+   begin
+      accept Start;
+
+      for K in 1 .. 20 loop
+         Parse (K);
+      end loop;
+
+      raise Constraint_Error;
+
+   exception
+      when Program_Error =>
+         null;
+   end Secondary;
+
+   TS : array (1 .. 2) of Secondary;
+
+begin
+   Parse (1);
+
+   for J in TS'Range loop
+      TS (J).Start;
+   end loop;
+end Curr_Task;

gcc/testsuite/gnat.dg/discr_range_check.adb

@@ -0,0 +1,18 @@
+-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+procedure discr_range_check is
+   Default_First_Entry : constant := 1;
+
+   task type Server_T (First_Entry : Positive := Default_First_Entry) is
+      entry E (First_Entry .. First_Entry);
+   end Server_T;
+
+   task body Server_T is begin null; end;
+
+   type Server_Access is access Server_T;
+   Server : Server_Access;
+
+begin   
+   Server := new Server_T;
+end;    

gcc/testsuite/gnat.dg/dispatch1.adb

@@ -0,0 +1,9 @@
+-- { dg-do run }
+
+with dispatch1_p; use dispatch1_p;
+procedure dispatch1 is
+   O   : DT_I1;
+   Ptr : access I1'Class;
+begin
+   Ptr := new I1'Class'(I1'Class (O));
+end;

gcc/testsuite/gnat.dg/dispatch1_p.ads

@@ -0,0 +1,4 @@
+package dispatch1_p is
+   type I1 is interface;
+   type DT_I1 is new I1 with null record;
+end;

gcc/testsuite/gnat.dg/env_compile_capacity.adb

@@ -0,0 +1,24 @@
+-- { do-do compile }
+
+with My_Env_Versioned_Value_Set_G;
+package body Env_Compile_Capacity is
+  generic 
+    with package Env_Obj_Set_Instance is
+       new My_Env_Versioned_Value_Set_G(<>);
+    with function Updated_Entity (Value : Env_Obj_Set_Instance.Value_T)
+        return Boolean is <>;
+    with package Entity_Upd_Iteration is
+       new Env_Obj_Set_Instance.Update_G (Updated_Entity);
+  procedure Compile_G;
+  procedure Compile_G is begin null; end;
+  package My_Env_Aerodrome is
+     new My_Env_Versioned_Value_Set_G (Value_T => String);
+  function Updated_Entity (Id : in String) return Boolean is
+    begin return True; end;
+  package Iteration_Aerodrome_Arrival is
+     new My_Env_Aerodrome.Update_G (Updated_Entity);
+  procedure Aerodrome_Arrival is new Compile_G
+    (Env_Obj_Set_Instance  => My_Env_Aerodrome,
+     Updated_Entity        => Updated_Entity,
+     Entity_Upd_Iteration  => Iteration_Aerodrome_Arrival);
+end Env_Compile_Capacity;

gcc/testsuite/gnat.dg/env_compile_capacity.ads

@@ -0,0 +1 @@
+package Env_Compile_Capacity is pragma Elaborate_Body; end;

gcc/testsuite/gnat.dg/generic_dispatch.adb

@@ -0,0 +1,9 @@
+--  { dg-do run }
+
+with generic_dispatch_p; use generic_dispatch_p;
+procedure generic_dispatch is
+   I : aliased Integer := 0;
+   D : Iface'Class := Dispatching_Constructor (DT'Tag, I'access);
+begin   
+   null;   
+end generic_dispatch;

gcc/testsuite/gnat.dg/generic_dispatch_p.adb

@@ -0,0 +1,7 @@
+package body generic_dispatch_p is
+   function Constructor (I : not null access Integer) return DT is
+      R : DT; 
+  begin
+      return R;
+   end Constructor;
+end;

gcc/testsuite/gnat.dg/generic_dispatch_p.ads

@@ -0,0 +1,13 @@
+with Ada.Tags.Generic_Dispatching_Constructor;
+package generic_dispatch_p is
+   type Iface is interface;
+   function Constructor (I : not null access Integer) return Iface is abstract;
+   function Dispatching_Constructor
+      is new Ada.Tags.Generic_Dispatching_Constructor
+               (T           => Iface,
+                Parameters  => Integer,
+                Constructor => Constructor);
+   type DT is new Iface with null record; 
+   overriding
+   function Constructor (I : not null access Integer) return DT;
+end;

gcc/testsuite/gnat.dg/gnat_malloc.adb

@@ -0,0 +1,25 @@
+-- { dg-do run }
+-- { dg-options "-O2" }
+
+with Unchecked_Conversion;
+
+procedure gnat_malloc is
+
+   type int1 is new integer;
+   type int2 is new integer;
+   type a1 is access int1;
+   type a2 is access int2;
+
+   function to_a2 is new Unchecked_Conversion (a1, a2);
+
+   v1 : a1 := new int1;
+   v2 : a2 := to_a2 (v1);
+
+begin
+   v1.all := 1;
+   v2.all := 0;
+
+   if v1.all /= 0 then
+      raise Program_Error;
+   end if;
+end;

gcc/testsuite/gnat.dg/gnatg.adb

@@ -0,0 +1,13 @@
+-- { dg-do compile }
+-- { dg-options "-gnatD" }
+
+with System; 
+with Ada.Unchecked_Conversion;
+procedure gnatg is
+   subtype Address is System.Address;
+   type T is access procedure;
+   function Cvt is new Ada.Unchecked_Conversion (Address, T);
+   X : T;  
+begin   
+   X := Cvt (Gnatg'Address);
+end gnatg;

gcc/testsuite/gnat.dg/ice_type.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+with ICE_Types; use ICE_Types;
+procedure ICE_Type is
+   type Local_Float_T is new Float_View_T;
+   LF : Local_Float_T;
+begin
+   Initialize (Float_View_T (LF));
+end;

gcc/testsuite/gnat.dg/ice_types.ads

@@ -0,0 +1,6 @@
+package ICE_Types is
+   type Float_View_T is private;
+   procedure Initialize (X : out Float_View_T);
+private
+   type Float_View_T is new Float;
+end;

gcc/testsuite/gnat.dg/in_mod_conv.adb

@@ -0,0 +1,24 @@
+-- { do-do compile }
+
+procedure in_mod_conv is
+   package Test is 
+     type T  is new Natural range 1..6;
+     subtype T_SubType is T range 3..5;
+     type A1 is array (T range <>) of boolean;
+     type A2 is new A1 (T_SubType);
+     PRAGMA pack (A2);
+     type New_A2 is new A2; 
+  end Test;
+  package body Test is 
+     procedure P1 (Obj : in New_A2) is
+     begin   
+        null;   
+     end P1; 
+     procedure P2 (Data : in out A2) is
+     begin   
+        P1 (New_A2 (Data (T_SubType)));  -- test 
+     end P2; 
+  end Test;
+begin   
+   null;   
+end;

gcc/testsuite/gnat.dg/inline_scope.adb

@@ -0,0 +1,15 @@
+-- { do-do compile }
+-- { do-options "-gnatN" }
+
+with inline_scope_p;
+procedure inline_scope (X : Integer) is
+   type A is array (Integer range 1 .. 2) of Boolean;
+   S : A;  
+   pragma Warnings (Off, S);
+   procedure Report_List  is
+   begin   
+      inline_scope_p.Assert (S (1), Natural'Image (Natural (1)));
+   end Report_List;
+begin   
+   null;   
+end;    

gcc/testsuite/gnat.dg/inline_scope_p.adb

@@ -0,0 +1,8 @@
+package body inline_scope_p is
+   procedure Assert (Expr : Boolean; Str : String) is
+   begin   
+      if Expr then
+         null;   
+      end if; 
+   end Assert; 
+end;    

gcc/testsuite/gnat.dg/inline_scope_p.ads

@@ -0,0 +1,4 @@
+package inline_scope_p is
+    procedure Assert (Expr : Boolean; Str : String);
+    pragma Inline (Assert);
+end;    

gcc/testsuite/gnat.dg/inline_tagged.adb

@@ -0,0 +1,35 @@
+-- { dg-do run }
+-- { dg-options "-gnatN" }
+
+with Text_IO; use Text_IO;
+with system; use system; 
+procedure inline_tagged is
+   package Pkg is
+      type T_Inner is tagged record
+         Value : Integer;
+      end record; 
+      type T_Inner_access is access all T_Inner;
+      procedure P2 (This : in T_Inner; Ptr : address);
+      pragma inline (P2);
+      type T_Outer is record
+           Inner : T_Inner_Access;
+      end record; 
+      procedure P1 (This : access T_Outer);
+   end Pkg;
+   package body Pkg is
+      procedure P2 (This : in T_Inner; Ptr : address) is
+      begin   
+         if this'address /= Ptr then
+            raise Program_Error;
+         end if;
+      end;    
+      procedure P1 (This : access T_Outer) is
+      begin
+         P2 (This.Inner.all, This.Inner.all'Address);
+      end P1; 
+   end Pkg;
+   use Pkg;
+   Thing : aliased T_Outer := (inner => new T_Inner);
+begin   
+   P1 (Thing'access);
+end;    

gcc/testsuite/gnat.dg/interface_conv.adb

@@ -0,0 +1,17 @@
+-- { dg-do run }
+
+procedure Interface_Conv is
+   package Pkg is
+      type I1 is interface;
+      procedure Prim (X : I1) is null;
+      type I2 is interface;
+      procedure Prim (X : I2) is null;
+      type DT is new I1 and I2 with null record;
+   end Pkg;
+   use Pkg;
+   Obj  : DT;
+   CW_3 : I2'Class := Obj;
+   CW_5 : I1'Class := I1'Class (CW_3);  --  test
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/kill_value.adb

@@ -0,0 +1,20 @@
+-- { dg-do run }
+
+procedure kill_value is
+   type Struct;
+   type Pstruct is access all Struct;
+   
+   type Struct is record Next : Pstruct; end record;
+   
+   Vap : Pstruct := new Struct;
+
+begin
+   for J in 1 .. 10 loop
+      if Vap /= null then
+         while Vap /= null
+         loop
+            Vap := Vap.Next;
+         end loop;
+      end if;
+   end loop;
+end;

gcc/testsuite/gnat.dg/late_overriding.adb

@@ -0,0 +1,15 @@
+-- { dg-do compile }
+
+procedure late_overriding is
+   package Pkg is
+      type I is interface;
+      procedure Meth (O : in I) is abstract;
+      type Root is abstract tagged null record; 
+      type DT1 is abstract new Root and I with null record; 
+   end Pkg;
+   use Pkg;
+   type DT2 is new DT1 with null record; 
+   procedure Meth (X : DT2) is begin null; end;  --  Test
+begin   
+   null;   
+end;

gcc/testsuite/gnat.dg/layered_abstraction.adb

@@ -0,0 +1,9 @@
+package body  Layered_Abstraction is
+    Z : P1.T := P2.Obj;  -- Both P1.T and P2.Obj are visible because 
+                         -- they were not specified in the formal package.
+                         -- Note that P2.T is not visible since it
+                         -- is required to match P1.T
+
+    use P1;              --  to make equality immediately visible 
+    Yes_Again : Boolean := P1.Obj2 = P2.Obj2;
+end Layered_Abstraction;

gcc/testsuite/gnat.dg/layered_abstraction.ads

@@ -0,0 +1,13 @@
+with Layered_Abstraction_P;
+generic 
+    with package P1 is new Layered_Abstraction_P(<>);
+    with package P2 is new Layered_Abstraction_P(T => P1.T, Obj => <>); 
+package Layered_Abstraction is
+    pragma Elaborate_Body;
+    X : P1.T := P2.Obj;  -- Both P1.T and P2.Obj are visible because 
+                         -- they were not specified in the formal package.                               -- Note that P2.T is not visible since it
+                         -- is required to match P1.T
+
+    use P1;              --  to make equality immediately visible 
+    Yes : Boolean := P1.Obj2 = P2.Obj2;
+end Layered_Abstraction;

gcc/testsuite/gnat.dg/layered_abstraction_p.ads

@@ -0,0 +1,6 @@
+generic 
+    type T is private;
+    Obj : T;
+package Layered_Abstraction_P is
+   Obj2 : T := Obj; 
+end;    

gcc/testsuite/gnat.dg/layered_instance.adb

@@ -0,0 +1,11 @@
+-- { do-do compile }
+
+with Layered_Abstraction_P;
+with layered_abstraction;
+procedure layered_instance is
+   package s1 is new Layered_Abstraction_P (Integer, 15);
+   package S2 is new Layered_Abstraction_P (Integer, 20);
+   package Inst is new layered_abstraction (S1, S2);
+begin   
+   null;   
+end;    

gcc/testsuite/gnat.dg/limited_with.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+
+with Pack1;
+package body limited_with is
+   procedure Print_2 (Obj : access Pack1.Nested.Rec_Typ) is
+   begin
+      null;
+   end;
+end limited_with;

gcc/testsuite/gnat.dg/limited_with.ads

@@ -0,0 +1,4 @@
+limited with Pack1;
+package limited_with is
+   procedure Print_2 (Obj : access Pack1.Nested.Rec_Typ);
+end limited_with;

gcc/testsuite/gnat.dg/loop_bound.adb

@@ -0,0 +1,26 @@
+-- { dg-do compile }
+
+procedure loop_bound is
+   package P is
+      type Base is new Integer;
+      Limit : constant Base := 10;
+      type Index is private;
+      generic package Gen is end;
+   private 
+      type Index is new Base range 0 .. Limit;
+   end P;  
+   package body P is
+      package body Gen is
+         type Table is array (Index) of Integer;
+         procedure Init (X : in out Table) is
+         begin   
+            for I in 1..Index'last -1 loop 
+               X (I) := -1;
+            end loop;
+         end Init;
+      end Gen;
+   end P;  
+   package Inst is new P.Gen;
+begin   
+   null;   
+end;    

gcc/testsuite/gnat.dg/machine_code1.adb

@@ -0,0 +1,11 @@
+-- { dg-do compile }
+-- { dg-options "-gnatws" }
+
+with System.Machine_Code; use System.Machine_Code;
+procedure machine_code1 is
+   A_Float        : Float;
+   An_Other_Float : Float := -99999.0;
+begin
+   An_Other_Float := An_Other_Float - A_Float;
+   Asm("", Inputs => (Float'Asm_Input ("m", A_Float)));
+end;

gcc/testsuite/gnat.dg/my_env_versioned_value_set_g.ads

@@ -0,0 +1,7 @@
+generic 
+  type Value_T(<>) is private;
+package My_Env_Versioned_Value_Set_G is
+  generic 
+    with function Updated_Entity (Value : Value_T) return Boolean is <>;
+  package Update_G is end; 
+end;    

gcc/testsuite/gnat.dg/nested_controlled_alloc.adb

@@ -0,0 +1,49 @@
+-- { dg-do run }
+
+with Text_IO; use Text_IO;
+with Ada.Finalization; use Ada.Finalization;
+
+procedure Nested_Controlled_Alloc is
+   
+   package Controlled_Alloc is
+
+      type Fin is new Limited_Controlled with null record;
+      procedure Finalize (X : in out Fin);
+
+      F : Fin;
+      
+      type T is limited private;
+      type Ref is access all T;
+   
+   private
+      
+      type T is new Limited_Controlled with null record;
+      procedure Finalize (X : in out T);
+   
+   end Controlled_Alloc;
+   
+   package body Controlled_Alloc is
+
+       procedure Finalize (X : in out T) is
+       begin
+          Put_Line ("Finalize (T)");
+       end Finalize;
+
+       procedure Finalize (X : in out Fin) is
+          R : Ref;
+       begin
+          begin
+             R := new T;
+             raise Constraint_Error;
+          
+          exception
+             when Program_Error =>
+                null;  -- OK
+          end;
+       end Finalize;
+   
+   end Controlled_Alloc;
+
+begin
+   null;
+end Nested_Controlled_Alloc;

gcc/testsuite/gnat.dg/nested_return_test.adb

@@ -0,0 +1,33 @@
+-- { dg-do run }
+-- { dg-options "-gnata" }
+
+procedure Nested_Return_Test is
+   function H (X: integer) return access integer is
+      Local : aliased integer := (X+1);
+   begin 
+      case X is
+         when 3 =>
+            begin
+              return Result : access integer do
+                  Result := new integer '(27);
+                  begin
+                     for I in 1 .. 10 loop
+                       result.all := result.all + 10;
+                     end loop;
+                     return;
+                  end;
+              end return;
+            end;
+         when 5 =>
+            return Result: Access integer do
+               Result := New Integer'(X*X*X);
+            end return;
+         when others =>
+            return null;
+      end case;
+   end;
+begin
+   pragma Assert (H (3).all = 127);
+   pragma Assert (H (5).all = 125);
+   null;
+end Nested_Return_Test;

gcc/testsuite/gnat.dg/overriding_ops.adb

@@ -0,0 +1,15 @@
+-- { dg-do compile }
+
+package body overriding_ops is
+   task body Light_Programmer is
+   begin
+      accept Set_Name (Name : Name_Type);
+   end Light_Programmer;
+
+   protected body Light is
+      procedure Set_Name (Name : Name_Type) is
+      begin
+         L_Name := Name;
+      end Set_Name;
+   end Light;
+end overriding_ops;

gcc/testsuite/gnat.dg/overriding_ops.ads

@@ -0,0 +1,12 @@
+with overriding_ops_p; use overriding_ops_p;
+package overriding_ops is
+   task type Light_Programmer is new Device with
+      overriding entry Set_Name (Name : Name_Type);
+   end Light_Programmer;
+   --  Object that represents a light 
+   protected type Light is new Device with
+      overriding procedure Set_Name (Name : Name_Type);
+   private 
+      L_Name : Name_Type;
+   end Light;
+end overriding_ops;

gcc/testsuite/gnat.dg/overriding_ops_p.ads

@@ -0,0 +1,8 @@
+package overriding_ops_p is
+   subtype Name_Type is String (1 .. 30); 
+   type Device is synchronized interface;
+   --  Base type of devices 
+   procedure Set_Name (Object : in out Device; Name : Name_Type)
+     is abstract;
+   --  Set the name of the Device
+end overriding_ops_p;

gcc/testsuite/gnat.dg/pack1.ads

@@ -0,0 +1,7 @@
+package Pack1 is
+   package Nested is
+      type Rec_Typ is record
+         null;
+      end record;
+   end Nested;
+end Pack1;

gcc/testsuite/gnat.dg/pointer_protected.adb

@@ -0,0 +1,10 @@
+-- { dg-do compile }
+
+with pointer_protected_p;
+
+procedure pointer_protected is
+   Pointer : pointer_protected_p.Ptr := null;
+   Data    : pointer_protected_p.T;
+begin
+   Pointer.all (Data);
+end pointer_protected;

gcc/testsuite/gnat.dg/pointer_protected_p.ads

@@ -0,0 +1,9 @@
+package pointer_protected_p is
+   type T;
+   
+   type Ptr is access protected procedure (Data : T);
+   
+   type T is record
+      Data : Ptr;
+   end record;
+end pointer_protected_p;

gcc/testsuite/gnat.dg/prot1.adb

@@ -0,0 +1,22 @@
+-- { dg-do compile }
+
+procedure Prot1 is
+   protected type Prot is
+      procedure Change (x : integer);
+   private
+      Flag : Boolean;
+   end Prot;
+   type Handle is access protected procedure (X : Integer);
+   procedure Manage (Ptr : Handle) is
+   begin
+      null;
+   end;
+
+   protected body prot is
+      procedure Change (x : integer) is begin null; end;
+   end;
+
+   Sema : Prot;
+begin
+   Manage (Sema.Change'Unrestricted_Access);
+end;

gcc/testsuite/gnat.dg/self.adb

@@ -0,0 +1,18 @@
+package body Self is 
+   function G (X : Integer) return Lim is
+   begin   
+      return R : Lim := (Comp => X, others => <>); 
+   end G;  
+
+   procedure Change (X : in out Lim; Incr : Integer) is
+   begin   
+      X.Comp := X.Comp + Incr; 
+      X.Self_Default.Comp := X.Comp + Incr; 
+      X.Self_Anon_Default.Comp := X.Comp + Incr; 
+   end Change; 
+
+   function Get (X : Lim) return Integer is
+   begin   
+      return X.Comp; 
+   end;    
+end Self;

gcc/testsuite/gnat.dg/self.ads

@@ -0,0 +1,17 @@
+with System; 
+package Self is 
+  type Lim is limited private;
+  type Lim_Ref is access all Lim;
+  function G (X : Integer) return lim;
+
+  procedure Change (X : in out Lim; Incr : Integer);
+  function Get (X : Lim) return Integer;
+private 
+  type Lim is limited record
+     Comp : Integer;
+     Self_Default : Lim_Ref := Lim'Unchecked_Access;
+     Self_Unrestricted_Default : Lim_Ref := Lim'Unrestricted_Access;
+     Self_Anon_Default : access Lim := Lim'Unchecked_Access;
+     Self_Anon_Unrestricted_Default : access Lim := Lim'Unrestricted_Access;
+  end record; 
+end Self;

gcc/testsuite/gnat.dg/specs/abstract_limited.ads

@@ -0,0 +1,6 @@
+-- { dg-do compile }
+
+package abstract_limited is
+   type I is limited interface;
+   type T is abstract limited new I with null record;
+end;

gcc/testsuite/gnat.dg/specs/controller.ads

@@ -0,0 +1,15 @@
+-- { dg-do compile } 
+
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+package Controller is
+   type Iface is interface;
+   type Thing is tagged record
+      Name : Unbounded_String;
+   end record;
+   type Object is abstract new Thing and Iface with private;
+private
+   type Object is abstract new Thing  and Iface
+   with record
+      Surname : Unbounded_String;
+   end record;
+end Controller;

gcc/testsuite/gnat.dg/specs/double_record_extension1.ads

@@ -1,3 +1,5 @@
+-- { dg-do compile } 
+
 package double_record_extension1 is
 
    type T1(n: natural) is tagged record

gcc/testsuite/gnat.dg/specs/double_record_extension2.ads

@@ -1,3 +1,5 @@
+-- { dg-do compile } 
+
 package double_record_extension2 is
 
   type Base_Message_Type (Num_Bytes : Positive) is tagged record

gcc/testsuite/gnat.dg/specs/formal_type.ads

@@ -0,0 +1,15 @@
+-- { dg-do compile }
+
+with Ada.Strings.Bounded;
+package formal_type is
+   generic 
+      with package BI is
+         new Ada.Strings.Bounded.Generic_Bounded_Length (<>);
+      type NB is new BI.Bounded_String;
+   package G is end; 
+   package BI is new Ada.Strings.Bounded.Generic_Bounded_Length (30);
+   type NB is new BI.Bounded_String;
+    Thing : NB;
+      Size : Integer := THing.Max_Length;
+   package GI is new G (BI, NB);
+end;    

gcc/testsuite/gnat.dg/specs/gen_interface.ads

@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+with gen_interface_p;
+package gen_interface is
+   type T is interface;
+   procedure P (Thing: T) is abstract;
+   package NG is new gen_interface_p (T, P);
+end;    

gcc/testsuite/gnat.dg/specs/gen_interface_p.ads

@@ -0,0 +1,5 @@
+generic 
+   type I is interface;
+   with procedure P (X : I) is abstract;
+package gen_interface_p is
+end;    

gcc/testsuite/gnat.dg/specs/static_initializer.ads

@@ -1,4 +1,5 @@
 -- { dg-do compile }
+-- { dg-options "-cargs -S -margs" }
 
 package static_initializer is
 

gcc/testsuite/gnat.dg/specs/universal_fixed.ads

@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+package Universal_Fixed is
+    Nm2Metres : constant := 1852.0;
+    type Metres is delta 1.0 range 0.0 .. 1_000_000.0;
+    type Nautical_Miles is
+      delta 0.001 range 0.0 .. (Metres'Last + (Nm2Metres / 2)) / Nm2Metres;
+end Universal_Fixed;

gcc/testsuite/gnat.dg/spipaterr.adb

@@ -0,0 +1,14 @@
+-- { dg-do run }
+
+with Text_IO; use Text_IO;
+with GNAT.SPITBOL.Patterns; use GNAT.SPITBOL.Patterns;
+procedure Spipaterr is
+    X : String := "ABCDE";
+    Y : Pattern := Len (1) & X (2 .. 2);
+begin
+    if Match ("XB", Y) then
+       null;
+    else
+       raise Program_Error;
+    end if;
+end;

gcc/testsuite/gnat.dg/task_name.adb

@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+package body task_name is
+   task body Task_Object is
+   begin
+      null;
+   end Task_Object;
+end;

gcc/testsuite/gnat.dg/task_name.ads

@@ -0,0 +1,22 @@
+with Ada.Finalization;
+package task_name is
+   type Base_Controller is
+     abstract new Ada.Finalization.Limited_Controlled with null record;
+
+   type Extended_Controller is
+     abstract new Base_Controller with private;
+
+   type Task_Object (Controller : access Extended_Controller'Class) is
+     limited private;
+private
+   type String_Access is access string;
+
+   type Extended_Controller is
+     abstract new Base_Controller with record
+        Thread : aliased Task_Object (Extended_Controller'Access);
+        Name   : String_Access := new string'("the_name_of_the_task");
+     end record;
+
+   task type Task_Object (Controller : access Extended_Controller'Class) is           pragma Task_Name (Controller.Name.all);
+   end Task_Object;
+end;

gcc/testsuite/gnat.dg/test_bounded.adb

@@ -0,0 +1,13 @@
+-- { dg-do run }
+-- { dg-options "-gnatws" }
+
+procedure Test_Bounded is
+   type Bounded (Length : Natural := 0) is
+      record
+         S : String (1..Length);
+      end record;
+   type Ref is access all Bounded;
+   X : Ref := new Bounded;
+begin
+   null;
+end Test_Bounded;

gcc/testsuite/gnat.dg/test_image.adb

@@ -0,0 +1,8 @@
+-- { dg-do run }
+
+with test_image_p;
+procedure test_image is
+  my_at5c : test_image_p.a_type5_class;
+begin
+  my_at5c := new test_image_p.type5;
+end;

gcc/testsuite/gnat.dg/test_image_p.adb

@@ -0,0 +1,24 @@
+with ada.task_identification;
+with ada.text_io; use ada.text_io;
+package body test_image_p is
+    function to_type1 (arg1 : in Integer) return type1 is
+    begin
+        return  (f2 => (others => Standard.False));
+    end to_type1;
+    task body task_t is
+       Name : String :=
+             ada.task_identification.image (arg.the_task'identity);
+    begin
+        arg.the_array := (others => to_type1 (-1));
+        if Name (1 .. 19) /= "my_at5c.f3.the_task" then
+           Put_Line ("error");
+           raise Program_Error;
+        end if;
+        
+        select
+           accept entry1;
+        or 
+           terminate;
+        end select;
+    end task_t;
+end;

gcc/testsuite/gnat.dg/test_image_p.ads

@@ -0,0 +1,23 @@
+package test_image_p is
+    type type1 is tagged private;
+    type type3 is limited private;
+    type type5 is tagged limited private;
+    type a_type5_class is access all type5'Class;
+    task type task_t (arg : access type3) is
+        entry entry1;
+    end task_t;
+    function to_type1 (arg1 : in Integer) return type1;
+private
+  type array_t is array (Positive range <>) of type1;
+  type array_t2 is array (1 .. 3) of Boolean;
+  type type1 is tagged record
+     f2 : array_t2;
+  end record;
+    type type3 is record
+        the_task : aliased task_t (type3'Access);
+        the_array : array_t (1 .. 10) := (others => to_type1 (-1));
+    end record;
+    type type5 is tagged limited record
+        f3 : type3;
+    end record;
+end;

gcc/testsuite/gnat.dg/test_prio.adb

@@ -0,0 +1,20 @@
+-- { do-do run }
+-- { dg-options "-gnatws" }
+pragma Locking_Policy (Ceiling_Locking);
+with test_prio_p;use test_prio_p;
+with text_io; use text_io;
+procedure Test_Prio is
+   task Tsk is
+      pragma Priority (10);
+   end Tsk;
+   task body Tsk is
+   begin   
+      Sema2.Seize;
+      Sema1.Seize;
+      Put_Line ("error");
+   exception
+      when Program_Error => null;  -- OK
+   end;    
+begin   
+   null;   
+end;    

gcc/testsuite/gnat.dg/test_prio_p.adb

@@ -0,0 +1,5 @@
+package body test_prio_p is
+   protected body Protected_Queue_T is
+      entry Seize when True is begin null; end;
+   end Protected_Queue_T;
+end test_prio_p;

gcc/testsuite/gnat.dg/test_prio_p.ads

@@ -0,0 +1,12 @@
+with System; with Unchecked_Conversion;
+package test_prio_p is
+   type Task_Priority_T is new Natural;
+   function Convert_To_System_Priority is
+   new Unchecked_Conversion (Task_Priority_T, System.Priority);
+   protected type Protected_Queue_T( PO_Priority : Task_Priority_T ) is
+      pragma Priority (Convert_To_System_Priority (PO_Priority ));
+      entry Seize;
+   end Protected_Queue_T;
+   Sema1 : protected_Queue_T (5);
+   Sema2 : protected_Queue_T (10);
+end test_prio_p;

gcc/testsuite/gnat.dg/test_self.adb

@@ -0,0 +1,12 @@
+-- { dg-do run }
+
+with Text_IO; use Text_IO;
+with Self; use Self;
+procedure Test_Self is
+   It : Lim := G (5);
+begin   
+   Change (It, 10);
+   if Get (It) /= 35 then 
+      Put_Line ("self-referential aggregate incorrectly built");
+   end if; 
+end Test_Self;

gcc/testsuite/gnat.dg/test_self_ref.adb

@@ -0,0 +1,36 @@
+-- { dg-do run }
+
+procedure Test_Self_Ref is
+   type T2;
+   type T2_Ref is access all T2; 
+
+   function F (X: T2_Ref) return Integer;
+
+   type T2 is limited record
+      Int1 : Integer := F (T2'Unchecked_Access);
+      Int2 : Integer := F (T2'Unrestricted_Access);
+   end record; 
+
+   Counter : Integer := 2;
+
+   function F (X: T2_Ref) return Integer is
+   begin   
+      Counter := Counter * 5;
+      return Counter;
+   end F;  
+
+   Obj1 : T2_Ref := new T2'(10,20);
+   Obj2 : T2_Ref := new T2; 
+   Obj3 : T2_Ref := new T2'(others => <>); 
+
+begin   
+  if Obj1.Int1 /= 10 or else Obj1.Int2 /= 20 then    
+     raise Program_Error;
+  end if; 
+  if Obj2.Int1 /= 10 or else Obj2.Int2 /= 50 then    
+     raise Program_Error;
+  end if; 
+  if Obj3.Int1 /= 250 or else Obj3.Int2 /= 1250 then    
+     raise Program_Error;
+  end if; 
+end Test_Self_Ref;

gcc/testsuite/gnat.dg/timing_events.adb

@@ -0,0 +1,29 @@
+-- { dg-do run }
+
+procedure Timing_Events is
+   type Timing_Event_Handler is access protected procedure;
+   
+   protected PO is
+      entry     Test;
+      procedure Proc;
+   private
+      Data : Integer := 99;
+   end PO;
+   
+   protected body PO is
+      entry Test when True is
+         Handler : Timing_Event_Handler := Proc'Access;
+      begin
+         Handler.all;
+      end Test;
+      
+      procedure Proc is
+      begin
+         if Data /= 99 then
+            raise Program_Error;
+         end if;
+      end Proc;
+   end PO;
+begin
+   PO.Test;
+end;

gcc/testsuite/gnat.dg/type_conv.adb

@@ -0,0 +1,14 @@
+-- { dg-do compile }
+
+procedure type_conv is
+   type Str is new String;
+   generic
+   package G is private end;
+   package body G is
+      Name : constant String := "it";
+      Full_Name : Str := Str (Name & " works");
+   end G;
+   package Inst is new G;
+begin
+   null;
+end;

gcc/testsuite/gnat.dg/wide_pi.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-gnatW8" }
+
+with Ada.Numerics;
+
+procedure wide_pi is
+begin   
+   null;   
+end;

gcc/testsuite/gnat.dg/wide_test.adb

@@ -0,0 +1,18 @@
+-- { dg-do run }
+-- { dg-options "-gnatW8" }
+
+procedure wide_test is
+   X  : constant Wide_Character := 'Я';
+
+begin
+   declare
+      S3 : constant Wide_String := (''', X, ''');
+      X3 :           Wide_Character;
+   begin
+      X3 := Wide_Character'Wide_Value (S3);
+
+      if X /= X3 then
+         raise Program_Error;
+      end if;
+   end;
+end;