246 lines
7.0 KiB
Plaintext
246 lines
7.0 KiB
Plaintext
-- 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;
|