URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c3a0014.a] - Rev 294
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log