old-autovect-branch/gcc/testsuite/ada/acats/tests/cc/cc30002.a

   1 -- CC30002.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 an explicit declaration in the private part of an instance
  28 --      does not override an implicit declaration in the instance, unless the
  29 --      corresponding explicit declaration in the generic overrides a
  30 --      corresponding implicit declaration in the generic. Check for primitive
  31 --      subprograms of tagged types.
  32 --
  33 -- TEST DESCRIPTION:
  34 --      Consider the following:
  35 --
  36 --         type Ancestor is tagged null record;
  37 --         procedure R (X: in Ancestor);
  38 --
  39 --         generic
  40 --            type Formal is new Ancestor with private;
  41 --         package G is
  42 --            type T is new Formal with null record;
  43 --            -- Implicit procedure R (X: in T);
  44 --            procedure P (X: in T);  -- (1)
  45 --         private
  46 --            procedure Q (X: in T);  -- (2)
  47 --            procedure R (X: in T);  -- (3) Overrides implicit R in generic.
  48 --         end G;
  49 --
  50 --         type Actual is new Ancestor with null record;
  51 --         procedure P (X: in Actual);
  52 --         procedure Q (X: in Actual);
  53 --         procedure R (X: in Actual);
  54 --
  55 --         package Instance is new G (Formal => Actual);
  56 --
  57 --      In the instance, the copy of P at (1) overrides Actual's P, since it
  58 --      is declared in the visible part of the instance. The copy of Q at (2)
  59 --      does not override anything. The copy of R at (3) overrides Actual's
  60 --      R, even though it is declared in the private part, because within
  61 --      the generic the explicit declaration of R overrides an implicit
  62 --      declaration.
  63 --
  64 --      Thus, for calls involving a parameter with tag T:
  65 --         - Calls to P will execute the body declared for T.
  66 --         - Calls to Q from within Instance will execute the body declared
  67 --           for T.
  68 --         - Calls to Q from outside Instance will execute the body declared
  69 --           for Actual.
  70 --         - Calls to R will execute the body declared for T.
  71 --
  72 --      Verify this behavior for both dispatching and nondispatching calls to
  73 --      Q and R.
  74 --
  75 --
  76 -- CHANGE HISTORY:
  77 --      24 Feb 95   SAIC    Initial prerelease version.
  78 --
  79 --!
  80
  81 package CC30002_0 is
  82
  83    type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance,
  84                          Body_Of_Actual,   Initial_Value);
  85
  86    type Camera is tagged record
  87       -- ... Camera components.
  88       TC_Focus_Called   : TC_Body_Kind := Initial_Value;
  89       TC_Shutter_Called : TC_Body_Kind := Initial_Value;
  90    end record;
  91
  92    procedure Focus (C: in out Camera);
  93
  94    -- ...Other operations.
  95
  96 end CC30002_0;
  97
  98
  99      --==================================================================--
 100
 101
 102 package body CC30002_0 is
 103
 104    procedure Focus (C: in out Camera) is
 105    begin
 106       -- Artificial for testing purposes.
 107       C.TC_Focus_Called := Body_Of_Ancestor;
 108    end Focus;
 109
 110 end CC30002_0;
 111
 112
 113      --==================================================================--
 114
 115
 116 with CC30002_0;
 117 use  CC30002_0;
 118 generic
 119    type Camera_Type is new CC30002_0.Camera with private;
 120 package CC30002_1 is
 121
 122    type Speed_Camera is new Camera_Type with record
 123       Diag_Code: Positive;
 124       -- ...Other components.
 125    end record;
 126
 127    -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic.
 128    procedure Self_Test_NonDisp (C: in out Speed_Camera);
 129    procedure Self_Test_Disp    (C: in out Speed_Camera'Class);
 130
 131 private
 132
 133    -- The following explicit declaration of Set_Shutter_Speed does NOT override
 134    -- a corresponding implicit declaration in the generic. Therefore, its copy
 135    -- does NOT override the implicit declaration (inherited from the actual)
 136    -- in the instance.
 137
 138    procedure Set_Shutter_Speed (C: in out Speed_Camera);
 139
 140    -- The following explicit declaration of Focus DOES override a
 141    -- corresponding implicit declaration (inherited from the parent) in the
 142    -- generic. Therefore, its copy overrides the implicit declaration
 143    -- (inherited from the actual) in the instance.
 144
 145    procedure Focus (C: in out Speed_Camera);  -- Overrides implicit Focus
 146                                               -- in generic.
 147 end CC30002_1;
 148
 149
 150      --==================================================================--
 151
 152
 153 package body CC30002_1 is
 154
 155    procedure Self_Test_NonDisp (C: in out Speed_Camera) is
 156    begin
 157       -- Nondispatching calls:
 158       Focus (C);
 159       Set_Shutter_Speed (C);
 160    end Self_Test_NonDisp;
 161
 162    procedure Self_Test_Disp (C: in out Speed_Camera'Class) is
 163    begin
 164       -- Dispatching calls:
 165       Focus (C);
 166       Set_Shutter_Speed (C);
 167    end Self_Test_Disp;
 168
 169    procedure Set_Shutter_Speed (C: in out Speed_Camera) is
 170    begin
 171       -- Artificial for testing purposes.
 172       C.TC_Shutter_Called := Body_In_Instance;
 173    end Set_Shutter_Speed;
 174
 175    procedure Focus (C: in out Speed_Camera) is
 176    begin
 177       -- Artificial for testing purposes.
 178       C.TC_Focus_Called := Body_In_Instance;
 179    end Focus;
 180
 181 end CC30002_1;
 182
 183
 184      --==================================================================--
 185
 186
 187 with CC30002_0;
 188 package CC30002_2 is
 189
 190    type Aperture_Camera is new CC30002_0.Camera with record
 191       FStop: Natural;
 192       -- ...Other components.
 193    end record;
 194
 195    procedure Set_Shutter_Speed (C: in out Aperture_Camera);
 196    procedure Focus (C: in out Aperture_Camera);
 197
 198 end CC30002_2;
 199
 200
 201      --==================================================================--
 202
 203
 204 package body CC30002_2 is
 205
 206    procedure Set_Shutter_Speed (C: in out Aperture_Camera) is
 207       use CC30002_0;
 208    begin
 209       -- Artificial for testing purposes.
 210       C.TC_Shutter_Called := Body_Of_Actual;
 211    end Set_Shutter_Speed;
 212
 213    procedure Focus (C: in out Aperture_Camera) is
 214       use CC30002_0;
 215    begin
 216       -- Artificial for testing purposes.
 217       C.TC_Focus_Called := Body_Of_Actual;
 218    end Focus;
 219
 220 end CC30002_2;
 221
 222
 223      --==================================================================--
 224
 225
 226 -- Instance declaration.
 227
 228 with CC30002_1;
 229 with CC30002_2;
 230 package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera);
 231
 232
 233      --==================================================================--
 234
 235
 236 with CC30002_0;
 237 with CC30002_1;
 238 with CC30002_2;
 239 with CC30002_3; -- Instance.
 240
 241 with Report;
 242 procedure CC30002 is
 243
 244    package Speed_Cameras renames CC30002_3;
 245
 246    use CC30002_0;
 247
 248    TC_Camera1: Speed_Cameras.Speed_Camera;
 249    TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1;
 250    TC_Camera3: Speed_Cameras.Speed_Camera;
 251    TC_Camera4: Speed_Cameras.Speed_Camera;
 252
 253 begin
 254    Report.Test ("CC30002", "Check that an explicit declaration in the "      &
 255                 "private part of an instance does not override an implicit " &
 256                 "declaration in the instance, unless the corresponding "     &
 257                 "explicit declaration in the generic overrides a "           &
 258                 "corresponding implicit declaration in the generic. Check "  &
 259                 "for primitive subprograms of tagged types");
 260
 261 --
 262 -- Check non-dispatching calls outside instance:
 263 --
 264
 265    -- Non-overriding primitive operation:
 266
 267    Speed_Cameras.Set_Shutter_Speed (TC_Camera1);
 268    if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then
 269       Report.Failed ("Wrong body executed: non-dispatching call to " &
 270                      "Set_Shutter_Speed outside instance");
 271    end if;
 272
 273
 274    -- Overriding primitive operation:
 275
 276    Speed_Cameras.Focus (TC_Camera1);
 277    if TC_Camera1.TC_Focus_Called /= Body_In_Instance then
 278       Report.Failed ("Wrong body executed: non-dispatching call to " &
 279                      "Focus outside instance");
 280    end if;
 281
 282
 283 --
 284 -- Check dispatching calls outside instance:
 285 --
 286
 287    -- Non-overriding primitive operation:
 288
 289    Speed_Cameras.Set_Shutter_Speed (TC_Camera2);
 290    if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then
 291       Report.Failed ("Wrong body executed: dispatching call to " &
 292                      "Set_Shutter_Speed outside instance");
 293    end if;
 294
 295
 296    -- Overriding primitive operation:
 297
 298    Speed_Cameras.Focus (TC_Camera2);
 299    if TC_Camera2.TC_Focus_Called /= Body_In_Instance then
 300       Report.Failed ("Wrong body executed: dispatching call to " &
 301                      "Focus outside instance");
 302    end if;
 303
 304
 305
 306 --
 307 -- Check non-dispatching calls within instance:
 308 --
 309
 310    Speed_Cameras.Self_Test_NonDisp (TC_Camera3);
 311
 312    -- Non-overriding primitive operation:
 313
 314    if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then
 315       Report.Failed ("Wrong body executed: non-dispatching call to " &
 316                      "Set_Shutter_Speed inside instance");
 317    end if;
 318
 319    -- Overriding primitive operation:
 320
 321    if TC_Camera3.TC_Focus_Called /= Body_In_Instance then
 322       Report.Failed ("Wrong body executed: non-dispatching call to " &
 323                      "Focus inside instance");
 324    end if;
 325
 326
 327
 328 --
 329 -- Check dispatching calls within instance:
 330 --
 331
 332    Speed_Cameras.Self_Test_Disp (TC_Camera4);
 333
 334    -- Non-overriding primitive operation:
 335
 336    if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then
 337       Report.Failed ("Wrong body executed: dispatching call to " &
 338                      "Set_Shutter_Speed inside instance");
 339    end if;
 340
 341    -- Overriding primitive operation:
 342
 343    if TC_Camera4.TC_Focus_Called /= Body_In_Instance then
 344       Report.Failed ("Wrong body executed: dispatching call to " &
 345                      "Focus inside instance");
 346    end if;
 347
 348    Report.Result;
 349 end CC30002;