-- C3A0014.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 the view defined by an object declaration is aliased, -- and the type of the object has discriminants, then the object is -- constrained by its initial value even if its nominal subtype is -- unconstrained. -- -- Check that the attribute A'Constrained returns True if A is a formal -- out or in out parameter, or dereference thereof, and A denotes an -- aliased view of an object. -- -- TEST DESCRIPTION: -- These rules apply to objects of a record type with defaulted -- discriminants, which may be unconstrained variables. If such a -- variable is declared to be aliased, then it is constrained by its -- initial value, and the value of the discriminant cannot be changed -- for the life of the variable. -- -- The rules do not apply to aliased component types because if such -- types are discriminated they must be constrained. -- -- A'Constrained returns True if A denotes a constant, value, or -- constrained variable. Since aliased objects are constrained, it must -- return True if the actual parameter corresponding to a formal -- parameter A is an aliased object. The objective only mentions formal -- parameters of mode out and in out, since parameters of mode in are -- by definition constant, and would result in True anyway. -- -- This test declares aliased objects of a nominally unconstrained -- record subtype, both with and without initialization expressions. -- It also declares access values which point to such objects. It then -- checks that Constraint_Error is raised if an attempt is made to -- change the discriminant value of an aliased object, either directly -- or via a dereference of an access value. For aliased objects, this -- check is also performed for subprogram parameters of mode out. -- -- The test also passes aliased objects and access values which point -- to such objects as actuals to subprograms and verifies, for parameter -- modes out and in out, that P'Constrained returns true if P is the -- corresponding formal parameter or a dereference thereof. -- -- Additionally, the test declares a generic package which declares a -- an aliased object of a formal derived unconstrained type, which is -- is initialized with the value of a formal object of that type. -- procedure declared within the generic assigns a value to the object -- which has the same discriminant value as the formal derived type's -- ancestor type. The generic is instantiated with various actuals -- for the formal object, and the procedure is called. The test verifies -- that Constraint_Error is raised if the discriminant values of the -- actual corresponding to the formal object and the value assigned -- by the procedure are not equal. -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors. -- --! package C3A0014_0 is subtype Reasonable is Integer range 1..10; -- Unconstrained (sub)type. type UC (D: Reasonable := 2) is record -- Discriminant default. S: String (1 .. D) := "Hi"; -- Default value. end record; type AUC is access all UC; -- Nominal subtype is unconstrained for the following: Obj0 : UC; -- An unconstrained object. Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization, -- an unconstrained object. Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization, -- a constrained object. Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view), -- a constrained object. Obj4 : aliased UC; -- Aliased without initialization, Obj4 -- constrained here to initial value -- taken from default for type. Ptr1 : AUC := new UC'(Obj1); Ptr2 : AUC := new UC; Ptr3 : AUC := Obj3'Access; Ptr4 : AUC := Obj4'Access; procedure NP_Proc (A: out UC); procedure NP_Cons (A: in out UC; B: out Boolean); procedure P_Cons (A: out AUC; B: out Boolean); generic type FT is new UC; FObj : in out FT; package Gen is F : aliased FT := FObj; -- Constrained if FT has discriminants. procedure Proc; end Gen; procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ); end C3A0014_0; --=======================================================================-- with Report; package body C3A0014_0 is procedure NP_Proc (A: out UC) is begin A := (3, "Bye"); end NP_Proc; procedure NP_Cons (A: in out UC; B: out Boolean) is begin B := A'Constrained; end NP_Cons; procedure P_Cons (A: out AUC; B: out Boolean) is begin B := A.all'Constrained; end P_Cons; package body Gen is procedure Proc is begin F := (2, "Fi"); end Proc; end Gen; procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is Default : UC := (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; end C3A0014_0; --=======================================================================-- with C3A0014_0; use C3A0014_0; with Report; procedure C3A0014 is begin Report.Test("C3A0014", "Check that if the view defined by an object " & "declaration is aliased, and the type of the " & "object has discriminants, then the object is " & "constrained by its initial value even if its " & "nominal subtype is unconstrained. Check that " & "the attribute A'Constrained returns True if A " & "is a formal out or in out parameter, or " & "dereference thereof, and A denotes an aliased " & "view of an object"); Non_Pointer_Block: begin begin Obj0 := (3, "Bye"); -- OK: Obj0 not constrained. if Obj0 /= (3, "Bye") then Report.Failed ("Wrong value after aggregate assignment - Subtest 1"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 1"); end; begin Obj1 := (3, "Bye"); -- OK: Obj1 not constrained. if Obj1 /= (3, "Bye") then Report.Failed ("Wrong value after aggregate assignment - Subtest 2"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 2"); end; begin Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5). Avoid_Optimization_and_Fail (Obj2, "Subtest 3"); exception when Constraint_Error => null; -- Exception is expected. end; begin Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5). Avoid_Optimization_and_Fail (Obj3, "Subtest 4"); exception when Constraint_Error => null; -- Exception is expected. end; begin Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2). Avoid_Optimization_and_Fail (Obj4, "Subtest 5"); exception when Constraint_Error => null; -- Exception is expected. end; exception when others => Report.Failed("Unexpected exception: Non_Pointer_Block"); end Non_Pointer_Block; Pointer_Block: begin begin Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5). Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6"); exception when Constraint_Error => null; -- Exception is expected. end; begin Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2). Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7"); exception when Constraint_Error => null; -- Exception is expected. end; begin Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5). Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8"); exception when Constraint_Error => null; -- Exception is expected. end; begin Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2). Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9"); exception when Constraint_Error => null; -- Exception is expected. end; exception when others => Report.Failed("Unexpected exception: Pointer_Block"); end Pointer_Block; Subprogram_Block: declare Is_Constrained : Boolean; begin begin NP_Proc (Obj0); -- OK: Obj0 not constrained, can if Obj0 /= (3, "Bye") then -- change discriminant value. Report.Failed ("Wrong value after aggregate assignment - Subtest 10"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 10"); end; begin NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5). Avoid_Optimization_and_Fail (Obj2, "Subtest 11"); exception when Constraint_Error => null; -- Exception is expected. end; begin NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5). Avoid_Optimization_and_Fail (Obj3, "Subtest 12"); exception when Constraint_Error => null; -- Exception is expected. end; begin NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2). Avoid_Optimization_and_Fail (Obj4, "Subtest 13"); exception when Constraint_Error => null; -- Exception is expected. end; begin Is_Constrained := True; NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1 if Is_Constrained then -- is not constrained. Report.Failed ("Wrong result from 'Constrained - Subtest 14"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 14"); end; begin Is_Constrained := False; NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is if not Is_Constrained then -- constrained. Report.Failed ("Wrong result from 'Constrained - Subtest 15"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 15"); end; begin Is_Constrained := False; P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all if not Is_Constrained then -- is constrained. Report.Failed ("Wrong result from 'Constrained - Subtest 16"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 16"); end; begin Is_Constrained := False; P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all if not Is_Constrained then -- is constrained. Report.Failed ("Wrong result from 'Constrained - Subtest 17"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 17"); end; exception when others => Report.Failed("Exception raised in Subprogram_Block"); end Subprogram_Block; Generic_Block: declare type NUC is new UC; Obj : NUC; package Instance_A is new Gen (NUC, Obj); package Instance_B is new Gen (UC, Obj2); package Instance_C is new Gen (UC, Obj3); package Instance_D is new Gen (UC, Obj4); begin begin Instance_A.Proc; -- OK: Obj.D = 2. if Instance_A.F /= (2, "Fi") then Report.Failed ("Wrong value after aggregate assignment - Subtest 18"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 18"); end; begin Instance_B.Proc; -- C_E: Obj2.D = 5. Avoid_Optimization_and_Fail (Obj2, "Subtest 19"); exception when Constraint_Error => null; -- Exception is expected. end; begin Instance_C.Proc; -- C_E: Obj3.D = 5. Avoid_Optimization_and_Fail (Obj3, "Subtest 20"); exception when Constraint_Error => null; -- Exception is expected. end; begin Instance_D.Proc; -- OK: Obj4.D = 2. if Instance_D.F /= (2, "Fi") then Report.Failed ("Wrong value after aggregate assignment - Subtest 21"); end if; exception when others => Report.Failed ("Unexpected exception raised - Subtest 21"); end; exception when others => Report.Failed("Exception raised in Generic_Block"); end Generic_Block; Report.Result; end C3A0014;