--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/c3/c330002.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,326 @@
+-- C330002.A 
+-- 
+--                             Grant of Unlimited Rights
+--
+--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
+--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
+--     unlimited rights in the software and documentation contained herein.
+--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
+--     this public release, the Government intends to confer upon all 
+--     recipients unlimited rights  equal to those held by the Government.  
+--     These rights include rights to use, duplicate, release or disclose the 
+--     released technical data and computer software in whole or in part, in 
+--     any manner and for any purpose whatsoever, and to have or permit others 
+--     to do so.
+--
+--                                    DISCLAIMER
+--
+--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
+--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
+--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
+--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
+--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
+--     PARTICULAR PURPOSE OF SAID MATERIAL.
+--*
+-- 
+-- OBJECTIVE: 
+--      Check that if a subtype indication of a variable object defines an  
+--      indefinite subtype, then there is an initialization expression. 
+--      Check that the object remains so constrained throughout its lifetime. 
+--      Check for cases of tagged record, arrays and generic formal type. 
+--                    
+-- TEST DESCRIPTION: 
+--      An indefinite subtype is either: 
+--         a) An unconstrained array subtype. 
+--         b) A subtype with unknown discriminants (this includes class-wide 
+--            types). 
+--         c) A subtype with unconstrained discriminants without defaults. 
+-- 
+--      Declare tagged types with unconstrained discriminants without 
+--      defaults.  Declare an unconstrained array.  Declare a generic formal
+--      type with an unknown discriminant and a formal object of this type.  
+--      In the generic package, declare an object of the formal type using 
+--      the formal object as its initial value.  In the main program, 
+--      declare objects of tagged types.  Instantiate the generic package.  
+--      The test checks that Constraint_Error is raised if an attempt is 
+--      made to change bounds as well as discriminants of the objects of the 
+--      indefinite subtypes.  
+-- 
+-- 
+-- CHANGE HISTORY: 
+--      01 Nov 95   SAIC    Initial prerelease version. 
+--      27 Jul 96   SAIC    Modified test description & Report.Test.  Added
+--                          code to prevent dead variable optimization.
+-- 
+--!
+
+package C330002_0 is  
+
+   subtype Small_Num is Integer range 1 .. 20;
+
+   -- Types with unconstrained discriminants without defaults.      
+
+   type Tag_Type (Disc : Small_Num) is tagged         
+     record                                          
+       S : String (1 .. Disc);                       
+     end record;
+
+   function  Tag_Value return Tag_Type;
+
+   procedure Assign_Tag (A : out Tag_Type);
+
+   procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String);
+
+   ---------------------------------------------------------------------
+   -- An unconstrained array type.
+
+   type Array_Type is array (Positive range <>) of Integer;
+
+   function  Array_Value return Array_Type;
+
+   procedure Assign_Array (A : out Array_Type);
+
+   ---------------------------------------------------------------------
+   generic
+      -- Type with an unknown discriminant.
+      type Formal_Type (<>) is private;
+      FT_Obj  : Formal_Type;
+   package Gen is
+      Gen_Obj : Formal_Type := FT_Obj;
+   end Gen;
+
+end C330002_0;
+
+     --==================================================================--
+
+with Report;
+package body C330002_0 is  
+
+   procedure Assign_Tag (A : out Tag_Type) is
+   begin
+      A := (3, "Bye");
+   end Assign_Tag;
+
+   ----------------------------------------------------------------------
+   procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is
+      Default : Tag_Type := (1, "!"); -- Unique value.
+   begin                       
+      if P = Default then       -- Both If branches can't do the same thing.
+         Report.Failed  (Msg & ": Constraint_Error not raised");
+      else                      -- Subtests should always select this path.
+         Report.Failed ("Constraint_Error not raised " & Msg);
+      end if;
+   end Avoid_Optimization_and_Fail;
+
+   ----------------------------------------------------------------------
+   function  Tag_Value return Tag_Type is
+      TO : Tag_Type := (4 , "ACVC");
+   begin
+      return TO;
+   end Tag_Value;
+
+   ----------------------------------------------------------------------
+   function  Array_Value return Array_Type is
+      IA : Array_Type := (20, 31);
+   begin
+      return IA;
+   end Array_Value;
+
+   ----------------------------------------------------------------------
+   procedure Assign_Array (A : out Array_Type) is
+   begin
+      A := (84, 36);
+   end Assign_Array;
+
+end C330002_0;
+
+     --==================================================================--
+
+with Report;
+with C330002_0;
+use  C330002_0;
+
+procedure C330002 is  
+
+begin
+   Report.Test ("C330002", "Check that if a subtype indication of a "      &
+                "variable object defines an indefinite subtype, then "     & 
+                "there is an initialization expression.  Check that "      &
+                "the object remains so constrained throughout its "        &
+                "lifetime.  Check that Constraint_Error is raised "        &
+                "if an attempt is made to change bounds as well as "       &
+                "discriminants of the objects of the indefinite "          &
+                "subtypes.  Check for cases of tagged record and generic " &
+                "formal types");
+
+   TagObj_Block:
+   declare
+      TObj_ByAgg  : Tag_Type := (5, "Hello");    -- Initial assignment is
+                                                 -- aggregate.   
+      TObj_ByObj  : Tag_Type := TObj_ByAgg;      -- Initial assignment is
+                                                 -- an object.   
+      TObj_ByFunc : Tag_Type := Tag_Value;       -- Initial assignment is
+                                                 -- function return value.
+      Ren_Obj     : Tag_Type renames TObj_ByAgg;        
+
+   begin
+
+      begin
+         if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then
+            Report.Failed ("Wrong initial values for TObj_ByAgg");
+         end if;
+           
+         TObj_ByAgg := (2, "Hi");                -- C_E, can't change the 
+                                                 -- value of the discriminant.
+
+         Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1");
+
+      exception
+         when Constraint_Error => null;          -- Exception is expected.
+         when others           => 
+            Report.Failed ("Unexpected exception - Subtest 1");
+      end;
+
+
+      begin
+         Assign_Tag (Ren_Obj);                   -- C_E, can't change the 
+                                                 -- value of the discriminant.
+
+         Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2");
+
+      exception
+         when Constraint_Error => null;          -- Exception is expected.
+         when others           => 
+            Report.Failed ("Unexpected exception - Subtest 2");
+      end;
+
+
+      begin
+         if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then
+            Report.Failed ("Wrong initial values for TObj_ByObj");
+         end if;
+
+         TObj_ByObj := (3, "Bye");               -- C_E, can't change the 
+                                                 -- value of the discriminant.
+
+         Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3");
+
+      exception
+         when Constraint_Error => null;          -- Exception is expected.
+         when others           => 
+            Report.Failed ("Unexpected exception - Subtest 3");
+      end;
+
+
+      begin
+         if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then
+            Report.Failed ("Wrong initial values for TObj_ByFunc");
+         end if;
+
+         TObj_ByFunc := (5, "Aloha");            -- C_E, can't change the 
+                                                 -- value of the discriminant.
+
+         Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4");
+
+      exception
+         when Constraint_Error => null;          -- Exception is expected.
+         when others           => 
+            Report.Failed ("Unexpected exception - Subtest 4");
+      end;
+
+   end TagObj_Block;
+
+
+   ArrObj_Block:
+   declare
+      Arr_Const   :  constant Array_Type               
+                  := (9, 7, 6, 8); 
+      Arr_ByAgg   :  Array_Type                  -- Initial assignment is
+                  := (10, 11, 12);               -- aggregate.            
+      Arr_ByFunc  :  Array_Type                  -- Initial assignment is
+                  := Array_Value;                -- function return value.
+      Arr_ByObj   :  Array_Type                  -- Initial assignment is
+                  := Arr_ByAgg;                  -- object.
+
+      Arr_Obj     :  array (Positive range <>) of Integer 
+                  := (1, 2, 3, 4, 5);
+    begin
+
+      begin
+         if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then
+            Report.Failed ("Wrong bounds for Arr_Const");
+         end if;
+
+         if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then
+            Report.Failed ("Wrong bounds for Arr_ByAgg");
+         end if;
+
+         if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then
+            Report.Failed ("Wrong bounds for Arr_ByFunc");
+         end if;
+
+         if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then
+            Report.Failed ("Wrong bounds for Arr_ByObj");
+         end if;
+
+         Assign_Array (Arr_ByObj);               -- C_E, Arr_ByObj bounds are
+                                                 -- 1..3.
+
+         Report.Failed ("Constraint_Error not raised - Subtest 5");
+
+      exception
+            when Constraint_Error => null;        -- Exception is expected.
+            when others           => 
+               Report.Failed ("Unexpected exception - Subtest 5");
+      end;
+
+
+      begin
+         if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then
+            Report.Failed ("Wrong bounds for Arr_Obj");
+         end if;
+
+         for I in 0 .. 5 loop
+            Arr_Obj (I + 1) := I + 5;             -- C_E, Arr_Obj bounds are
+         end loop;                                -- 1..5.
+
+         Report.Failed ("Constraint_Error not raised - Subtest 6");
+
+      exception
+            when Constraint_Error => null;        -- Exception is expected.
+            when others           => 
+               Report.Failed ("Unexpected exception - Subtest 6");
+      end;
+
+   end ArrObj_Block;
+
+
+   GenericObj_Block:
+   declare
+      type Rec (Disc : Small_Num) is 
+        record     
+           S : Small_Num := Disc;
+        end record;
+
+      Rec_Obj : Rec := (2, 2);
+      package IGen is new Gen (Rec, Rec_Obj);
+
+   begin
+      IGen.Gen_Obj := (3, 3);                    -- C_E, can't change the 
+                                                 -- value of the discriminant.
+
+      Report.Failed ("Constraint_Error not raised - Subtest 7");
+
+      -- Next line prevents dead assignment.
+      Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc));
+
+   exception
+      when Constraint_Error => null;             -- Exception is expected.
+      when others           => 
+         Report.Failed ("Unexpected exception - Subtest 7");
+
+   end GenericObj_Block;
+
+   Report.Result;
+
+end C330002;