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

   1 -- C392D01.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 --      Check that, for an implicitly declared dispatching operation that is
  31 --      NOT overridden, the body executed is the body of the corresponding
  32 --      subprogram of the parent type.
  33 --
  34 --      Check for the case where the overriding (and non-overriding) operations
  35 --      are declared for a private extension (and its full type) in a public
  36 --      child unit of the package declaring the ancestor type, and the ancestor
  37 --      type is a tagged private type whose full view is itself a derived type.
  38 --
  39 -- TEST DESCRIPTION:
  40 --      Consider:
  41 --
  42 --      package Parent is
  43 --         type Root is tagged ...
  44 --         procedure Vis_Op (P: Root);
  45 --      private
  46 --         procedure Pri_Op (P: Root);                     -- (A)
  47 --      end Parent;
  48 --
  49 --      package Intermediate is
  50 --         type Mid is tagged private;
  51 --      private
  52 --         type Mid is new Parent.Root with record ...
  53 --         -- Implicit Vis_Op (P: Mid) declared here.
  54 --
  55 --         procedure Vis_Op (P: Mid);                      -- (B)
  56 --      end Intermediate;
  57 --
  58 --      package Intermediate.Child is
  59 --         type Derived is new Mid with private;
  60 --
  61 --         procedure Pri_Op (P: Derived);                  -- (C)
  62 --         ...
  63 --
  64 --      private
  65 --         type Derived is new Mid with record...
  66 --         -- Implicit Vis_Op (P: Derived) declared here.
  67 --         ...
  68 --      end Intermediate.Child;
  69 --
  70 --      Type Derived inherits Vis_Op from the parent type Mid. Note, however,
  71 --      that it is implicitly declared in the private part (inherited
  72 --      subprograms for a derived_type_definition -- in this case, the full
  73 --      type -- are implicitly declared at the  earliest place within the
  74 --      immediate scope of the type_declaration where the corresponding
  75 --      declaration from the parent is visible).
  76 --
  77 --      Because Parent.Pri_Op is never visible within the immediate scope
  78 --      of Mid, it is not implicitly declared for Mid. Thus, it is also not
  79 --      implicitly declared for Derived. As a result, the version of Pri_Op
  80 --      declared at (C) above does not override an inherited version of
  81 --      Parent.Pri_Op and is totally unrelated to it.
  82 --
  83 --      Dispatching calls with tag Mid will execute (A) and (B). Dispatching
  84 --      calls with tag Derived from Parent will execute the bodies of (B)
  85 --      and (A).  Dispatching calls with tag Derived from Parent.Child
  86 --      will execute the bodies of (B) and (C).
  87 --
  88 -- TEST FILES:
  89 --      The following files comprise this test:
  90 --
  91 --         F392D00.A
  92 --         C392D01.A
  93 --
  94 --
  95 -- CHANGE HISTORY:
  96 --      06 Dec 94   SAIC    ACVC 2.0
  97 --
  98 --!
  99
 100 with F392D00;
 101 package C392D01_0 is
 102
 103    type Zoom_Camera is tagged private;
 104
 105    procedure Self_Test (C : in out Zoom_Camera'Class);
 106
 107    -- ...Additional operations.
 108
 109
 110    function TC_Correct_Result (C : Zoom_Camera;
 111                                D : F392D00.Depth_Of_Field;
 112                                S : F392D00.Shutter_Speed) return Boolean;
 113
 114 private
 115
 116    type Magnification is (Low, Medium, High);
 117
 118    type Zoom_Camera is new F392D00.Remote_Camera with record
 119       Mag : Magnification;
 120    end record;
 121
 122    -- procedure Focus (C     : in out Zoom_Camera;               -- Implicitly
 123    --                  Depth : in     Depth_Of_Field)            -- declared
 124                                                                  -- here.
 125
 126    procedure Focus (C     : in out Zoom_Camera;                -- Overrides
 127                     Depth : in     F392D00.Depth_Of_Field);    -- inherited op.
 128
 129    -- For the remote zoom camera, perhaps the focusing algorithm is different
 130    -- in some way, so the original Focus operation is overridden here.
 131
 132    -- Since the partial view is not an extension, the overriding operation
 133    -- must be declared after the full type. This version of Focus, although
 134    -- not visible for type Zoom_Camera from outside the package, can still be
 135    -- dispatched to.
 136
 137
 138    -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from
 139    -- F392D00.Remote_Camera, but since the operation never becomes visible
 140    -- within the immediate scope of Zoom_Camera, it is never implicitly
 141    -- declared.
 142
 143 end C392D01_0;
 144
 145
 146      --==================================================================--
 147
 148
 149 package body C392D01_0 is
 150
 151    procedure Focus (C     : in out Zoom_Camera;
 152                     Depth : in     F392D00.Depth_Of_Field) is
 153    begin
 154       -- Artificial for testing purposes.
 155       C.DOF := 83;
 156    end Focus;
 157
 158    -----------------------------------------------------------
 159    -- Indirect call to F392D00.Self_Test since the main does not know
 160    -- that Zoom_Camera is a private extension of F392D00.Basic_Camera.
 161    procedure Self_Test (C : in out Zoom_Camera'Class) is
 162    begin
 163       F392D00.Self_Test (C);
 164       -- ...Additional self-testing.
 165    end Self_Test;
 166
 167    -----------------------------------------------------------
 168    function TC_Correct_Result (C : Zoom_Camera;
 169                                D : F392D00.Depth_Of_Field;
 170                                S : F392D00.Shutter_Speed) return Boolean is
 171       use type F392D00.Depth_Of_Field;
 172       use type F392D00.Shutter_Speed;
 173    begin
 174       return (C.DOF = D and C.Shutter = S);
 175    end TC_Correct_Result;
 176
 177 end C392D01_0;
 178
 179
 180      --==================================================================--
 181
 182
 183 with F392D00;
 184 package C392D01_0.C392D01_1 is
 185
 186    type Film_Speed is private;
 187
 188    type Auto_Speed is new Zoom_Camera with private;
 189
 190    -- Implicit function TC_Correct_Result (Auto_Speed) declared here.
 191
 192    procedure Set_Shutter_Speed (C     : in out Auto_Speed;
 193                                 Speed : in     F392D00.Shutter_Speed);
 194
 195    -- This version of Set_Shutter_Speed does NOT override the operation
 196    -- inherited from Zoom_Camera, because the inherited operation is never
 197    -- visible (and thus, is never implicitly declared) within the immediate
 198    -- scope of type Auto_Speed.
 199
 200    procedure Self_Test (C : in out Auto_Speed'Class);
 201
 202    -- ...Other operations.
 203
 204 private
 205    type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
 206
 207    type Auto_Speed is new Zoom_Camera with record
 208       ASA : Film_Speed;
 209    end record;
 210
 211    -- procedure Focus (C     : in out Auto_Speed;                -- Implicitly
 212    --                  Depth : in     F392D00.Depth_Of_Field);   -- declared
 213                                                                  -- here.
 214
 215 end C392D01_0.C392D01_1;
 216
 217
 218      --==================================================================--
 219
 220
 221 package body C392D01_0.C392D01_1 is
 222
 223    procedure Set_Shutter_Speed (C     : in out Auto_Speed;
 224                                 Speed : in     F392D00.Shutter_Speed) is
 225    begin
 226       -- Artificial for testing purposes.
 227       C.Shutter := F392D00.Two_Fifty;
 228    end Set_Shutter_Speed;
 229
 230    -------------------------------------------------------
 231    procedure Self_Test (C : in out Auto_Speed'Class) is
 232    begin
 233       -- Artificial for testing purposes.
 234       Set_Shutter_Speed (C, F392D00.Thousand);
 235       Focus (C, 27);
 236    end Self_Test;
 237
 238 end C392D01_0.C392D01_1;
 239
 240
 241      --==================================================================--
 242
 243
 244 with F392D00;
 245 with C392D01_0.C392D01_1;
 246
 247 with Report;
 248
 249 procedure C392D01 is
 250    Zooming_Camera : C392D01_0.Zoom_Camera;
 251    Auto_Camera1   : C392D01_0.C392D01_1.Auto_Speed;
 252    Auto_Camera2   : C392D01_0.C392D01_1.Auto_Speed;
 253
 254    TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83;
 255    TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83;
 256    TC_Expected_Depth      : constant F392D00.Depth_Of_Field := 83;
 257    TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed
 258                           := F392D00.Thousand;
 259    TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed
 260                           := F392D00.Thousand;
 261    TC_Expected_Speed      : constant F392D00.Shutter_Speed
 262                           := F392D00.Two_Fifty;
 263
 264    use type F392D00.Depth_Of_Field;
 265    use type F392D00.Shutter_Speed;
 266
 267 begin
 268    Report.Test ("C392D01", "Dispatching for overridden and non-overridden "   &
 269                 "primitive subprograms: private extension declared in child " &
 270                 "unit, parent is tagged private whose full view is derived  " &
 271                 "type");
 272
 273
 274
 275 -- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which
 276 -- itself calls the class-wide operation for Remote_Camera'Class, which
 277 -- in turn makes dispatching calls to Focus and Set_Shutter_Speed:
 278
 279
 280    -- For an object of type Zoom_Camera, the dispatching call to Focus should
 281    -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
 282    -- to Set_Shutter_Speed should dispatch to the body declared for
 283    -- Remote_Camera:
 284
 285    C392D01_0.Self_Test(Zooming_Camera);
 286
 287    if not C392D01_0.TC_Correct_Result (Zooming_Camera,
 288                                        TC_Expected_Zoom_Depth,
 289                                        TC_Expected_Zoom_Speed)
 290    then
 291       Report.Failed ("Calls dispatched incorrectly for tagged private type");
 292    end if;
 293
 294    -- For an object of type Auto_Speed, the dispatching call to Focus should
 295    -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
 296    -- call to Set_Shutter_Speed should dispatch to the body explicitly declared
 297    -- for Remote_Camera:
 298
 299    C392D01_0.Self_Test(Auto_Camera1);
 300
 301    if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1,
 302                                                  TC_Expected_Auto_Depth,
 303                                                  TC_Expected_Auto_Speed)
 304    then
 305       Report.Failed ("Calls dispatched incorrectly for private extension");
 306    end if;
 307
 308    -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call
 309    -- to Focus which should dispatch to the body explicitly declared for
 310    -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch
 311    -- to the body explicitly declared for Auto_Speed:
 312
 313    C392D01_0.C392D01_1.Self_Test(Auto_Camera2);
 314
 315    if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2,
 316                                                  TC_Expected_Depth,
 317                                                  TC_Expected_Speed)
 318    then
 319       Report.Failed ("Call to explicit subprogram executed the wrong body");
 320    end if;
 321
 322    Report.Result;
 323
 324 end C392D01;