path: root/gcc/testsuite/ada/acats/tests/c3/c392d01.a

-- C392D01.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, for an implicitly declared dispatching operation that is
--      overridden, the body executed is the body for the overriding
--      subprogram, even if the overriding occurs in a private part.
--      Check that, for an implicitly declared dispatching operation that is
--      NOT overridden, the body executed is the body of the corresponding
--      subprogram of the parent type.
--
--      Check for the case where the overriding (and non-overriding) operations
--      are declared for a private extension (and its full type) in a public
--      child unit of the package declaring the ancestor type, and the ancestor
--      type is a tagged private type whose full view is itself a derived type.
--
-- TEST DESCRIPTION:
--      Consider:
--
--      package Parent is
--         type Root is tagged ...
--         procedure Vis_Op (P: Root);
--      private
--         procedure Pri_Op (P: Root);                     -- (A)
--      end Parent;
--
--      package Intermediate is
--         type Mid is tagged private;
--      private
--         type Mid is new Parent.Root with record ...
--         -- Implicit Vis_Op (P: Mid) declared here.
--
--         procedure Vis_Op (P: Mid);                      -- (B)
--      end Intermediate;
--
--      package Intermediate.Child is
--         type Derived is new Mid with private; 
--
--         procedure Pri_Op (P: Derived);                  -- (C)
--         ...
--
--      private
--         type Derived is new Mid with record...
--         -- Implicit Vis_Op (P: Derived) declared here.
--         ...
--      end Intermediate.Child;
--
--      Type Derived inherits Vis_Op from the parent type Mid. Note, however,
--      that it is implicitly declared in the private part (inherited
--      subprograms for a derived_type_definition -- in this case, the full
--      type -- are implicitly declared at the  earliest place within the
--      immediate scope of the type_declaration where the corresponding
--      declaration from the parent is visible).
--
--      Because Parent.Pri_Op is never visible within the immediate scope
--      of Mid, it is not implicitly declared for Mid. Thus, it is also not
--      implicitly declared for Derived. As a result, the version of Pri_Op
--      declared at (C) above does not override an inherited version of
--      Parent.Pri_Op and is totally unrelated to it.
--
--      Dispatching calls with tag Mid will execute (A) and (B). Dispatching 
--      calls with tag Derived from Parent will execute the bodies of (B) 
--      and (A).  Dispatching calls with tag Derived from Parent.Child
--      will execute the bodies of (B) and (C).  
--
-- TEST FILES:
--      The following files comprise this test:
--
--         F392D00.A
--         C392D01.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

with F392D00;
package C392D01_0 is

   type Zoom_Camera is tagged private;

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

   -- ...Additional operations.


   function TC_Correct_Result (C : Zoom_Camera;
                               D : F392D00.Depth_Of_Field;
                               S : F392D00.Shutter_Speed) return Boolean;

private

   type Magnification is (Low, Medium, High);

   type Zoom_Camera is new F392D00.Remote_Camera with record
      Mag : Magnification;
   end record;

   -- procedure Focus (C     : in out Zoom_Camera;               -- Implicitly
   --                  Depth : in     Depth_Of_Field)            -- declared
                                                                 -- here.

   procedure Focus (C     : in out Zoom_Camera;                -- Overrides
                    Depth : in     F392D00.Depth_Of_Field);    -- inherited op.

   -- For the remote zoom camera, perhaps the focusing algorithm is different
   -- in some way, so the original Focus operation is overridden here.

   -- Since the partial view is not an extension, the overriding operation
   -- must be declared after the full type. This version of Focus, although
   -- not visible for type Zoom_Camera from outside the package, can still be
   -- dispatched to.  


   -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from
   -- F392D00.Remote_Camera, but since the operation never becomes visible
   -- within the immediate scope of Zoom_Camera, it is never implicitly
   -- declared. 

end C392D01_0;


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


