aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a453
1 files changed, 453 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0014.a
new file mode 100644
index 000000000..c83ab4f5e
--- /dev/null
+++ b/gcc-4.9/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;