path: root/gcc/testsuite/ada/acats/tests/cc/cc30002.a

-- CC30002.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 an explicit declaration in the private part of an instance
--      does not override an implicit declaration in the instance, unless the
--	corresponding explicit declaration in the generic overrides a
--      corresponding implicit declaration in the generic. Check for primitive
--      subprograms of tagged types.
--
-- TEST DESCRIPTION:
--      Consider the following:
--
--         type Ancestor is tagged null record;
--         procedure R (X: in Ancestor);
--
--         generic
--            type Formal is new Ancestor with private;
--         package G is
--            type T is new Formal with null record;
--            -- Implicit procedure R (X: in T);
--            procedure P (X: in T);  -- (1)
--         private
--            procedure Q (X: in T);  -- (2)
--            procedure R (X: in T);  -- (3) Overrides implicit R in generic.
--         end G;
--
--         type Actual is new Ancestor with null record;
--         procedure P (X: in Actual);
--         procedure Q (X: in Actual);
--         procedure R (X: in Actual);
--
--         package Instance is new G (Formal => Actual);
--
--      In the instance, the copy of P at (1) overrides Actual's P, since it
--      is declared in the visible part of the instance. The copy of Q at (2)
--      does not override anything. The copy of R at (3) overrides Actual's
--      R, even though it is declared in the private part, because within
--      the generic the explicit declaration of R overrides an implicit
--      declaration.
--
--      Thus, for calls involving a parameter with tag T:
--         - Calls to P will execute the body declared for T.
--         - Calls to Q from within Instance will execute the body declared
--           for T.
--         - Calls to Q from outside Instance will execute the body declared
--           for Actual.
--         - Calls to R will execute the body declared for T.
--
--      Verify this behavior for both dispatching and nondispatching calls to
--      Q and R. 
--
--
-- CHANGE HISTORY:
--      24 Feb 95   SAIC    Initial prerelease version.
--
--!

package CC30002_0 is

   type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance,
                         Body_Of_Actual,   Initial_Value);

   type Camera is tagged record
      -- ... Camera components.
      TC_Focus_Called   : TC_Body_Kind := Initial_Value;
      TC_Shutter_Called : TC_Body_Kind := Initial_Value;
   end record;

   procedure Focus (C: in out Camera);

   -- ...Other operations.

end CC30002_0;


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


package body CC30002_0 is

   procedure Focus (C: in out Camera) is
   begin
      -- Artificial for testing purposes.
      C.TC_Focus_Called := Body_Of_Ancestor;
   end Focus;

end CC30002_0;


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


with CC30002_0;
use  CC30002_0;
generic
   type Camera_Type is new CC30002_0.Camera with private;
