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