gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c393a02.a

   1 -- C393A02.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 -- OBJECTIVE:
  27 --     Check that a dispatching call to an abstract subprogram invokes
  28 --     the correct subprogram body of a descendant type according to
  29 --     the controlling tag.
  30 --     Check that a subprogram can be declared with formal parameters
  31 --     and result that are of an abstract type's associated class-wide
  32 --     type and that such subprograms can be called. 3.4.1(4)
  33 --
  34 -- TEST DESCRIPTION:
  35 --     This test declares several objects of types derived from the
  36 --     abstract type as defined in the foundation F393A00.  It then calls
  37 --     various dispatching and class-wide subprograms using those objects.
  38 --     The packages in F393A00 are instrumented to trace the flow of
  39 --     execution.
  40 --     The test checks for the correct order of execution, as expected
  41 --     by the various calls.
  42 --
  43 -- TEST FILES:
  44 --     The following files comprise this test:
  45 --
  46 --        F393A00.A   (foundation code)
  47 --        C393A02.A
  48 --
  49 --
  50 -- CHANGE HISTORY:
  51 --      06 Dec 94   SAIC    ACVC 2.0
  52 --      19 Dec 94   SAIC    Removed RM references from objective text.
  53 --      05 APR 96   SAIC    Update RM references for 2.1
  54 --
  55 --!
  56
  57 with Report;
  58 with F393A00_0;
  59 with F393A00_1;
  60 with F393A00_2;
  61 with F393A00_3;
  62 with F393A00_4;
  63 procedure C393A02 is
  64
  65   A_Windmill : F393A00_2.Windmill;
  66   A_Pump     : F393A00_3.Pump;
  67   A_Mill     : F393A00_4.Mill;
  68
  69   A_Windmill_2 : F393A00_2.Windmill;
  70   A_Pump_2     : F393A00_3.Pump;
  71   A_Mill_2     : F393A00_4.Mill;
  72
  73   B_Windmill : F393A00_2.Windmill;
  74   B_Pump     : F393A00_3.Pump;
  75   B_Mill     : F393A00_4.Mill;
  76
  77   procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is
  78   begin
  79    F393A00_0.TC_Touch('x');
  80    F393A00_2.Swap( A,B );
  81   end Swapem;
  82
  83   function Zephyr( A: F393A00_2.Windmill'Class )
  84            return F393A00_2.Windmill'Class is
  85     Item : F393A00_2.Windmill'Class := A;
  86   begin
  87     F393A00_0.TC_Touch('y');
  88     if not F393A00_1.Initialized( Item ) then  -- b
  89       F393A00_2.Initialize( Item );            -- a
  90     end if;
  91     F393A00_2.Stop( Item );                    -- f / mff
  92     F393A00_2.Add_Spin( Item, 10 );            -- e
  93     return Item;
  94   end Zephyr;
  95
  96   function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is
  97     Item : F393A00_2.Windmill'Class := It;
  98   begin
  99     F393A00_2.Stop( Item );                   -- f
 100     F393A00_2.Add_Spin( Item, 40 );           -- e
 101     return Item;
 102   end Gale;
 103
 104   function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is
 105     Item : F393A00_2.Windmill'Class := It;
 106   begin
 107     F393A00_2.Stop( Item );                   -- f
 108     F393A00_2.Add_Spin( Item, 50 );           -- e
 109     return Item;
 110   end Gale;
 111
 112   function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is
 113     Item : F393A00_2.Windmill'Class := It;
 114   begin
 115     F393A00_2.Stop( Item );                   -- mff
 116     F393A00_2.Add_Spin( Item, 60 );           -- e
 117     return Item;
 118   end Gale;
 119
 120 begin  -- Main test procedure.
 121
 122   Report.Test ("C393A02", "Check that a dispatching call to an abstract "
 123                          & "subprogram invokes the correct subprogram body. "
 124                          & "Check that a subprogram declared with formal "
 125                          & "parameters/result of an abstract type's "
 126                          & "associated class-wide can be called" );
 127
 128   F393A00_0.TC_Validate( "hhh", "Mill declarations" );
 129   A_Windmill := F393A00_2.Create;
 130   F393A00_0.TC_Validate( "d", "Create A_Windmill" );
 131
 132   A_Pump     := F393A00_3.Create;
 133   F393A00_0.TC_Validate( "h", "Create A_Pump" );
 134
 135   A_Mill     := F393A00_4.Create;
 136   F393A00_0.TC_Validate( "hl", "Create A_Mill" );
 137
 138   --------------
 139
 140   Swapem( A_Windmill, A_Windmill_2 );
 141   F393A00_0.TC_Validate( "xc", "Windmill Swap" );
 142
 143   Swapem( A_Pump, A_Pump_2 );
 144   F393A00_0.TC_Validate( "xc", "Pump Swap" );
 145
 146   Swapem( A_Mill, A_Mill_2 );
 147   F393A00_0.TC_Validate( "xk", "Pump Swap" );
 148
 149   F393A00_2.Initialize( A_Windmill_2 );
 150   F393A00_3.Initialize( A_Pump_2 );
 151   F393A00_4.Initialize( A_Mill_2 );
 152   B_Windmill := A_Windmill_2;
 153   B_Pump     := A_Pump_2;
 154   B_Mill     := A_Mill_2;
 155   F393A00_2.Add_Spin( B_Windmill, 123 );
 156   F393A00_3.Set_Rate( B_Pump, 12.34 );
 157   F393A00_4.Add_Spin( B_Mill, 321 );
 158   F393A00_0.TC_Validate( "aaaeie", "Setting Values" );
 159
 160   declare
 161     It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe
 162     XX : F393A00_2.Windmill'Class := Gale( B_Windmill );   -- fe
 163     use type F393A00_2.Rotational_Measurement;
 164   begin
 165     if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
 166 then
 167       Report.Failed( "Copy to class-wide variable" );
 168     end if;                                                -- bb
 169     if F393A00_2.Spin( It ) /= 10                          -- g
 170        or F393A00_2.Spin( XX ) /= 40 then                  -- g
 171       Report.Failed( "Call to class-wide operation" );
 172     end if;
 173
 174     F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" );
 175   end;
 176
 177   declare
 178     It : F393A00_2.Windmill'Class := Zephyr( B_Pump );     -- ybfe
 179     XX : F393A00_2.Windmill'Class := Gale( B_Pump );       -- fe
 180     use type F393A00_2.Rotational_Measurement;
 181   begin
 182     if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
 183 then
 184       Report.Failed( "Bad copy to class-wide variable" );
 185     end if;                                                -- bb
 186     if F393A00_2.Spin( It ) /= 10                          -- g
 187        or F393A00_2.Spin( XX ) /= 50 then                  -- g
 188       Report.Failed( "Call to class-wide operation" );
 189     end if;
 190
 191     F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" );
 192   end;
 193
 194   declare
 195     It : F393A00_2.Windmill'Class := Zephyr( B_Mill );     -- ybmffe
 196     XX : F393A00_2.Windmill'Class := Gale( B_Mill );       -- mffe
 197     use type F393A00_2.Rotational_Measurement;
 198   begin
 199     if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
 200 then
 201       Report.Failed( "Bad copy to class-wide variable" );
 202     end if;                                                -- bb
 203     if F393A00_2.Spin( It ) /= 10                          -- g
 204        or F393A00_2.Spin( XX ) /= 60 then                  -- g
 205       Report.Failed( "Call to class-wide operation" );
 206     end if;
 207
 208     F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" );
 209   end;
 210
 211   Report.Result;
 212
 213 end C393A02;