From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/c3/c3a0014.a | 453 +++++++++++++++++++++++++++++ 1 file changed, 453 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0014.a (limited to 'gcc/testsuite/ada/acats/tests/c3/c3a0014.a') diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0014.a b/gcc/testsuite/ada/acats/tests/c3/c3a0014.a new file mode 100644 index 000000000..c83ab4f5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0014.a @@ -0,0 +1,453 @@ +-- 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; -- cgit v1.2.3