-- C392D02.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that a primitive procedure declared in a private part is not
--      overridden by a procedure explicitly declared at a place where the
--      primitive procedure in question is not visible.
--
--      Check for the case where the non-overriding operation is declared in a
--      separate (non-child) package from that declaring the parent type, and
--      the descendant type is a record extension.
--
-- TEST DESCRIPTION:
--      Consider:
--
--      package P is
--         type Root is tagged ...
--      private
--         procedure Pri_Op (A: Root);
--      end P;
--
--      with P;
--      package Q is
--         type Derived is new P.Root with record...
--         procedure Pri_Op (A: Derived);  -- Does NOT override parent's Op.
--         ...
--      end Q;
--
--      Type Derived inherits Pri_Op from the parent type Root. However,
--      because P.Pri_Op is never visible within the immediate scope of
--      Derived, it is not implicitly declared for Derived. As a result,
--      the explicit Q.Pri_Op does not override P.Pri_Op and is totally
--      unrelated to it.
--
--      Dispatching calls to P.Pri_Op with operands of tag Derived will
--      not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op.
--
-- TEST FILES:
--      The following files comprise this test:
--
--         F392D00.A
--         C392D02.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

with F392D00;
package C392D02_0 is

   type Aperture is (Eight, Sixteen);     

   type Auto_Speed is new F392D00.Remote_Camera with record
      -- ...
      FStop : Aperture;
   end record;


   procedure Set_Shutter_Speed (C     : in out Auto_Speed;     
                                Speed : in     F392D00.Shutter_Speed); 
                                                   -- Does NOT override.

   -- This version of Set_Shutter_Speed does NOT override the operation
   -- inherited from the parent, because the inherited operation is never
   -- visible (and thus, is never implicitly declared) within the immediate
   -- scope of type Auto_Speed.

   procedure Self_Test (C : in out Auto_Speed'Class);

   -- ...Other operations.

end C392D02_0;


     --==================================================================--


package body C392D02_0 is

   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
                                Speed : in     F392D00.Shutter_Speed) is
   begin
      -- Artificial for testing purposes.
      C.Shutter := F392D00.Four_Hundred;
   end Set_Shutter_Speed;

   ----------------------------------------------------
   procedure Self_Test (C : in out Auto_Speed'Class) is
   begin
      -- Should dispatch to the Set_Shutter_Speed explicitly declared
      -- for Auto_Speed.
      Set_Shutter_Speed (C, F392D00.Two_Fifty);
   end Self_Test;

end C392D02_0;


     --==================================================================--


with F392D00;
with C392D02_0;

with Report;

procedure C392D02 is
   Basic_Camera : F392D00.Remote_Camera;
   Auto_Camera1 : C392D02_0.Auto_Speed;
   Auto_Camera2 : C392D02_0.Auto_Speed;

   TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed 
                           := F392D00.Thousand;
   TC_Expected_Speed       : constant F392D00.Shutter_Speed 
                           := F392D00.Four_Hundred;

   use type F392D00.Shutter_Speed;

begin
   Report.Test ("C392D02", "Dispatching for non-overridden primitive " &
                "subprograms: record extension declared in non-child " &
                "package, parent is tagged record");

-- Call the class-wide operation for Remote_Camera'Class, which dispatches
-- to Set_Shutter_Speed:

   -- For an object of type Remote_Camera, the dispatching call should
   -- dispatch to the body declared for the root type:
     
   F392D00.Self_Test(Basic_Camera);

   if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then
      Report.Failed ("Call dispatched incorrectly for root type");
   end if;


   -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test,
   -- since C392D02_0.Set_Shutter_Speed does not override
   -- F392D00.Set_Shutter_Speed.

   -- For an object of type Auto_Speed, the dispatching call should
   -- also dispatch to the body declared for the root type:
     
   F392D00.Self_Test(Auto_Camera1);

   if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then
      Report.Failed ("Call dispatched incorrectly for derived type");
   end if;

   -- Call to Self_Test from C392D02_0 invokes the dispatching call to
   -- Set_Shutter_Speed which should dispatch to the body explicitly declared 
   -- for Auto_Speed:

   C392D02_0.Self_Test(Auto_Camera2);

   if Auto_Camera2.Shutter /= TC_Expected_Speed then
      Report.Failed ("Call to explicit subprogram executed the wrong body");
   end if;

   Report.Result;

end C392D02;