diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/support/f393a00.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/support/f393a00.a | 245 |
1 files changed, 0 insertions, 245 deletions
diff --git a/gcc/testsuite/ada/acats/support/f393a00.a b/gcc/testsuite/ada/acats/support/f393a00.a deleted file mode 100644 index e85c3f49cd0..00000000000 --- a/gcc/testsuite/ada/acats/support/f393a00.a +++ /dev/null @@ -1,245 +0,0 @@ --- 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; |