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/] [c393a02.a] - Rev 294
Go to most recent revision | Compare with Previous | Blame | View Log
-- C393A02.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 a dispatching call to an abstract subprogram invokes
-- the correct subprogram body of a descendant type according to
-- the controlling tag.
-- Check that a subprogram can be declared with formal parameters
-- and result that are of an abstract type's associated class-wide
-- type and that such subprograms can be called. 3.4.1(4)
--
-- TEST DESCRIPTION:
-- This test declares several objects of types derived from the
-- abstract type as defined in the foundation F393A00. It then calls
-- various dispatching and class-wide subprograms using those objects.
-- The packages in F393A00 are instrumented to trace the flow of
-- execution.
-- The test checks for the correct order of execution, as expected
-- by the various calls.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- F393A00.A (foundation code)
-- C393A02.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 19 Dec 94 SAIC Removed RM references from objective text.
-- 05 APR 96 SAIC Update RM references for 2.1
--
--!
with Report;
with F393A00_0;
with F393A00_1;
with F393A00_2;
with F393A00_3;
with F393A00_4;
procedure C393A02 is
A_Windmill : F393A00_2.Windmill;
A_Pump : F393A00_3.Pump;
A_Mill : F393A00_4.Mill;
A_Windmill_2 : F393A00_2.Windmill;
A_Pump_2 : F393A00_3.Pump;
A_Mill_2 : F393A00_4.Mill;
B_Windmill : F393A00_2.Windmill;
B_Pump : F393A00_3.Pump;
B_Mill : F393A00_4.Mill;
procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is
begin
F393A00_0.TC_Touch('x');
F393A00_2.Swap( A,B );
end Swapem;
function Zephyr( A: F393A00_2.Windmill'Class )
return F393A00_2.Windmill'Class is
Item : F393A00_2.Windmill'Class := A;
begin
F393A00_0.TC_Touch('y');
if not F393A00_1.Initialized( Item ) then -- b
F393A00_2.Initialize( Item ); -- a
end if;
F393A00_2.Stop( Item ); -- f / mff
F393A00_2.Add_Spin( Item, 10 ); -- e
return Item;
end Zephyr;
function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is
Item : F393A00_2.Windmill'Class := It;
begin
F393A00_2.Stop( Item ); -- f
F393A00_2.Add_Spin( Item, 40 ); -- e
return Item;
end Gale;
function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is
Item : F393A00_2.Windmill'Class := It;
begin
F393A00_2.Stop( Item ); -- f
F393A00_2.Add_Spin( Item, 50 ); -- e
return Item;
end Gale;
function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is
Item : F393A00_2.Windmill'Class := It;
begin
F393A00_2.Stop( Item ); -- mff
F393A00_2.Add_Spin( Item, 60 ); -- e
return Item;
end Gale;
begin -- Main test procedure.
Report.Test ("C393A02", "Check that a dispatching call to an abstract "
& "subprogram invokes the correct subprogram body. "
& "Check that a subprogram declared with formal "
& "parameters/result of an abstract type's "
& "associated class-wide can be called" );
F393A00_0.TC_Validate( "hhh", "Mill declarations" );
A_Windmill := F393A00_2.Create;
F393A00_0.TC_Validate( "d", "Create A_Windmill" );
A_Pump := F393A00_3.Create;
F393A00_0.TC_Validate( "h", "Create A_Pump" );
A_Mill := F393A00_4.Create;
F393A00_0.TC_Validate( "hl", "Create A_Mill" );
--------------
Swapem( A_Windmill, A_Windmill_2 );
F393A00_0.TC_Validate( "xc", "Windmill Swap" );
Swapem( A_Pump, A_Pump_2 );
F393A00_0.TC_Validate( "xc", "Pump Swap" );
Swapem( A_Mill, A_Mill_2 );
F393A00_0.TC_Validate( "xk", "Pump Swap" );
F393A00_2.Initialize( A_Windmill_2 );
F393A00_3.Initialize( A_Pump_2 );
F393A00_4.Initialize( A_Mill_2 );
B_Windmill := A_Windmill_2;
B_Pump := A_Pump_2;
B_Mill := A_Mill_2;
F393A00_2.Add_Spin( B_Windmill, 123 );
F393A00_3.Set_Rate( B_Pump, 12.34 );
F393A00_4.Add_Spin( B_Mill, 321 );
F393A00_0.TC_Validate( "aaaeie", "Setting Values" );
declare
It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe
XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe
use type F393A00_2.Rotational_Measurement;
begin
if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
then
Report.Failed( "Copy to class-wide variable" );
end if; -- bb
if F393A00_2.Spin( It ) /= 10 -- g
or F393A00_2.Spin( XX ) /= 40 then -- g
Report.Failed( "Call to class-wide operation" );
end if;
F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" );
end;
declare
It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe
XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe
use type F393A00_2.Rotational_Measurement;
begin
if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
then
Report.Failed( "Bad copy to class-wide variable" );
end if; -- bb
if F393A00_2.Spin( It ) /= 10 -- g
or F393A00_2.Spin( XX ) /= 50 then -- g
Report.Failed( "Call to class-wide operation" );
end if;
F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" );
end;
declare
It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe
XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe
use type F393A00_2.Rotational_Measurement;
begin
if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
then
Report.Failed( "Bad copy to class-wide variable" );
end if; -- bb
if F393A00_2.Spin( It ) /= 10 -- g
or F393A00_2.Spin( XX ) /= 60 then -- g
Report.Failed( "Call to class-wide operation" );
end if;
F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" );
end;
Report.Result;
end C393A02;
Go to most recent revision | Compare with Previous | Blame | View Log