URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [support/] [f393a00.a] - Rev 399
Go to most recent revision | Compare with Previous | Blame | View Log
-- F393A00.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.
--*
--
-- FOUNDATION DESCRIPTION:
-- This foundation provides a simple background for a class family
-- based on an abstract type. It is to be used to test the
-- dispatching of various forms of subprogram defined/inherited and
-- overridden with the abstract type.
--
-- type procedures functions
-- ---- ---------- ---------
-- Object Initialize, Swap(abstract) Create(abstract)
-- Object'Class Initialized
-- Windmill is new Object Swap, Stop, Add_Spin Create, Spin
-- Pump is new Windmill Set_Rate Create, Rate
-- Mill is new Windmill Swap, Stop Create
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
package F393A00_0 is
procedure TC_Touch ( A_Tag : Character );
procedure TC_Validate( Expected: String; Message: String );
end F393A00_0;
with Report;
package body F393A00_0 is
Expectation : String(1..20);
Finger : Natural := 0;
procedure TC_Touch ( A_Tag : Character ) is
begin
Finger := Finger+1;
Expectation(Finger) := A_Tag;
end TC_Touch;
procedure TC_Validate( Expected: String; Message: String ) is
begin
if Expectation(1..Finger) /= Expected then
Report.Failed( Message & " Expecting: " & Expected
& " Got: " & Expectation(1..Finger) );
end if;
Finger := 0;
end TC_Validate;
end F393A00_0;
----------------------------------------------------------------------
package F393A00_1 is
type Object is abstract tagged private;
procedure Initialize( An_Object: in out Object );
function Initialized( An_Object: Object'Class ) return Boolean;
procedure Swap( A,B: in out Object ) is abstract;
function Create return Object is abstract;
private
type Object is abstract tagged record
Initialized : Boolean := False;
end record;
end F393A00_1;
with F393A00_0;
package body F393A00_1 is
procedure Initialize( An_Object: in out Object ) is
begin
An_Object.Initialized := True;
F393A00_0.TC_Touch('a');
end Initialize;
function Initialized( An_Object: Object'Class ) return Boolean is
begin
F393A00_0.TC_Touch('b');
return An_Object.Initialized;
end Initialized;
end F393A00_1;
----------------------------------------------------------------------
with F393A00_1;
package F393A00_2 is
type Rotational_Measurement is range -1_000 .. 1_000;
type Windmill is new F393A00_1.Object with private;
procedure Swap( A,B: in out Windmill );
function Create return Windmill;
procedure Add_Spin( To_Mill : in out Windmill;
RPMs : in Rotational_Measurement );
procedure Stop( Mill : in out Windmill );
function Spin( Mill : Windmill ) return Rotational_Measurement;
private
type Windmill is new F393A00_1.Object with
record
Spin : Rotational_Measurement := 0;
end record;
end F393A00_2;
with F393A00_0;
package body F393A00_2 is
procedure Swap( A,B: in out Windmill ) is
T : constant Windmill := B;
begin
F393A00_0.TC_Touch('c');
B := A;
A := T;
end Swap;
function Create return Windmill is
A_Mill : Windmill;
begin
F393A00_0.TC_Touch('d');
return A_Mill;
end Create;
procedure Add_Spin( To_Mill : in out Windmill;
RPMs : in Rotational_Measurement ) is
begin
F393A00_0.TC_Touch('e');
To_Mill.Spin := To_Mill.Spin + RPMs;
end Add_Spin;
procedure Stop( Mill : in out Windmill ) is
begin
F393A00_0.TC_Touch('f');
Mill.Spin := 0;
end Stop;
function Spin( Mill : Windmill ) return Rotational_Measurement is
begin
F393A00_0.TC_Touch('g');
return Mill.Spin;
end Spin;
end F393A00_2;
----------------------------------------------------------------------
with F393A00_2;
package F393A00_3 is
type Pump is new F393A00_2.Windmill with private;
function Create return Pump;
type Gallons_Per_Revolution is digits 3;
procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution);
function Rate( Of_Pump: Pump ) return Gallons_Per_Revolution;
private
type Pump is new F393A00_2.Windmill with
record
GPRPM : Gallons_Per_Revolution := 0.0; -- Gallons/RPM
end record;
end F393A00_3;
with F393A00_0;
package body F393A00_3 is
function Create return Pump is
Sump : Pump;
begin
F393A00_0.TC_Touch('h');
return Sump;
end Create;
procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution)
is
begin
F393A00_0.TC_Touch('i');
A_Pump.GPRPM := To_Rate;
end Set_Rate;
function Rate( Of_Pump: Pump ) return Gallons_Per_Revolution is
begin
F393A00_0.TC_Touch('j');
return Of_Pump.GPRPM;
end Rate;
end F393A00_3;
----------------------------------------------------------------------
with F393A00_2;
with F393A00_3;
package F393A00_4 is
type Mill is new F393A00_2.Windmill with private;
procedure Swap( A,B: in out Mill );
function Create return Mill;
procedure Stop( It: in out Mill );
private
type Mill is new F393A00_2.Windmill with
record
Pump: F393A00_3.Pump := F393A00_3.Create;
end record;
end F393A00_4;
with F393A00_0;
package body F393A00_4 is
procedure Swap( A,B: in out Mill ) is
T: constant Mill := A;
begin
F393A00_0.TC_Touch('k');
A := B;
B := T;
end Swap;
function Create return Mill is
A_Mill : Mill;
begin
F393A00_0.TC_Touch('l');
return A_Mill;
end Create;
procedure Stop( It: in out Mill ) is
begin
F393A00_0.TC_Touch('m');
F393A00_3.Stop( It.Pump );
F393A00_2.Stop( F393A00_2.Windmill( It ) );
end Stop;
end F393A00_4;
Go to most recent revision | Compare with Previous | Blame | View Log