package CC30002_1 is

   type Speed_Camera is new Camera_Type with record
      Diag_Code: Positive;
      -- ...Other components.
   end record;

   -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic.
   procedure Self_Test_NonDisp (C: in out Speed_Camera);
   procedure Self_Test_Disp    (C: in out Speed_Camera'Class);

private

   -- The following explicit declaration of Set_Shutter_Speed does NOT override
   -- a corresponding implicit declaration in the generic. Therefore, its copy
   -- does NOT override the implicit declaration (inherited from the actual)
   -- in the instance.

   procedure Set_Shutter_Speed (C: in out Speed_Camera);

   -- The following explicit declaration of Focus DOES override a
   -- corresponding implicit declaration (inherited from the parent) in the
   -- generic. Therefore, its copy overrides the implicit declaration
   -- (inherited from the actual) in the instance.

   procedure Focus (C: in out Speed_Camera);  -- Overrides implicit Focus
                                              -- in generic.
end CC30002_1;


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


package body CC30002_1 is

   procedure Self_Test_NonDisp (C: in out Speed_Camera) is
   begin
      -- Nondispatching calls:
      Focus (C);
      Set_Shutter_Speed (C);
   end Self_Test_NonDisp;

   procedure Self_Test_Disp (C: in out Speed_Camera'Class) is
   begin
      -- Dispatching calls:
      Focus (C);
      Set_Shutter_Speed (C);
   end Self_Test_Disp;

   procedure Set_Shutter_Speed (C: in out Speed_Camera) is
   begin
      -- Artificial for testing purposes.
      C.TC_Shutter_Called := Body_In_Instance;
   end Set_Shutter_Speed;

   procedure Focus (C: in out Speed_Camera) is
   begin
      -- Artificial for testing purposes.
      C.TC_Focus_Called := Body_In_Instance;
   end Focus;

end CC30002_1;


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


with CC30002_0;
package CC30002_2 is

   type Aperture_Camera is new CC30002_0.Camera with record
      FStop: Natural;
      -- ...Other components.
   end record;

   procedure Set_Shutter_Speed (C: in out Aperture_Camera);
   procedure Focus (C: in out Aperture_Camera);

end CC30002_2;


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


package body CC30002_2 is

   procedure Set_Shutter_Speed (C: in out Aperture_Camera) is
      use CC30002_0;
   begin
      -- Artificial for testing purposes.
      C.TC_Shutter_Called := Body_Of_Actual;
   end Set_Shutter_Speed;

   procedure Focus (C: in out Aperture_Camera) is
      use CC30002_0;
   begin
      -- Artificial for testing purposes.
      C.TC_Focus_Called := Body_Of_Actual;
   end Focus;

end CC30002_2;


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


-- Instance declaration.

with CC30002_1;
with CC30002_2;
package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera);


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


with CC30002_0;
with CC30002_1;
with CC30002_2;
with CC30002_3; -- Instance.

with Report;
procedure CC30002 is

   package Speed_Cameras renames CC30002_3;

   use CC30002_0;

   TC_Camera1: Speed_Cameras.Speed_Camera;
   TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1;
   TC_Camera3: Speed_Cameras.Speed_Camera;
   TC_Camera4: Speed_Cameras.Speed_Camera;

begin
   Report.Test ("CC30002", "Check that an explicit declaration in the "      &
                "private part of an instance does not override an implicit " &
                "declaration in the instance, unless the corresponding "     &
                "explicit declaration in the generic overrides a "           &
                "corresponding implicit declaration in the generic. Check "  &
                "for primitive subprograms of tagged types");

--
-- Check non-dispatching calls outside instance:
--

   -- Non-overriding primitive operation:

   Speed_Cameras.Set_Shutter_Speed (TC_Camera1);
   if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then
      Report.Failed ("Wrong body executed: non-dispatching call to " &
                     "Set_Shutter_Speed outside instance");
   end if;


   -- Overriding primitive operation:

   Speed_Cameras.Focus (TC_Camera1);
   if TC_Camera1.TC_Focus_Called /= Body_In_Instance then
      Report.Failed ("Wrong body executed: non-dispatching call to " &
                     "Focus outside instance");
   end if;


--
-- Check dispatching calls outside instance:
--

   -- Non-overriding primitive operation:

   Speed_Cameras.Set_Shutter_Speed (TC_Camera2);
   if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then
      Report.Failed ("Wrong body executed: dispatching call to " &
                     "Set_Shutter_Speed outside instance");
   end if;


   -- Overriding primitive operation:

   Speed_Cameras.Focus (TC_Camera2);
   if TC_Camera2.TC_Focus_Called /= Body_In_Instance then
      Report.Failed ("Wrong body executed: dispatching call to " &
                     "Focus outside instance");
   end if;



--
-- Check non-dispatching calls within instance:
--

   Speed_Cameras.Self_Test_NonDisp (TC_Camera3);

   -- Non-overriding primitive operation:

   if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then
      Report.Failed ("Wrong body executed: non-dispatching call to " &
                     "Set_Shutter_Speed inside instance");
   end if;

   -- Overriding primitive operation:

   if TC_Camera3.TC_Focus_Called /= Body_In_Instance then
      Report.Failed ("Wrong body executed: non-dispatching call to " &
                     "Focus inside instance");
   end if;



--
-- Check dispatching calls within instance:
--

   Speed_Cameras.Self_Test_Disp (TC_Camera4);

   -- Non-overriding primitive operation:

   if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then
      Report.Failed ("Wrong body executed: dispatching call to " &
                     "Set_Shutter_Speed inside instance");
   end if;

   -- Overriding primitive operation:

   if TC_Camera4.TC_Focus_Called /= Body_In_Instance then
      Report.Failed ("Wrong body executed: dispatching call to " &
                     "Focus inside instance");
   end if;

   Report.Result;
end CC30002;