gcc/testsuite/ada/acats/support/f393a00.a

   1 -- F393A00.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- FOUNDATION DESCRIPTION:
  27 --      This foundation provides a simple background for a class family
  28 --      based on an abstract type.  It is to be used to test the
  29 --      dispatching of various forms of subprogram defined/inherited and
  30 --      overridden with the abstract type.
  31 --
  32 --  type                       procedures                  functions
  33 --  ----                       ----------                  ---------
  34 --  Object                     Initialize, Swap(abstract)  Create(abstract)
  35 --        Object'Class                                     Initialized
  36 --    Windmill is new Object   Swap, Stop, Add_Spin        Create, Spin
  37 --      Pump is new Windmill   Set_Rate                    Create, Rate
  38 --      Mill is new Windmill   Swap, Stop                  Create
  39 --
  40 -- CHANGE HISTORY:
  41 --      06 Dec 94   SAIC    ACVC 2.0
  42 --
  43 --!
  44
  45 package F393A00_0 is
  46    procedure TC_Touch ( A_Tag : Character );
  47    procedure TC_Validate( Expected: String; Message: String );
  48 end F393A00_0;
  49
  50 with Report;
  51 package body F393A00_0 is
  52    Expectation : String(1..20);
  53    Finger      : Natural := 0;
  54
  55    procedure TC_Touch ( A_Tag : Character ) is
  56    begin
  57      Finger := Finger+1;
  58      Expectation(Finger) := A_Tag;
  59    end TC_Touch;
  60
  61    procedure TC_Validate( Expected: String; Message: String ) is
  62    begin
  63      if Expectation(1..Finger) /= Expected then
  64        Report.Failed( Message & " Expecting: " & Expected
  65                              & " Got: " & Expectation(1..Finger) );
  66      end if;
  67      Finger := 0;
  68    end TC_Validate;
  69 end F393A00_0;
  70
  71 ----------------------------------------------------------------------
  72
  73 package F393A00_1 is
  74    type Object is abstract tagged private;
  75    procedure Initialize( An_Object: in out Object );
  76    function  Initialized( An_Object: Object'Class ) return Boolean;
  77    procedure Swap( A,B: in out Object ) is abstract;
  78    function  Create return Object is abstract;
  79 private
  80    type Object is abstract tagged record
  81      Initialized : Boolean := False;
  82    end record;
  83 end F393A00_1;
  84
  85 with F393A00_0;
  86 package body F393A00_1 is
  87    procedure Initialize( An_Object: in out Object ) is
  88    begin
  89      An_Object.Initialized := True;
  90      F393A00_0.TC_Touch('a');
  91    end Initialize;
  92
  93    function  Initialized( An_Object: Object'Class ) return Boolean is
  94    begin
  95      F393A00_0.TC_Touch('b');
  96      return An_Object.Initialized;
  97    end Initialized;
  98 end F393A00_1;
  99
 100 ----------------------------------------------------------------------
 101
 102 with F393A00_1;
 103 package F393A00_2 is
 104
 105    type Rotational_Measurement is range -1_000 .. 1_000;
 106    type Windmill is new F393A00_1.Object with private;
 107
 108    procedure Swap( A,B: in out Windmill );
 109
 110    function  Create return Windmill;
 111
 112    procedure Add_Spin( To_Mill : in out Windmill;
 113                       RPMs    : in     Rotational_Measurement );
 114
 115    procedure Stop( Mill : in out Windmill );
 116
 117    function  Spin( Mill : Windmill ) return Rotational_Measurement;
 118
 119 private
 120    type Windmill is new F393A00_1.Object with
 121      record
 122        Spin : Rotational_Measurement := 0;
 123      end record;
 124 end F393A00_2;
 125
 126 with F393A00_0;
 127 package body F393A00_2 is
 128
 129    procedure Swap( A,B: in out Windmill ) is
 130      T : constant Windmill := B;
 131    begin
 132      F393A00_0.TC_Touch('c');
 133      B := A;
 134      A := T;
 135    end Swap;
 136
 137    function  Create return Windmill is
 138      A_Mill : Windmill;
 139    begin
 140      F393A00_0.TC_Touch('d');
 141      return A_Mill;
 142    end Create;
 143
 144    procedure Add_Spin( To_Mill : in out Windmill;
 145                       RPMs    : in     Rotational_Measurement ) is
 146    begin
 147      F393A00_0.TC_Touch('e');
 148      To_Mill.Spin := To_Mill.Spin + RPMs;
 149    end Add_Spin;
 150
 151    procedure Stop( Mill : in out Windmill ) is
 152    begin
 153      F393A00_0.TC_Touch('f');
 154      Mill.Spin := 0;
 155    end Stop;
 156
 157    function  Spin( Mill : Windmill ) return Rotational_Measurement is
 158    begin
 159      F393A00_0.TC_Touch('g');
 160      return Mill.Spin;
 161    end Spin;
 162
 163 end F393A00_2;
 164
 165 ----------------------------------------------------------------------
 166
 167 with F393A00_2;
 168 package F393A00_3 is
 169    type Pump is new F393A00_2.Windmill with private;
 170    function Create return Pump;
 171
 172    type Gallons_Per_Revolution is digits 3;
 173    procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution);
 174    function  Rate( Of_Pump: Pump ) return Gallons_Per_Revolution;
 175 private
 176    type Pump is new F393A00_2.Windmill with
 177      record
 178        GPRPM : Gallons_Per_Revolution := 0.0; -- Gallons/RPM
 179      end record;
 180 end F393A00_3;
 181
 182 with F393A00_0;
 183 package body F393A00_3 is
 184    function Create return Pump is
 185      Sump : Pump;
 186    begin
 187      F393A00_0.TC_Touch('h');
 188      return Sump;
 189    end Create;
 190
 191    procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution)
 192    is
 193    begin
 194      F393A00_0.TC_Touch('i');
 195      A_Pump.GPRPM := To_Rate;
 196    end Set_Rate;
 197
 198    function  Rate( Of_Pump: Pump ) return Gallons_Per_Revolution is
 199    begin
 200      F393A00_0.TC_Touch('j');
 201      return Of_Pump.GPRPM;
 202    end Rate;
 203 end F393A00_3;
 204
 205 ----------------------------------------------------------------------
 206
 207 with F393A00_2;
 208 with F393A00_3;
 209 package F393A00_4 is
 210    type Mill is new F393A00_2.Windmill with private;
 211
 212    procedure Swap( A,B: in out Mill );
 213    function  Create return Mill;
 214    procedure Stop( It: in out Mill );
 215  private
 216    type Mill is new F393A00_2.Windmill with
 217      record
 218        Pump: F393A00_3.Pump := F393A00_3.Create;
 219      end record;
 220 end F393A00_4;
 221
 222 with F393A00_0;
 223 package body F393A00_4 is
 224    procedure Swap( A,B: in out Mill ) is
 225      T: constant Mill := A;
 226    begin
 227      F393A00_0.TC_Touch('k');
 228      A := B;
 229      B := T;
 230    end Swap;
 231
 232    function  Create return Mill is
 233      A_Mill : Mill;
 234    begin
 235      F393A00_0.TC_Touch('l');
 236      return A_Mill;
 237    end Create;
 238
 239    procedure Stop( It: in out Mill ) is
 240    begin
 241      F393A00_0.TC_Touch('m');
 242      F393A00_3.Stop( It.Pump );
 243      F393A00_2.Stop( F393A00_2.Windmill( It ) );
 244    end Stop;
 245 end F393A00_4;