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

   1 -- C392011.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 if a function call with a controlling result is itself
  28 --     a controlling operand of an enclosing call on a dispatching operation,
  29 --     then its controlling tag value is determined by the controlling tag
  30 --     value of the enclosing call.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      The test builds and traverses a "ragged" list; a linked list which
  34 --      contains data elements of three different types (all rooted at
  35 --      Level_0'Class).  The traversal of this list checks the objective
  36 --      by calling the dispatching operation "Check" using an item from the
  37 --      list, and calling the function create; thus causing the controlling
  38 --      result of the function to be determined by evaluating the value of
  39 --      the other controlling parameter to the two-parameter Check.
  40 --
  41 --
  42 -- CHANGE HISTORY:
  43 --      22 SEP 95   SAIC   Initial version
  44 --      23 APR 96   SAIC   Corrected commentary, differentiated integer.
  45 --
  46 --!
  47
  48 ----------------------------------------------------------------- C392011_0
  49
  50 package C392011_0 is
  51
  52   type Level_0 is tagged record
  53     Ch_Item : Character;
  54   end record;
  55
  56   function Create return Level_0;
  57     -- primitive dispatching function
  58
  59   procedure Check( Left, Right: in Level_0 );
  60     -- has controlling parameters
  61
  62 end C392011_0;
  63
  64 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  65
  66 with Report;
  67 with TCTouch;
  68 package body C392011_0 is
  69
  70   The_Character : Character := 'A';
  71
  72   function Create return Level_0 is
  73     Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character );
  74   begin
  75     The_Character := Character'Succ(The_Character);
  76     TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A
  77     return Created_Item_0;
  78   end Create;
  79
  80   procedure Check( Left, Right: in Level_0 ) is
  81   begin
  82     TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B
  83   end Check;
  84
  85 end C392011_0;
  86
  87 ----------------------------------------------------------------- C392011_1
  88
  89 with C392011_0;
  90 package C392011_1 is
  91
  92   type Level_1 is new C392011_0.Level_0 with record
  93     Int_Item : Integer;
  94   end record;
  95
  96   -- note that Create becomes abstract upon this derivation hence:
  97
  98   function Create return Level_1;
  99
 100   procedure Check( Left, Right: in Level_1 );
 101
 102 end C392011_1;
 103
 104 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 105
 106 with TCTouch;
 107 package body C392011_1 is
 108
 109   Integer_1 : Integer := 0;
 110
 111   function Create return Level_1 is
 112     Created_Item_1 : constant Level_1
 113                    := ( C392011_0.Create with Int_Item => Integer_1 );
 114     -- note call to     ^--------------^   -- A
 115   begin
 116     Integer_1 := Integer'Succ(Integer_1);
 117     TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C
 118     return Created_Item_1;
 119   end Create;
 120
 121   procedure Check( Left, Right: in Level_1 ) is
 122   begin
 123     TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D
 124   end Check;
 125
 126 end C392011_1;
 127
 128 ----------------------------------------------------------------- C392011_2
 129
 130 with C392011_1;
 131 package C392011_2 is
 132
 133   type Level_2 is new C392011_1.Level_1 with record
 134     Another_Int_Item : Integer;
 135   end record;
 136
 137   -- note that Create becomes abstract upon this derivation hence:
 138
 139   function Create return Level_2;
 140
 141   procedure Check( Left, Right: in Level_2 );
 142
 143 end C392011_2;
 144
 145 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 146
 147 with TCTouch;
 148 package body C392011_2 is
 149
 150   Integer_2 : Integer := 100;
 151
 152   function Create return Level_2 is
 153     Created_Item_2 : constant Level_2
 154                  := ( C392011_1.Create with Another_Int_Item => Integer_2 );
 155     -- note call to   ^--------------^   -- AC
 156   begin
 157     Integer_2 := Integer'Succ(Integer_2);
 158     TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E
 159     return Created_Item_2;
 160   end Create;
 161
 162   procedure Check( Left, Right: in Level_2 ) is
 163   begin
 164     TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F
 165   end Check;
 166
 167 end C392011_2;
 168
 169 ------------------------------------------------------- C392011_2.C392011_3
 170
 171 with C392011_0;
 172 package C392011_2.C392011_3 is
 173
 174   type Wide_Reference is access all C392011_0.Level_0'Class;
 175
 176   type Ragged_Element;
 177
 178   type List_Pointer is access Ragged_Element;
 179
 180   type Ragged_Element is record
 181     Data : Wide_Reference;
 182     Next : List_Pointer;
 183   end record;
 184
 185   procedure Build_List;
 186
 187   procedure Traverse_List;
 188
 189 end C392011_2.C392011_3;
 190
 191 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 192
 193 package body C392011_2.C392011_3 is
 194
 195   The_List : List_Pointer;
 196
 197   procedure Build_List is
 198   begin
 199
 200     -- build a list that looks like:
 201     -- Level_2, Level_1, Level_2, Level_1, Level_0
 202     --
 203     -- the mechanism is to create each object, "pushing" the existing list
 204     -- onto the end: cons( new_item, car, cdr )
 205
 206     The_List :=
 207         new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null );
 208     -- Level_0                                                            >> A
 209
 210     The_List :=
 211     new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
 212     -- Level_1 -> Level_0                                                >> AC
 213
 214     The_List :=
 215     new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
 216     -- Level_2 -> Level_1 -> Level_0                                    >> ACE
 217
 218     The_List :=
 219     new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
 220     -- Level_1 -> Level_2 -> Level_1 -> Level_0                          >> AC
 221
 222     The_List :=
 223     new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
 224     -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0              >> ACE
 225
 226   end Build_List;
 227
 228   procedure Traverse_List is
 229
 230     Next_Item : List_Pointer := The_List;
 231
 232   -- Check that if a function call with a controlling result is itself
 233   -- a controlling operand of an enclosing call on a dispatching operation,
 234   -- then its controlling tag value is determined by the controlling tag
 235   -- value of the enclosing call.
 236
 237   -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0
 238
 239   begin
 240
 241     while Next_Item /= null loop  -- here we go!
 242       -- these calls better dispatch according to the value in the particular
 243       -- list item; causing the call to create to dispatch accordingly.
 244       -- why do it twice?  To make sure order makes no difference
 245
 246       C392011_0.Check(Next_Item.Data.all, C392011_0.Create);
 247       -- Create will touch first, then Check touches
 248
 249       C392011_0.Check(C392011_0.Create, Next_Item.Data.all);
 250
 251       -- Here's what's s'pos'd to 'appen:
 252       -- Check( Lev_2, Create ) >> ACEF
 253       -- Check( Create, Lev_2 ) >> ACEF
 254       -- Check( Lev_1, Create ) >> ACD
 255       -- Check( Create, Lev_1 ) >> ACD
 256       -- Check( Lev_2, Create ) >> ACEF
 257       -- Check( Create, Lev_2 ) >> ACEF
 258       -- Check( Lev_1, Create ) >> ACD
 259       -- Check( Create, Lev_1 ) >> ACD
 260       -- Check( Lev_0, Create ) >> AB
 261       -- Check( Create, Lev_0 ) >> AB
 262
 263       Next_Item := Next_Item.Next;
 264     end loop;
 265   end Traverse_List;
 266
 267 end C392011_2.C392011_3;
 268
 269 ------------------------------------------------------------------- C392011
 270
 271 with Report;
 272 with TCTouch;
 273 with C392011_2.C392011_3;
 274
 275 procedure C392011 is
 276
 277 begin  -- Main test procedure.
 278
 279   Report.Test ("C392011", "Check that if a function call with a " &
 280                           "controlling result is itself a controlling " &
 281                           "operand of an enclosing call on a dispatching " &
 282                           "operation, then its controlling tag value is " &
 283                           "determined by the controlling tag value of " &
 284                           "the enclosing call" );
 285
 286   C392011_2.C392011_3.Build_List;
 287   TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" );
 288
 289   C392011_2.C392011_3.Traverse_List;
 290   TCTouch.Validate( "ACEFACEF" &
 291                     "ACDACD" &
 292                     "ACEFACEF" &
 293                     "ACDACD" &
 294                     "ABAB",
 295                     "Traverse List" );
 296
 297   Report.Result;
 298
 299 end C392011;