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