gcc/testsuite/ada/acats/tests/c3/c393a03.a

   1 -- C393A03.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 non-abstract primitive subprogram of an abstract
  28 --      type can be called as a dispatching operation and that the body
  29 --      of this subprogram can make a dispatching call to an abstract
  30 --      operation of the corresponding abstract type.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      This test expands on the class family defined in foundation F393A00
  34 --      by deriving a new abstract type from the root abstract type "Object".
  35 --      The subprograms defined for the new abstract type are then
  36 --      appropriately overridden, and the test ultimately calls various
  37 --      mixtures of these subprograms to check that the dispatching occurs
  38 --      correctly.
  39 --
  40 -- TEST FILES:
  41 --      The following files comprise this test:
  42 --
  43 --         F393A00.A   (foundation code)
  44 --         C393A03.A
  45 --
  46 --
  47 -- CHANGE HISTORY:
  48 --      06 Dec 94   SAIC    ACVC 2.0
  49 --      19 Dec 94   SAIC    Removed ARM references from objective text.
  50 --      23 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
  51 --
  52 --!
  53
  54 ------------------------------------------------------------------- C393A03_0
  55
  56 with F393A00_1;
  57 package C393A03_0 is
  58
  59   type Counting_Object is abstract new F393A00_1.Object with private;
  60   -- inherits Initialize, Swap (abstract) and Create (abstract)
  61
  62   procedure Bump ( A_Counter: in out Counting_Object );
  63   procedure Clear( A_Counter: in out Counting_Object ) is abstract;
  64   procedure Zero ( A_Counter: in out Counting_Object );
  65   function  Value( A_Counter: Counting_Object'Class ) return Natural;
  66
  67 private
  68
  69   type Counting_Object is abstract new F393A00_1.Object with
  70     record
  71       Tally : Natural :=0;
  72     end record;
  73
  74 end C393A03_0;
  75
  76 -----------------------------------------------------------------------------
  77
  78 with F393A00_0;
  79 package body C393A03_0 is
  80
  81   procedure Bump ( A_Counter: in out Counting_Object ) is
  82   begin
  83     F393A00_0.TC_Touch('A');
  84     A_Counter.Tally := A_Counter.Tally +1;
  85   end Bump;
  86
  87   procedure Zero ( A_Counter: in out Counting_Object ) is
  88   begin
  89     F393A00_0.TC_Touch('B');
  90
  91  -- dispatching call to abstract operation of Counting_Object
  92     Clear( Counting_Object'Class(A_Counter) );
  93
  94     A_Counter.Tally := 0;
  95
  96   end Zero;
  97
  98   function  Value( A_Counter: Counting_Object'Class ) return Natural is
  99   begin
 100     F393A00_0.TC_Touch('C');
 101     return A_Counter.Tally;
 102   end Value;
 103
 104 end C393A03_0;
 105
 106 ------------------------------------------------------------------- C393A03_1
 107
 108 with C393A03_0;
 109 package C393A03_1 is
 110
 111   type Modular_Object is new C393A03_0.Counting_Object with private;
 112   -- inherits Initialize, Bump, Zero and Value,
 113   -- inherits abstract Swap, Create and Clear
 114
 115   procedure Swap( A,B: in out Modular_Object );
 116   procedure Clear( It: in out Modular_Object );
 117   procedure Set_Max( It : in out Modular_Object; Value : Natural );
 118   function  Create return Modular_Object;
 119
 120 private
 121
 122   type Modular_Object is new C393A03_0.Counting_Object with
 123     record
 124       Max_Value : Natural;
 125     end record;
 126
 127 end C393A03_1;
 128
 129 -----------------------------------------------------------------------------
 130
 131 with F393A00_0;
 132 package body C393A03_1 is
 133
 134   procedure Swap( A,B: in out Modular_Object ) is
 135     T : constant Modular_Object := B;
 136   begin
 137     F393A00_0.TC_Touch('1');
 138     B := A;
 139     A := T;
 140   end Swap;
 141
 142   procedure Clear( It: in out Modular_Object ) is
 143   begin
 144     F393A00_0.TC_Touch('2');
 145     null;
 146   end Clear;
 147
 148   procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
 149   begin
 150     F393A00_0.TC_Touch('3');
 151     It.Max_Value := Value;
 152   end Set_Max;
 153
 154   function  Create return Modular_Object is
 155     AMO : Modular_Object;
 156   begin
 157     F393A00_0.TC_Touch('4');
 158     AMO.Max_Value := Natural'Last;
 159     return AMO;
 160   end Create;
 161
 162 end C393A03_1;
 163
 164 --------------------------------------------------------------------- C393A03
 165
 166 with Report;
 167 with F393A00_0;
 168 with F393A00_1;
 169 with C393A03_0;
 170 with C393A03_1;
 171 procedure C393A03 is
 172
 173   A_Thing       : C393A03_1.Modular_Object;
 174   Another_Thing : C393A03_1.Modular_Object;
 175
 176   procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
 177   begin
 178     C393A03_0.Initialize( It );  -- dispatch to inherited procedure
 179   end Initialize;
 180
 181   procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
 182   begin
 183     C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
 184   end Bump;
 185
 186   procedure Set_Max( It  : in out C393A03_1.Modular_Object'Class;
 187                      Val : Natural) is
 188   begin
 189     C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
 190   end Set_Max;
 191
 192   procedure Swap( A, B  : in out C393A03_0.Counting_Object'Class ) is
 193   begin
 194     C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
 195   end Swap;
 196
 197   procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
 198   begin
 199     C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
 200   end Zero;
 201
 202 begin  -- Main test procedure.
 203
 204    Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
 205                          & "of an abstract type can be called as a "
 206                          & "dispatching operation and that the body of this "
 207                          & "subprogram can make a dispatching call to an "
 208                          & "abstract operation of the corresponding "
 209                          & "abstract type" );
 210
 211    A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
 212    F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");
 213
 214    Initialize( A_Thing );
 215    Initialize( Another_Thing );
 216    F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
 217
 218    Bump( A_Thing ); -- Tally = 1
 219    F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");
 220
 221    Set_Max( A_Thing, 42 ); -- Max_Value = 42
 222    F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");
 223
 224    if not F393A00_1.Initialized( A_Thing ) then
 225      Report.Failed("Initialize didn't");
 226    end if;
 227    F393A00_0.TC_Validate( "b", "Class-wide layer 0");
 228
 229    Swap( A_Thing, Another_Thing );
 230    F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");
 231
 232    Zero( A_Thing );
 233    F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");
 234
 235    if C393A03_0.Value( A_Thing ) /= 0 then
 236      Report.Failed("Zero didn't");
 237    end if;
 238    F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");
 239
 240    Report.Result;
 241
 242 end C393A03;