gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c392d03.a

   1 -- C392D03.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 inherited dispatching operation that is overridden,
  28 --      the body executed is the body of the overriding subprogram, even if
  29 --      the overriding occurs in a private part.
  30 --
  31 --      Check for the case where the overriding operation is declared in a
  32 --      separate (non-child) package from that declaring the parent type, and
  33 --      the descendant type is a record extension.
  34 --
  35 --      Check for both dispatching and nondispatching calls.
  36 --
  37 -- TEST DESCRIPTION:
  38 --      Consider:
  39 --
  40 --      package P is
  41 --         type Root is tagged ...
  42 --         procedure Op (A: Root);
  43 --      end P;
  44 --
  45 --      with P;
  46 --      package Q is
  47 --         type Derived1 is new P.Root with record...
  48 --         -- Implicit procedure Op (A: Derived1) declared here.
  49 --         type Derived2 is new P.Root with private...
  50 --         -- Implicit procedure Op (A: Derived2) declared here.
  51 --         type New_Derived is new Derived1 with private...
  52 --         -- Implicit procedure Op (A: New_Derived) declared here.
  53 --      private
  54 --         procedure Op (A: Derived1);  -- Overrides parent's Op.
  55 --         type Derived2 is new P.Root with record...
  56 --         procedure Op (A: Derived2);  -- Overrides parent's Op.
  57 --         type New_Derived is new Derived1 with record...
  58 --         ...
  59 --      end Q;
  60 --
  61 --      Both type Derived1 and Derived2 inherit Op from the parent type Root.
  62 --      Type New_Derived inherits (inherited) Op from Derived1.  The inherited
  63 --      operation is implicitly declared immediately after the type extension.
  64 --      The inherited operation is overridden by an explicit declaration in
  65 --      the private part. Even though the overriding operation is private,
  66 --      calls to Op with an operand of tag Derived1, Derived2, or New_Derived
  67 --      will execute the body of the overriding operation.
  68 --
  69 -- TEST FILES:
  70 --      The following files comprise this test:
  71 --
  72 --         F392D00.A
  73 --         C392D03.A
  74 --
  75 --
  76 -- CHANGE HISTORY:
  77 --      06 Dec 94   SAIC    ACVC 2.0
  78 --
  79 --!
  80
  81 with F392D00;
  82 package C392D03_0 is
  83
  84    type Aperture is (Eight, Sixteen);
  85
  86    type Auto_Focus is new F392D00.Remote_Camera with record
  87       -- ...
  88       FStop : Aperture;
  89    end record;
  90
  91    -- Implicit procedure Focus (C     : in out Auto_Focus;
  92    --                           Depth : in     Depth_Of_Field) declared here.
  93
  94    type Auto_Flashing is new F392D00.Remote_Camera with private;
  95
  96    -- Implicit procedure Focus (C     : in out Auto_Flashing;
  97    --                           Depth : in     Depth_Of_Field) declared here.
  98
  99    type Special_Focus is new Auto_Focus with private;
 100
 101    -- Implicit procedure Focus (C     : in out Special_Focus;
 102    --                           Depth : in     Depth_Of_Field) declared here.
 103
 104    -- ...Other operations.
 105
 106 private
 107
 108    procedure Focus (C     : in out Auto_Focus;              -- Overrides
 109                     Depth : in     F392D00.Depth_Of_Field); -- parent's op.
 110
 111    -- For the improved remote camera, focus is set automatically, so it is
 112    -- declared as a private operation.
 113
 114    type Auto_Flashing is new F392D00.Remote_Camera with null record;
 115
 116    procedure Focus (C     : in out Auto_Flashing;           -- Overrides
 117                     Depth : in     F392D00.Depth_Of_Field); -- parent's op.
 118
 119    type Special_Focus is new Auto_Focus with null record;
 120
 121 end C392D03_0;
 122
 123
 124      --==================================================================--
 125
 126
 127 package body C392D03_0 is
 128
 129    procedure Focus (C     : in out Auto_Focus;
 130                     Depth : in     F392D00.Depth_Of_Field) is
 131    begin
 132       -- Artificial for testing purposes.
 133       C.DOF := 52;
 134    end Focus;
 135
 136    -----------------------------------------------------------
 137    procedure Focus (C     : in out Auto_Flashing;
 138                     Depth : in     F392D00.Depth_Of_Field) is
 139    begin
 140       -- Artificial for testing purposes.
 141       C.DOF := 91;
 142    end Focus;
 143
 144 end C392D03_0;
 145
 146
 147      --==================================================================--
 148
 149
 150 with F392D00;
 151 with C392D03_0;
 152
 153 with Report;
 154
 155 procedure C392D03 is
 156
 157    type Focus_Ptr is access procedure
 158      (P1 : in out C392D03_0.Auto_Focus;
 159       P2 : in F392D00.Depth_Of_Field);
 160
 161    Basic_Camera   : F392D00.Remote_Camera;
 162    Auto_Camera1   : C392D03_0.Auto_Focus;
 163    Auto_Camera2   : C392D03_0.Auto_Focus;
 164    Flash_Camera1  : C392D03_0.Auto_Flashing;
 165    Flash_Camera2  : C392D03_0.Auto_Flashing;
 166    Special_Camera : C392D03_0.Special_Focus;
 167    Auto_Depth     : F392D00.Depth_Of_Field := 78;
 168
 169    TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
 170    TC_Expected_Auto_Depth  : constant F392D00.Depth_Of_Field := 52;
 171    TC_Expected_Depth       : constant F392D00.Depth_Of_Field := 91;
 172
 173    FP : Focus_Ptr := C392D03_0.Focus'Access;
 174
 175    use type F392D00.Depth_Of_Field;
 176
 177 begin
 178    Report.Test ("C392D03", "Dispatching for overridden primitive " &
 179                 "subprograms: record extension declared in non-child " &
 180                 "package, parent is tagged record");
 181
 182
 183 -- Call the class-wide operation for Remote_Camera'Class, which itself makes
 184 -- a dispatching call to Focus:
 185
 186    -- For an object of type Remote_Camera, the dispatching call should
 187    -- dispatch to the body declared for the root type:
 188
 189    F392D00.Self_Test(Basic_Camera);
 190
 191    if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
 192       Report.Failed ("Call dispatched incorrectly for root type");
 193    end if;
 194
 195
 196    -- For an object of type Auto_Focus, the dispatching call should
 197    -- dispatch to the body declared for the derived type:
 198
 199    F392D00.Self_Test(Auto_Camera1);
 200
 201    if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
 202       Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
 203    end if;
 204
 205
 206    -- For an object of type Auto_Flash, the dispatching call should
 207    -- also dispatch to the body declared for the derived type:
 208
 209    F392D00.Self_Test(Flash_Camera1);
 210
 211    if Flash_Camera1.DOF /= TC_Expected_Depth then
 212       Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
 213    end if;
 214
 215    -- For an object of Auto_Flash type, a non-dispatching call to Focus should
 216    -- execute the body declared for the derived type (even through it is
 217    -- declared in the private part).
 218
 219    C392D03_0.Focus (Flash_Camera2, Auto_Depth);
 220
 221    if Flash_Camera2.DOF /= TC_Expected_Depth then
 222       Report.Failed ("Non-dispatching call to privately overriding " &
 223                      "subprogram executed the wrong body");
 224    end if;
 225
 226    -- For an object of Auto_Focus type, a non-dispatching call to Focus should
 227    -- execute the body declared for the derived type (even through it is
 228    -- declared in the private part).
 229
 230    FP.all (Auto_Camera2, Auto_Depth);
 231
 232    if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
 233       Report.Failed ("Non-dispatching call by using access to overriding " &
 234                      "subprogram executed the wrong body");
 235    end if;
 236
 237    -- For an object of type Special_Camera, the dispatching call should
 238    -- also dispatch to the body declared for the derived type:
 239
 240    F392D00.Self_Test(Special_Camera);
 241
 242    if Special_Camera.DOF /= TC_Expected_Auto_Depth then
 243       Report.Failed ("Call dispatched incorrectly for Special_Camera type");
 244    end if;
 245
 246    Report.Result;
 247
 248 end C392D03;