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/] [c330002.a] - Rev 384
Compare with Previous | Blame | View Log
-- C330002.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 a subtype indication of a variable object defines an
-- indefinite subtype, then there is an initialization expression.
-- Check that the object remains so constrained throughout its lifetime.
-- Check for cases of tagged record, arrays and generic formal type.
--
-- TEST DESCRIPTION:
-- An indefinite subtype is either:
-- a) An unconstrained array subtype.
-- b) A subtype with unknown discriminants (this includes class-wide
-- types).
-- c) A subtype with unconstrained discriminants without defaults.
--
-- Declare tagged types with unconstrained discriminants without
-- defaults. Declare an unconstrained array. Declare a generic formal
-- type with an unknown discriminant and a formal object of this type.
-- In the generic package, declare an object of the formal type using
-- the formal object as its initial value. In the main program,
-- declare objects of tagged types. Instantiate the generic package.
-- The test checks that Constraint_Error is raised if an attempt is
-- made to change bounds as well as discriminants of the objects of the
-- indefinite subtypes.
--
--
-- CHANGE HISTORY:
-- 01 Nov 95 SAIC Initial prerelease version.
-- 27 Jul 96 SAIC Modified test description & Report.Test. Added
-- code to prevent dead variable optimization.
--
--!
package C330002_0 is
subtype Small_Num is Integer range 1 .. 20;
-- Types with unconstrained discriminants without defaults.
type Tag_Type (Disc : Small_Num) is tagged
record
S : String (1 .. Disc);
end record;
function Tag_Value return Tag_Type;
procedure Assign_Tag (A : out Tag_Type);
procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String);
---------------------------------------------------------------------
-- An unconstrained array type.
type Array_Type is array (Positive range <>) of Integer;
function Array_Value return Array_Type;
procedure Assign_Array (A : out Array_Type);
---------------------------------------------------------------------
generic
-- Type with an unknown discriminant.
type Formal_Type (<>) is private;
FT_Obj : Formal_Type;
package Gen is
Gen_Obj : Formal_Type := FT_Obj;
end Gen;
end C330002_0;
--==================================================================--
with Report;
package body C330002_0 is
procedure Assign_Tag (A : out Tag_Type) is
begin
A := (3, "Bye");
end Assign_Tag;
----------------------------------------------------------------------
procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is
Default : Tag_Type := (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;
----------------------------------------------------------------------
function Tag_Value return Tag_Type is
TO : Tag_Type := (4 , "ACVC");
begin
return TO;
end Tag_Value;
----------------------------------------------------------------------
function Array_Value return Array_Type is
IA : Array_Type := (20, 31);
begin
return IA;
end Array_Value;
----------------------------------------------------------------------
procedure Assign_Array (A : out Array_Type) is
begin
A := (84, 36);
end Assign_Array;
end C330002_0;
--==================================================================--
with Report;
with C330002_0;
use C330002_0;
procedure C330002 is
begin
Report.Test ("C330002", "Check that if a subtype indication of a " &
"variable object defines an indefinite subtype, then " &
"there is an initialization expression. Check that " &
"the object remains so constrained throughout its " &
"lifetime. Check that Constraint_Error is raised " &
"if an attempt is made to change bounds as well as " &
"discriminants of the objects of the indefinite " &
"subtypes. Check for cases of tagged record and generic " &
"formal types");
TagObj_Block:
declare
TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is
-- aggregate.
TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is
-- an object.
TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is
-- function return value.
Ren_Obj : Tag_Type renames TObj_ByAgg;
begin
begin
if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then
Report.Failed ("Wrong initial values for TObj_ByAgg");
end if;
TObj_ByAgg := (2, "Hi"); -- C_E, can't change the
-- value of the discriminant.
Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1");
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 1");
end;
begin
Assign_Tag (Ren_Obj); -- C_E, can't change the
-- value of the discriminant.
Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2");
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 2");
end;
begin
if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then
Report.Failed ("Wrong initial values for TObj_ByObj");
end if;
TObj_ByObj := (3, "Bye"); -- C_E, can't change the
-- value of the discriminant.
Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3");
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 3");
end;
begin
if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then
Report.Failed ("Wrong initial values for TObj_ByFunc");
end if;
TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the
-- value of the discriminant.
Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4");
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 4");
end;
end TagObj_Block;
ArrObj_Block:
declare
Arr_Const : constant Array_Type
:= (9, 7, 6, 8);
Arr_ByAgg : Array_Type -- Initial assignment is
:= (10, 11, 12); -- aggregate.
Arr_ByFunc : Array_Type -- Initial assignment is
:= Array_Value; -- function return value.
Arr_ByObj : Array_Type -- Initial assignment is
:= Arr_ByAgg; -- object.
Arr_Obj : array (Positive range <>) of Integer
:= (1, 2, 3, 4, 5);
begin
begin
if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then
Report.Failed ("Wrong bounds for Arr_Const");
end if;
if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then
Report.Failed ("Wrong bounds for Arr_ByAgg");
end if;
if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then
Report.Failed ("Wrong bounds for Arr_ByFunc");
end if;
if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then
Report.Failed ("Wrong bounds for Arr_ByObj");
end if;
Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are
-- 1..3.
Report.Failed ("Constraint_Error not raised - Subtest 5");
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 5");
end;
begin
if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then
Report.Failed ("Wrong bounds for Arr_Obj");
end if;
for I in 0 .. 5 loop
Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are
end loop; -- 1..5.
Report.Failed ("Constraint_Error not raised - Subtest 6");
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 6");
end;
end ArrObj_Block;
GenericObj_Block:
declare
type Rec (Disc : Small_Num) is
record
S : Small_Num := Disc;
end record;
Rec_Obj : Rec := (2, 2);
package IGen is new Gen (Rec, Rec_Obj);
begin
IGen.Gen_Obj := (3, 3); -- C_E, can't change the
-- value of the discriminant.
Report.Failed ("Constraint_Error not raised - Subtest 7");
-- Next line prevents dead assignment.
Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc));
exception
when Constraint_Error => null; -- Exception is expected.
when others =>
Report.Failed ("Unexpected exception - Subtest 7");
end GenericObj_Block;
Report.Result;
end C330002;