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