-- C3A0014.A
|
-- C3A0014.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that if the view defined by an object declaration is aliased,
|
-- Check that if the view defined by an object declaration is aliased,
|
-- and the type of the object has discriminants, then the object is
|
-- and the type of the object has discriminants, then the object is
|
-- constrained by its initial value even if its nominal subtype is
|
-- constrained by its initial value even if its nominal subtype is
|
-- unconstrained.
|
-- unconstrained.
|
--
|
--
|
-- Check that the attribute A'Constrained returns True if A is a formal
|
-- 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
|
-- out or in out parameter, or dereference thereof, and A denotes an
|
-- aliased view of an object.
|
-- aliased view of an object.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- These rules apply to objects of a record type with defaulted
|
-- These rules apply to objects of a record type with defaulted
|
-- discriminants, which may be unconstrained variables. If such a
|
-- discriminants, which may be unconstrained variables. If such a
|
-- variable is declared to be aliased, then it is constrained by its
|
-- variable is declared to be aliased, then it is constrained by its
|
-- initial value, and the value of the discriminant cannot be changed
|
-- initial value, and the value of the discriminant cannot be changed
|
-- for the life of the variable.
|
-- for the life of the variable.
|
--
|
--
|
-- The rules do not apply to aliased component types because if such
|
-- The rules do not apply to aliased component types because if such
|
-- types are discriminated they must be constrained.
|
-- types are discriminated they must be constrained.
|
--
|
--
|
-- A'Constrained returns True if A denotes a constant, value, or
|
-- A'Constrained returns True if A denotes a constant, value, or
|
-- constrained variable. Since aliased objects are constrained, it must
|
-- constrained variable. Since aliased objects are constrained, it must
|
-- return True if the actual parameter corresponding to a formal
|
-- return True if the actual parameter corresponding to a formal
|
-- parameter A is an aliased object. The objective only mentions 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
|
-- parameters of mode out and in out, since parameters of mode in are
|
-- by definition constant, and would result in True anyway.
|
-- by definition constant, and would result in True anyway.
|
--
|
--
|
-- This test declares aliased objects of a nominally unconstrained
|
-- This test declares aliased objects of a nominally unconstrained
|
-- record subtype, both with and without initialization expressions.
|
-- record subtype, both with and without initialization expressions.
|
-- It also declares access values which point to such objects. It then
|
-- It also declares access values which point to such objects. It then
|
-- checks that Constraint_Error is raised if an attempt is made to
|
-- checks that Constraint_Error is raised if an attempt is made to
|
-- change the discriminant value of an aliased object, either directly
|
-- change the discriminant value of an aliased object, either directly
|
-- or via a dereference of an access value. For aliased objects, this
|
-- or via a dereference of an access value. For aliased objects, this
|
-- check is also performed for subprogram parameters of mode out.
|
-- check is also performed for subprogram parameters of mode out.
|
--
|
--
|
-- The test also passes aliased objects and access values which point
|
-- The test also passes aliased objects and access values which point
|
-- to such objects as actuals to subprograms and verifies, for parameter
|
-- 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
|
-- modes out and in out, that P'Constrained returns true if P is the
|
-- corresponding formal parameter or a dereference thereof.
|
-- corresponding formal parameter or a dereference thereof.
|
--
|
--
|
-- Additionally, the test declares a generic package which declares a
|
-- Additionally, the test declares a generic package which declares a
|
-- an aliased object of a formal derived unconstrained type, which is
|
-- an aliased object of a formal derived unconstrained type, which is
|
-- is initialized with the value of a formal object of that type.
|
-- is initialized with the value of a formal object of that type.
|
-- procedure declared within the generic assigns a value to the object
|
-- procedure declared within the generic assigns a value to the object
|
-- which has the same discriminant value as the formal derived type's
|
-- which has the same discriminant value as the formal derived type's
|
-- ancestor type. The generic is instantiated with various actuals
|
-- ancestor type. The generic is instantiated with various actuals
|
-- for the formal object, and the procedure is called. The test verifies
|
-- for the formal object, and the procedure is called. The test verifies
|
-- that Constraint_Error is raised if the discriminant values of the
|
-- that Constraint_Error is raised if the discriminant values of the
|
-- actual corresponding to the formal object and the value assigned
|
-- actual corresponding to the formal object and the value assigned
|
-- by the procedure are not equal.
|
-- by the procedure are not equal.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors.
|
-- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors.
|
--
|
--
|
--!
|
--!
|
|
|
package C3A0014_0 is
|
package C3A0014_0 is
|
|
|
subtype Reasonable is Integer range 1..10;
|
subtype Reasonable is Integer range 1..10;
|
-- Unconstrained (sub)type.
|
-- Unconstrained (sub)type.
|
type UC (D: Reasonable := 2) is record -- Discriminant default.
|
type UC (D: Reasonable := 2) is record -- Discriminant default.
|
S: String (1 .. D) := "Hi"; -- Default value.
|
S: String (1 .. D) := "Hi"; -- Default value.
|
end record;
|
end record;
|
|
|
type AUC is access all UC;
|
type AUC is access all UC;
|
|
|
-- Nominal subtype is unconstrained for the following:
|
-- Nominal subtype is unconstrained for the following:
|
|
|
Obj0 : UC; -- An unconstrained object.
|
Obj0 : UC; -- An unconstrained object.
|
|
|
Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization,
|
Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization,
|
-- an unconstrained object.
|
-- an unconstrained object.
|
|
|
Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization,
|
Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization,
|
-- a constrained object.
|
-- a constrained object.
|
|
|
Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view),
|
Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view),
|
-- a constrained object.
|
-- a constrained object.
|
Obj4 : aliased UC; -- Aliased without initialization, Obj4
|
Obj4 : aliased UC; -- Aliased without initialization, Obj4
|
-- constrained here to initial value
|
-- constrained here to initial value
|
-- taken from default for type.
|
-- taken from default for type.
|
|
|
Ptr1 : AUC := new UC'(Obj1);
|
Ptr1 : AUC := new UC'(Obj1);
|
Ptr2 : AUC := new UC;
|
Ptr2 : AUC := new UC;
|
Ptr3 : AUC := Obj3'Access;
|
Ptr3 : AUC := Obj3'Access;
|
Ptr4 : AUC := Obj4'Access;
|
Ptr4 : AUC := Obj4'Access;
|
|
|
|
|
procedure NP_Proc (A: out UC);
|
procedure NP_Proc (A: out UC);
|
procedure NP_Cons (A: in out UC; B: out Boolean);
|
procedure NP_Cons (A: in out UC; B: out Boolean);
|
procedure P_Cons (A: out AUC; B: out Boolean);
|
procedure P_Cons (A: out AUC; B: out Boolean);
|
|
|
|
|
generic
|
generic
|
type FT is new UC;
|
type FT is new UC;
|
FObj : in out FT;
|
FObj : in out FT;
|
package Gen is
|
package Gen is
|
F : aliased FT := FObj; -- Constrained if FT has discriminants.
|
F : aliased FT := FObj; -- Constrained if FT has discriminants.
|
procedure Proc;
|
procedure Proc;
|
end Gen;
|
end Gen;
|
|
|
|
|
procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );
|
procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String );
|
|
|
|
|
end C3A0014_0;
|
end C3A0014_0;
|
|
|
|
|
--=======================================================================--
|
--=======================================================================--
|
|
|
with Report;
|
with Report;
|
|
|
package body C3A0014_0 is
|
package body C3A0014_0 is
|
|
|
procedure NP_Proc (A: out UC) is
|
procedure NP_Proc (A: out UC) is
|
begin
|
begin
|
A := (3, "Bye");
|
A := (3, "Bye");
|
end NP_Proc;
|
end NP_Proc;
|
|
|
procedure NP_Cons (A: in out UC; B: out Boolean) is
|
procedure NP_Cons (A: in out UC; B: out Boolean) is
|
begin
|
begin
|
B := A'Constrained;
|
B := A'Constrained;
|
end NP_Cons;
|
end NP_Cons;
|
|
|
procedure P_Cons (A: out AUC; B: out Boolean) is
|
procedure P_Cons (A: out AUC; B: out Boolean) is
|
begin
|
begin
|
B := A.all'Constrained;
|
B := A.all'Constrained;
|
end P_Cons;
|
end P_Cons;
|
|
|
|
|
package body Gen is
|
package body Gen is
|
|
|
procedure Proc is
|
procedure Proc is
|
begin
|
begin
|
F := (2, "Fi");
|
F := (2, "Fi");
|
end Proc;
|
end Proc;
|
|
|
end Gen;
|
end Gen;
|
|
|
|
|
procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
|
procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is
|
Default : UC := (1, "!"); -- Unique value.
|
Default : UC := (1, "!"); -- Unique value.
|
begin
|
begin
|
if P = Default then -- Both If branches can't do the same thing.
|
if P = Default then -- Both If branches can't do the same thing.
|
Report.Failed (Msg & ": Constraint_Error not raised");
|
Report.Failed (Msg & ": Constraint_Error not raised");
|
else -- Subtests should always select this path.
|
else -- Subtests should always select this path.
|
Report.Failed ("Constraint_Error not raised " & Msg);
|
Report.Failed ("Constraint_Error not raised " & Msg);
|
end if;
|
end if;
|
end Avoid_Optimization_and_Fail;
|
end Avoid_Optimization_and_Fail;
|
|
|
|
|
end C3A0014_0;
|
end C3A0014_0;
|
|
|
|
|
--=======================================================================--
|
--=======================================================================--
|
|
|
|
|
with C3A0014_0; use C3A0014_0;
|
with C3A0014_0; use C3A0014_0;
|
with Report;
|
with Report;
|
|
|
procedure C3A0014 is
|
procedure C3A0014 is
|
begin
|
begin
|
|
|
Report.Test("C3A0014", "Check that if the view defined by an object " &
|
Report.Test("C3A0014", "Check that if the view defined by an object " &
|
"declaration is aliased, and the type of the " &
|
"declaration is aliased, and the type of the " &
|
"object has discriminants, then the object is " &
|
"object has discriminants, then the object is " &
|
"constrained by its initial value even if its " &
|
"constrained by its initial value even if its " &
|
"nominal subtype is unconstrained. Check that " &
|
"nominal subtype is unconstrained. Check that " &
|
"the attribute A'Constrained returns True if A " &
|
"the attribute A'Constrained returns True if A " &
|
"is a formal out or in out parameter, or " &
|
"is a formal out or in out parameter, or " &
|
"dereference thereof, and A denotes an aliased " &
|
"dereference thereof, and A denotes an aliased " &
|
"view of an object");
|
"view of an object");
|
|
|
Non_Pointer_Block:
|
Non_Pointer_Block:
|
begin
|
begin
|
|
|
begin
|
begin
|
Obj0 := (3, "Bye"); -- OK: Obj0 not constrained.
|
Obj0 := (3, "Bye"); -- OK: Obj0 not constrained.
|
if Obj0 /= (3, "Bye") then
|
if Obj0 /= (3, "Bye") then
|
Report.Failed
|
Report.Failed
|
("Wrong value after aggregate assignment - Subtest 1");
|
("Wrong value after aggregate assignment - Subtest 1");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 1");
|
Report.Failed ("Unexpected exception raised - Subtest 1");
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Obj1 := (3, "Bye"); -- OK: Obj1 not constrained.
|
Obj1 := (3, "Bye"); -- OK: Obj1 not constrained.
|
if Obj1 /= (3, "Bye") then
|
if Obj1 /= (3, "Bye") then
|
Report.Failed
|
Report.Failed
|
("Wrong value after aggregate assignment - Subtest 2");
|
("Wrong value after aggregate assignment - Subtest 2");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 2");
|
Report.Failed ("Unexpected exception raised - Subtest 2");
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5).
|
Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5).
|
Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
|
Avoid_Optimization_and_Fail (Obj2, "Subtest 3");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5).
|
Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5).
|
Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
|
Avoid_Optimization_and_Fail (Obj3, "Subtest 4");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2).
|
Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2).
|
Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
|
Avoid_Optimization_and_Fail (Obj4, "Subtest 5");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
exception
|
exception
|
when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
|
when others => Report.Failed("Unexpected exception: Non_Pointer_Block");
|
end Non_Pointer_Block;
|
end Non_Pointer_Block;
|
|
|
|
|
Pointer_Block:
|
Pointer_Block:
|
begin
|
begin
|
|
|
begin
|
begin
|
Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5).
|
Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5).
|
Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
|
Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2).
|
Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2).
|
Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
|
Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5).
|
Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5).
|
Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
|
Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2).
|
Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2).
|
Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
|
Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
exception
|
exception
|
when others => Report.Failed("Unexpected exception: Pointer_Block");
|
when others => Report.Failed("Unexpected exception: Pointer_Block");
|
end Pointer_Block;
|
end Pointer_Block;
|
|
|
|
|
Subprogram_Block:
|
Subprogram_Block:
|
declare
|
declare
|
Is_Constrained : Boolean;
|
Is_Constrained : Boolean;
|
begin
|
begin
|
|
|
begin
|
begin
|
NP_Proc (Obj0); -- OK: Obj0 not constrained, can
|
NP_Proc (Obj0); -- OK: Obj0 not constrained, can
|
if Obj0 /= (3, "Bye") then -- change discriminant value.
|
if Obj0 /= (3, "Bye") then -- change discriminant value.
|
Report.Failed
|
Report.Failed
|
("Wrong value after aggregate assignment - Subtest 10");
|
("Wrong value after aggregate assignment - Subtest 10");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 10");
|
Report.Failed ("Unexpected exception raised - Subtest 10");
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5).
|
NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5).
|
Avoid_Optimization_and_Fail (Obj2, "Subtest 11");
|
Avoid_Optimization_and_Fail (Obj2, "Subtest 11");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5).
|
NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5).
|
Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
|
Avoid_Optimization_and_Fail (Obj3, "Subtest 12");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2).
|
NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2).
|
Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
|
Avoid_Optimization_and_Fail (Obj4, "Subtest 13");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
|
|
begin
|
begin
|
Is_Constrained := True;
|
Is_Constrained := True;
|
NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1
|
NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1
|
if Is_Constrained then -- is not constrained.
|
if Is_Constrained then -- is not constrained.
|
Report.Failed ("Wrong result from 'Constrained - Subtest 14");
|
Report.Failed ("Wrong result from 'Constrained - Subtest 14");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 14");
|
Report.Failed ("Unexpected exception raised - Subtest 14");
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Is_Constrained := False;
|
Is_Constrained := False;
|
NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is
|
NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is
|
if not Is_Constrained then -- constrained.
|
if not Is_Constrained then -- constrained.
|
Report.Failed ("Wrong result from 'Constrained - Subtest 15");
|
Report.Failed ("Wrong result from 'Constrained - Subtest 15");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 15");
|
Report.Failed ("Unexpected exception raised - Subtest 15");
|
end;
|
end;
|
|
|
|
|
|
|
|
|
begin
|
begin
|
Is_Constrained := False;
|
Is_Constrained := False;
|
P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all
|
P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all
|
if not Is_Constrained then -- is constrained.
|
if not Is_Constrained then -- is constrained.
|
Report.Failed ("Wrong result from 'Constrained - Subtest 16");
|
Report.Failed ("Wrong result from 'Constrained - Subtest 16");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 16");
|
Report.Failed ("Unexpected exception raised - Subtest 16");
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Is_Constrained := False;
|
Is_Constrained := False;
|
P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all
|
P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all
|
if not Is_Constrained then -- is constrained.
|
if not Is_Constrained then -- is constrained.
|
Report.Failed ("Wrong result from 'Constrained - Subtest 17");
|
Report.Failed ("Wrong result from 'Constrained - Subtest 17");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 17");
|
Report.Failed ("Unexpected exception raised - Subtest 17");
|
end;
|
end;
|
|
|
|
|
exception
|
exception
|
when others => Report.Failed("Exception raised in Subprogram_Block");
|
when others => Report.Failed("Exception raised in Subprogram_Block");
|
end Subprogram_Block;
|
end Subprogram_Block;
|
|
|
|
|
Generic_Block:
|
Generic_Block:
|
declare
|
declare
|
|
|
type NUC is new UC;
|
type NUC is new UC;
|
|
|
Obj : NUC;
|
Obj : NUC;
|
|
|
|
|
package Instance_A is new Gen (NUC, Obj);
|
package Instance_A is new Gen (NUC, Obj);
|
package Instance_B is new Gen (UC, Obj2);
|
package Instance_B is new Gen (UC, Obj2);
|
package Instance_C is new Gen (UC, Obj3);
|
package Instance_C is new Gen (UC, Obj3);
|
package Instance_D is new Gen (UC, Obj4);
|
package Instance_D is new Gen (UC, Obj4);
|
|
|
begin
|
begin
|
|
|
begin
|
begin
|
Instance_A.Proc; -- OK: Obj.D = 2.
|
Instance_A.Proc; -- OK: Obj.D = 2.
|
if Instance_A.F /= (2, "Fi") then
|
if Instance_A.F /= (2, "Fi") then
|
Report.Failed
|
Report.Failed
|
("Wrong value after aggregate assignment - Subtest 18");
|
("Wrong value after aggregate assignment - Subtest 18");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 18");
|
Report.Failed ("Unexpected exception raised - Subtest 18");
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Instance_B.Proc; -- C_E: Obj2.D = 5.
|
Instance_B.Proc; -- C_E: Obj2.D = 5.
|
Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
|
Avoid_Optimization_and_Fail (Obj2, "Subtest 19");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Instance_C.Proc; -- C_E: Obj3.D = 5.
|
Instance_C.Proc; -- C_E: Obj3.D = 5.
|
Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
|
Avoid_Optimization_and_Fail (Obj3, "Subtest 20");
|
exception
|
exception
|
when Constraint_Error => null; -- Exception is expected.
|
when Constraint_Error => null; -- Exception is expected.
|
end;
|
end;
|
|
|
|
|
begin
|
begin
|
Instance_D.Proc; -- OK: Obj4.D = 2.
|
Instance_D.Proc; -- OK: Obj4.D = 2.
|
if Instance_D.F /= (2, "Fi") then
|
if Instance_D.F /= (2, "Fi") then
|
Report.Failed
|
Report.Failed
|
("Wrong value after aggregate assignment - Subtest 21");
|
("Wrong value after aggregate assignment - Subtest 21");
|
end if;
|
end if;
|
exception
|
exception
|
when others =>
|
when others =>
|
Report.Failed ("Unexpected exception raised - Subtest 21");
|
Report.Failed ("Unexpected exception raised - Subtest 21");
|
end;
|
end;
|
|
|
exception
|
exception
|
when others => Report.Failed("Exception raised in Generic_Block");
|
when others => Report.Failed("Exception raised in Generic_Block");
|
end Generic_Block;
|
end Generic_Block;
|
|
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C3A0014;
|
end C3A0014;
|
|
|