package body C392D01_0 is

   procedure Focus (C     : in out Zoom_Camera;
                    Depth : in     F392D00.Depth_Of_Field) is
   begin
      -- Artificial for testing purposes.
      C.DOF := 83;
   end Focus;

   -----------------------------------------------------------
   -- Indirect call to F392D00.Self_Test since the main does not know 
   -- that Zoom_Camera is a private extension of F392D00.Basic_Camera.
   procedure Self_Test (C : in out Zoom_Camera'Class) is
   begin
      F392D00.Self_Test (C);
      -- ...Additional self-testing.
   end Self_Test;

   -----------------------------------------------------------
   function TC_Correct_Result (C : Zoom_Camera;
                               D : F392D00.Depth_Of_Field;
                               S : F392D00.Shutter_Speed) return Boolean is
      use type F392D00.Depth_Of_Field;
      use type F392D00.Shutter_Speed;
   begin
      return (C.DOF = D and C.Shutter = S);
   end TC_Correct_Result;

end C392D01_0;


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


with F392D00;
package C392D01_0.C392D01_1 is

   type Film_Speed is private;

   type Auto_Speed is new Zoom_Camera with private;

   -- Implicit function TC_Correct_Result (Auto_Speed) declared here.

   procedure Set_Shutter_Speed (C     : in out Auto_Speed;     
                                Speed : in     F392D00.Shutter_Speed); 

   -- This version of Set_Shutter_Speed does NOT override the operation
   -- inherited from Zoom_Camera, 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.

private
   type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);

   type Auto_Speed is new Zoom_Camera with record
      ASA : Film_Speed;
   end record;

   -- procedure Focus (C     : in out Auto_Speed;                -- Implicitly
   --                  Depth : in     F392D00.Depth_Of_Field);   -- declared
                                                                 -- here.

end C392D01_0.C392D01_1;


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


package body C392D01_0.C392D01_1 is

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

   -------------------------------------------------------
   procedure Self_Test (C : in out Auto_Speed'Class) is
   begin
      -- Artificial for testing purposes.
      Set_Shutter_Speed (C, F392D00.Thousand);
      Focus (C, 27);
   end Self_Test;

end C392D01_0.C392D01_1;


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


with F392D00;
with C392D01_0.C392D01_1;

with Report;

procedure C392D01 is
   Zooming_Camera : C392D01_0.Zoom_Camera;
   Auto_Camera1   : C392D01_0.C392D01_1.Auto_Speed;
   Auto_Camera2   : C392D01_0.C392D01_1.Auto_Speed;

   TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83;
   TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83;
   TC_Expected_Depth      : constant F392D00.Depth_Of_Field := 83;
   TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed 
                          := F392D00.Thousand;
   TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed 
                          := F392D00.Thousand;
   TC_Expected_Speed      : constant F392D00.Shutter_Speed 
                          := F392D00.Two_Fifty;

   use type F392D00.Depth_Of_Field;
   use type F392D00.Shutter_Speed;

begin
   Report.Test ("C392D01", "Dispatching for overridden and non-overridden "   &
                "primitive subprograms: private extension declared in child " &
                "unit, parent is tagged private whose full view is derived  " &
                "type");



-- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which 
-- itself calls the class-wide operation for Remote_Camera'Class, which
-- in turn makes dispatching calls to Focus and Set_Shutter_Speed:


   -- For an object of type Zoom_Camera, the dispatching call to Focus should
   -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
   -- to Set_Shutter_Speed should dispatch to the body declared for
   -- Remote_Camera:
     
   C392D01_0.Self_Test(Zooming_Camera);

   if not C392D01_0.TC_Correct_Result (Zooming_Camera,
                                       TC_Expected_Zoom_Depth,
                                       TC_Expected_Zoom_Speed)
   then
      Report.Failed ("Calls dispatched incorrectly for tagged private type");
   end if;

   -- For an object of type Auto_Speed, the dispatching call to Focus should
   -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
   -- call to Set_Shutter_Speed should dispatch to the body explicitly declared 
   -- for Remote_Camera:
     
   C392D01_0.Self_Test(Auto_Camera1);

   if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1,
                                                 TC_Expected_Auto_Depth,
                                                 TC_Expected_Auto_Speed)
   then
      Report.Failed ("Calls dispatched incorrectly for private extension");
   end if;

   -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call
   -- to Focus which should dispatch to the body explicitly declared for 
   -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch 
   -- to the body explicitly declared for Auto_Speed:

   C392D01_0.C392D01_1.Self_Test(Auto_Camera2);

   if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2,
                                                 TC_Expected_Depth,
                                                 TC_Expected_Speed)
   then
      Report.Failed ("Call to explicit subprogram executed the wrong body");
   end if;

   Report.Result;

end C392D01;