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