diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c330002.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c330002.a | 326 |
1 files changed, 0 insertions, 326 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c330002.a b/gcc/testsuite/ada/acats/tests/c3/c330002.a deleted file mode 100644 index 1403d5557b1..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c330002.a +++ /dev/null @@ -1,326 +0,0 @@ --- 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; |