old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c392005.a

   1 -- C392005.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, for an implicitly declared dispatching operation that is
  28 --      overridden, the body executed is the body for the overriding
  29 --      subprogram, even if the overriding occurs in a private part.
  30 --
  31 --      Check for the case where the overriding operations are declared in a
  32 --      public child unit of the package declaring the parent type, and the
  33 --      descendant type is a private extension.
  34 --
  35 --      Check for both dispatching and nondispatching calls.
  36 --
  37 --
  38 -- TEST DESCRIPTION:
  39 --      Consider:
  40 --
  41 --      package Parent is
  42 --         type Root is tagged ...
  43 --         procedure Vis_Op (P: Root);
  44 --      private
  45 --         procedure Pri_Op (P: Root);
  46 --      end Parent;
  47 --
  48 --      package Parent.Child is
  49 --         type Derived is new Root with private;
  50 --         -- Implicit Vis_Op (P: Derived) declared here.
  51 --
  52 --         procedure Pri_Op (P: Derived);                  -- (A)
  53 --         ...
  54 --      private
  55 --         type Derived is new Root with record...
  56 --         -- Implicit Pri_Op (P: Derived) declared here.
  57
  58 --         procedure Vis_Op (P: Derived);                  -- (B)
  59 --         ...
  60 --      end Parent.Child;
  61 --
  62 --      Type Derived inherits both Vis_Op and Pri_Op from the ancestor type
  63 --      Root. Note, however, that Vis_Op is implicitly declared in the visible
  64 --      part, whereas Pri_Op is implicitly declared in the private part
  65 --      (inherited subprograms for a private extension are implicitly declared
  66 --      after the private_extension_declaration if the corresponding
  67 --      declaration from the ancestor is visible at that place; otherwise the
  68 --      inherited subprogram is not declared for the private extension,
  69 --      although it might be for the full type).
  70 --
  71 --      Even though Root's version of Pri_Op hasn't been implicitly declared
  72 --      for Derived at the time Derived's version of Pri_Op has been
  73 --      explicitly declared, the explicit Pri_Op still overrides the implicit
  74 --      version.
  75 --      Also, even though the explicit Vis_Op for Derived is declared in the
  76 --      private part it still overrides the implicit version declared in the
  77 --      visible part. Calls with tag Derived will execute (A) and (B).
  78 --
  79 --
  80 -- CHANGE HISTORY:
  81 --      06 Dec 94   SAIC    ACVC 2.0
  82 --      26 Nov 96   SAIC    Improved for ACVC 2.1
  83 --
  84 --!
  85
  86 package C392005_0 is
  87
  88    type Remote_Camera is tagged private;
  89
  90    type Depth_Of_Field is range 5 .. 100;
  91    type Shutter_Speed  is (One, Two_Fifty, Four_Hundred, Thousand);
  92    type Aperture       is (Eight, Sixteen, Thirty_Two);
  93
  94    -- ...Other declarations.
  95
  96    procedure Focus (Cam   : in out Remote_Camera;
  97                     Depth : in     Depth_Of_Field);
  98
  99    procedure Self_Test (C: in out Remote_Camera'Class);
 100
 101    -- ...Other operations.
 102
 103    function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field;
 104    function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed;
 105
 106 private
 107
 108    type Remote_Camera is tagged record
 109       DOF    : Depth_Of_Field := 10;
 110       Shutter: Shutter_Speed  := One;
 111       FStop  : Aperture       := Eight;
 112    end record;
 113
 114    procedure Set_Shutter_Speed (C     : in out Remote_Camera;
 115                                 Speed : in     Shutter_Speed);
 116
 117    -- For the basic remote camera, shutter speed might be set as a function of
 118    -- focus perhaps, thus it is declared as a private operation (usable
 119    -- only internally within the abstraction).
 120
 121    function Set_Aperture (C : Remote_Camera) return Aperture;
 122
 123 end C392005_0;
 124
 125
 126      --==================================================================--
 127
 128
 129 package body C392005_0 is
 130
 131    procedure Focus (Cam   : in out Remote_Camera;
 132                     Depth : in     Depth_Of_Field) is
 133    begin
 134       -- Artificial for testing purposes.
 135       Cam.DOF := 46;
 136    end Focus;
 137
 138    -----------------------------------------------------------
 139    procedure Set_Shutter_Speed (C     : in out Remote_Camera;
 140                                 Speed : in     Shutter_Speed) is
 141    begin
 142       -- Artificial for testing purposes.
 143       C.Shutter := Thousand;
 144    end Set_Shutter_Speed;
 145
 146    -----------------------------------------------------------
 147    function Set_Aperture (C : Remote_Camera) return Aperture is
 148    begin
 149       -- Artificial for testing purposes.
 150       return Thirty_Two;
 151    end Set_Aperture;
 152
 153    -----------------------------------------------------------
 154    procedure Self_Test (C: in out Remote_Camera'Class) is
 155       TC_Dummy_Depth : constant Depth_Of_Field := 23;
 156       TC_Dummy_Speed : constant Shutter_Speed  := Four_Hundred;
 157    begin
 158
 159       -- Test focus at various depths:
 160       Focus(C, TC_Dummy_Depth);
 161       -- ...Additional calls to Focus.
 162
 163       -- Test various shutter speeds:
 164       Set_Shutter_Speed(C, TC_Dummy_Speed);
 165       -- ...Additional calls to Set_Shutter_Speed.
 166
 167    end Self_Test;
 168
 169    -----------------------------------------------------------
 170    function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is
 171    begin
 172       return C.DOF;
 173    end TC_Get_Depth;
 174
 175    -----------------------------------------------------------
 176    function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is
 177    begin
 178       return C.Shutter;
 179    end TC_Get_Speed;
 180
 181 end C392005_0;
 182
 183      --==================================================================--
 184
 185
 186 package C392005_0.C392005_1 is
 187
 188    type Auto_Speed is new Remote_Camera with private;
 189
 190
 191    -- procedure Focus (C     : in out Auto_Speed;      -- Implicitly declared
 192    --                  Depth : in     Depth_Of_Field)  -- here.
 193
 194    -- For the improved remote camera, shutter speed can be set manually,
 195    -- so it is declared as a public operation.
 196
 197    -- The order of declarations for Set_Aperture and Set_Shutter_Speed are
 198    -- reversed from the original declarations to trap potential compiler
 199    -- problems related to subprogram ordering.
 200
 201    function Set_Aperture (C : Auto_Speed) return Aperture;    -- Overrides
 202                                                               -- inherited op.
 203
 204    procedure Set_Shutter_Speed (C     : in out Auto_Speed;    -- Overrides
 205                                 Speed : in     Shutter_Speed);-- inherited op.
 206
 207    -- Set_Shutter_Speed and Set_Aperture override the operations inherited
 208    -- from the parent, even though the inherited operations are not implicitly
 209    -- declared until the private part below.
 210
 211    type New_Camera is private;
 212
 213    function TC_Get_Aper (C: New_Camera) return Aperture;
 214
 215    -- ...Other operations.
 216
 217 private
 218    type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
 219
 220    type Auto_Speed is new Remote_Camera with record
 221       ASA : Film_Speed;
 222    end record;
 223
 224    -- procedure Set_Shutter_Speed (C     : in out Auto_Speed;    -- Implicitly
 225    --                              Speed : in     Shutter_Speed) -- declared
 226                                                                  -- here.
 227
 228    -- function Set_Aperture (C : Auto_Speed) return Aperture;    -- Implicitly
 229                                                                  -- declared.
 230
 231    procedure Focus (C     : in out Auto_Speed;                -- Overrides
 232                     Depth : in     Depth_Of_Field);           -- inherited op.
 233
 234    -- For the improved remote camera, perhaps the focusing algorithm is
 235    -- different, so the original Focus operation is overridden here.
 236
 237    Auto_Camera : Auto_Speed;
 238
 239    type New_Camera is record
 240       Aper : Aperture := Set_Aperture (Auto_Camera);  -- Calls the overridden,
 241    end record;                                        -- not the inherited op.
 242
 243 end C392005_0.C392005_1;
 244
 245
 246      --==================================================================--
 247
 248
 249 package body C392005_0.C392005_1 is
 250
 251    procedure Focus (C     : in out Auto_Speed;
 252                     Depth : in     Depth_Of_Field) is
 253    begin
 254       -- Artificial for testing purposes.
 255       C.DOF := 57;
 256    end Focus;
 257
 258    ---------------------------------------------------------------
 259    procedure Set_Shutter_Speed (C     : in out Auto_Speed;
 260                                 Speed : in     Shutter_Speed) is
 261    begin
 262       -- Artificial for testing purposes.
 263       C.Shutter := Two_Fifty;
 264    end Set_Shutter_Speed;
 265
 266    -----------------------------------------------------------
 267    function Set_Aperture (C : Auto_Speed) return Aperture is
 268    begin
 269       -- Artificial for testing purposes.
 270       return Sixteen;
 271    end Set_Aperture;
 272
 273    -----------------------------------------------------------
 274    function TC_Get_Aper (C: New_Camera) return Aperture is
 275    begin
 276       return C.Aper;
 277    end TC_Get_Aper;
 278
 279 end C392005_0.C392005_1;
 280
 281
 282      --==================================================================--
 283
 284
 285 with C392005_0.C392005_1;
 286
 287 with Report;
 288
 289 procedure C392005 is
 290    Basic_Camera : C392005_0.Remote_Camera;
 291    Auto_Camera1 : C392005_0.C392005_1.Auto_Speed;
 292    Auto_Camera2 : C392005_0.C392005_1.Auto_Speed;
 293    Auto_Depth   : C392005_0.Depth_Of_Field := 67;
 294    New_Camera1  : C392005_0.C392005_1.New_Camera;
 295    TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46;
 296    TC_Expected_Auto_Depth  : constant C392005_0.Depth_Of_Field := 57;
 297    TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed
 298                            := C392005_0.Thousand;
 299    TC_Expected_Auto_Speed  : constant C392005_0.Shutter_Speed
 300                            := C392005_0.Two_Fifty;
 301    TC_Expected_New_Aper    : constant C392005_0.Aperture
 302                            := C392005_0.Sixteen;
 303
 304    use type C392005_0.Depth_Of_Field;
 305    use type C392005_0.Shutter_Speed;
 306    use type C392005_0.Aperture;
 307
 308 begin
 309    Report.Test ("C392005", "Dispatching for overridden primitive "        &
 310                 "subprograms: private extension declared in child unit, " &
 311                 "parent is tagged private whose full view is tagged record");
 312
 313 -- Call the class-wide operation for Remote_Camera'Class, which itself makes
 314 -- dispatching calls to Focus and Set_Shutter_Speed:
 315
 316
 317    -- For an object of type Remote_Camera, the dispatching calls should
 318    -- dispatch to the bodies declared for the root type:
 319
 320    C392005_0.Self_Test(Basic_Camera);
 321
 322    if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth
 323      or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed
 324    then
 325       Report.Failed ("Calls dispatched incorrectly for root type");
 326    end if;
 327
 328
 329    -- For an object of type Auto_Speed, the dispatching calls should
 330    -- dispatch to the bodies declared for the derived type:
 331
 332    C392005_0.Self_Test(Auto_Camera1);
 333
 334    if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth
 335
 336       or
 337       C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed
 338    then
 339       Report.Failed ("Calls dispatched incorrectly for derived type");
 340    end if;
 341
 342    -- For an object of type Auto_Speed, a non-dispatching call to Focus should
 343
 344    -- execute the body declared for the derived type (even through it is
 345    -- declared in the private part).
 346
 347    C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth);
 348
 349    if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth
 350
 351    then
 352       Report.Failed ("Non-dispatching call to privately overriding " &
 353                      "subprogram executed the wrong body");
 354    end if;
 355
 356    -- For an object of type New_Camera, the initialization using Set_Ap
 357    -- should execute the overridden body, not the inherited one.
 358
 359    if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper
 360    then
 361       Report.Failed ("Non-dispatching call to visible overriding " &
 362                      "subprogram executed the wrong body");
 363    end if;
 364
 365    Report.Result;
 366
 367 end C392005;