| -- 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; |
