Subversion Repositories openrisc_me

-- 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;