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

   1 -- C392D02.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 a primitive procedure declared in a private part is not
  28 --      overridden by a procedure explicitly declared at a place where the
  29 --      primitive procedure in question is not visible.
  30 --
  31 --      Check for the case where the non-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 -- TEST DESCRIPTION:
  36 --      Consider:
  37 --
  38 --      package P is
  39 --         type Root is tagged ...
  40 --      private
  41 --         procedure Pri_Op (A: Root);
  42 --      end P;
  43 --
  44 --      with P;
  45 --      package Q is
  46 --         type Derived is new P.Root with record...
  47 --         procedure Pri_Op (A: Derived);  -- Does NOT override parent's Op.
  48 --         ...
  49 --      end Q;
  50 --
  51 --      Type Derived inherits Pri_Op from the parent type Root. However,
  52 --      because P.Pri_Op is never visible within the immediate scope of
  53 --      Derived, it is not implicitly declared for Derived. As a result,
  54 --      the explicit Q.Pri_Op does not override P.Pri_Op and is totally
  55 --      unrelated to it.
  56 --
  57 --      Dispatching calls to P.Pri_Op with operands of tag Derived will
  58 --      not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op.
  59 --
  60 -- TEST FILES:
  61 --      The following files comprise this test:
  62 --
  63 --         F392D00.A
  64 --         C392D02.A
  65 --
  66 --
  67 -- CHANGE HISTORY:
  68 --      06 Dec 94   SAIC    ACVC 2.0
  69 --
  70 --!
  71
  72 with F392D00;
  73 package C392D02_0 is
  74
  75    type Aperture is (Eight, Sixteen);
  76
  77    type Auto_Speed is new F392D00.Remote_Camera with record
  78       -- ...
  79       FStop : Aperture;
  80    end record;
  81
  82
  83    procedure Set_Shutter_Speed (C     : in out Auto_Speed;
  84                                 Speed : in     F392D00.Shutter_Speed);
  85                                                    -- Does NOT override.
  86
  87    -- This version of Set_Shutter_Speed does NOT override the operation
  88    -- inherited from the parent, because the inherited operation is never
  89    -- visible (and thus, is never implicitly declared) within the immediate
  90    -- scope of type Auto_Speed.
  91
  92    procedure Self_Test (C : in out Auto_Speed'Class);
  93
  94    -- ...Other operations.
  95
  96 end C392D02_0;
  97
  98
  99      --==================================================================--
 100
 101
 102 package body C392D02_0 is
 103
 104    procedure Set_Shutter_Speed (C     : in out Auto_Speed;
 105                                 Speed : in     F392D00.Shutter_Speed) is
 106    begin
 107       -- Artificial for testing purposes.
 108       C.Shutter := F392D00.Four_Hundred;
 109    end Set_Shutter_Speed;
 110
 111    ----------------------------------------------------
 112    procedure Self_Test (C : in out Auto_Speed'Class) is
 113    begin
 114       -- Should dispatch to the Set_Shutter_Speed explicitly declared
 115       -- for Auto_Speed.
 116       Set_Shutter_Speed (C, F392D00.Two_Fifty);
 117    end Self_Test;
 118
 119 end C392D02_0;
 120
 121
 122      --==================================================================--
 123
 124
 125 with F392D00;
 126 with C392D02_0;
 127
 128 with Report;
 129
 130 procedure C392D02 is
 131    Basic_Camera : F392D00.Remote_Camera;
 132    Auto_Camera1 : C392D02_0.Auto_Speed;
 133    Auto_Camera2 : C392D02_0.Auto_Speed;
 134
 135    TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed
 136                            := F392D00.Thousand;
 137    TC_Expected_Speed       : constant F392D00.Shutter_Speed
 138                            := F392D00.Four_Hundred;
 139
 140    use type F392D00.Shutter_Speed;
 141
 142 begin
 143    Report.Test ("C392D02", "Dispatching for non-overridden primitive " &
 144                 "subprograms: record extension declared in non-child " &
 145                 "package, parent is tagged record");
 146
 147 -- Call the class-wide operation for Remote_Camera'Class, which dispatches
 148 -- to Set_Shutter_Speed:
 149
 150    -- For an object of type Remote_Camera, the dispatching call should
 151    -- dispatch to the body declared for the root type:
 152
 153    F392D00.Self_Test(Basic_Camera);
 154
 155    if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then
 156       Report.Failed ("Call dispatched incorrectly for root type");
 157    end if;
 158
 159
 160    -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test,
 161    -- since C392D02_0.Set_Shutter_Speed does not override
 162    -- F392D00.Set_Shutter_Speed.
 163
 164    -- For an object of type Auto_Speed, the dispatching call should
 165    -- also dispatch to the body declared for the root type:
 166
 167    F392D00.Self_Test(Auto_Camera1);
 168
 169    if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then
 170       Report.Failed ("Call dispatched incorrectly for derived type");
 171    end if;
 172
 173    -- Call to Self_Test from C392D02_0 invokes the dispatching call to
 174    -- Set_Shutter_Speed which should dispatch to the body explicitly declared
 175    -- for Auto_Speed:
 176
 177    C392D02_0.Self_Test(Auto_Camera2);
 178
 179    if Auto_Camera2.Shutter /= TC_Expected_Speed then
 180       Report.Failed ("Call to explicit subprogram executed the wrong body");
 181    end if;
 182
 183    Report.Result;
 184
 185 end C392D02;