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

-- C392005.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 for the case where the overriding operations are declared in a
--      public child unit of the package declaring the parent type, and the
--      descendant type is a private extension.
--
--      Check for both dispatching and nondispatching calls.
--
--
-- TEST DESCRIPTION:
--      Consider:
--
--      package Parent is
--         type Root is tagged ...
--         procedure Vis_Op (P: Root);
--      private
--         procedure Pri_Op (P: Root);
--      end Parent;
--
--      package Parent.Child is
--         type Derived is new Root with private;
--         -- Implicit Vis_Op (P: Derived) declared here.
--
--         procedure Pri_Op (P: Derived);                  -- (A)
--         ...
--      private
--         type Derived is new Root with record...
--         -- Implicit Pri_Op (P: Derived) declared here.

--         procedure Vis_Op (P: Derived);                  -- (B)
--         ...
--      end Parent.Child;
--
--      Type Derived inherits both Vis_Op and Pri_Op from the ancestor type
--      Root. Note, however, that Vis_Op is implicitly declared in the visible
--      part, whereas Pri_Op is implicitly declared in the private part
--      (inherited subprograms for a private extension are implicitly declared
--      after the private_extension_declaration if the corresponding
--      declaration from the ancestor is visible at that place; otherwise the
--      inherited subprogram is not declared for the private extension,
--      although it might be for the full type).
--
--      Even though Root's version of Pri_Op hasn't been implicitly declared
--      for Derived at the time Derived's version of Pri_Op has been
--      explicitly declared, the explicit Pri_Op still overrides the implicit
--      version. 
--      Also, even though the explicit Vis_Op for Derived is declared in the
--      private part it still overrides the implicit version declared in the
--      visible part. Calls with tag Derived will execute (A) and (B).
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      26 Nov 96   SAIC    Improved for ACVC 2.1
--
--!

package C392005_0 is

   type Remote_Camera is tagged private;

   type Depth_Of_Field is range 5 .. 100;  
   type Shutter_Speed  is (One, Two_Fifty, Four_Hundred, Thousand);
   type Aperture       is (Eight, Sixteen, Thirty_Two);     

   -- ...Other declarations.

   procedure Focus (Cam   : in out Remote_Camera;
                    Depth : in     Depth_Of_Field);

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

   -- ...Other operations.

   function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field;
   function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed;

private

   type Remote_Camera is tagged record
      DOF    : Depth_Of_Field := 10;
      Shutter: Shutter_Speed  := One;
      FStop  : Aperture       := Eight;
   end record;

   procedure Set_Shutter_Speed (C     : in out Remote_Camera;
                                Speed : in     Shutter_Speed);

   -- For the basic remote camera, shutter speed might be set as a function of
   -- focus perhaps, thus it is declared as a private operation (usable
   -- only internally within the abstraction).

   function Set_Aperture (C : Remote_Camera) return Aperture;
                               
end C392005_0;


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


package body C392005_0 is

   procedure Focus (Cam   : in out Remote_Camera;
                    Depth : in     Depth_Of_Field) is
   begin
      -- Artificial for testing purposes.
      Cam.DOF := 46;
   end Focus;

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

   -----------------------------------------------------------
   function Set_Aperture (C : Remote_Camera) return Aperture is
   begin
      -- Artificial for testing purposes.
      return Thirty_Two;
   end Set_Aperture;

   -----------------------------------------------------------
   procedure Self_Test (C: in out Remote_Camera'Class) is
      TC_Dummy_Depth : constant Depth_Of_Field := 23;
      TC_Dummy_Speed : constant Shutter_Speed  := Four_Hundred;
   begin

      -- Test focus at various depths:
      Focus(C, TC_Dummy_Depth);
      -- ...Additional calls to Focus.

      -- Test various shutter speeds:
      Set_Shutter_Speed(C, TC_Dummy_Speed);
      -- ...Additional calls to Set_Shutter_Speed.

   end Self_Test;

   -----------------------------------------------------------
   function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is
   begin
      return C.DOF;
   end TC_Get_Depth;

   -----------------------------------------------------------
   function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is
   begin
      return C.Shutter;
   end TC_Get_Speed;

end C392005_0;

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


package C392005_0.C392005_1 is

   type Auto_Speed is new Remote_Camera with private;


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

   -- For the improved remote camera, shutter speed can be set manually,
   -- so it is declared as a public operation.

   -- The order of declarations for Set_Aperture and Set_Shutter_Speed are
   -- reversed from the original declarations to trap potential compiler
   -- problems related to subprogram ordering.

   function Set_Aperture (C : Auto_Speed) return Aperture;    -- Overrides
                                                              -- inherited op.

   procedure Set_Shutter_Speed (C     : in out Auto_Speed;    -- Overrides
                                Speed : in     Shutter_Speed);-- inherited op.

   -- Set_Shutter_Speed and Set_Aperture override the operations inherited
   -- from the parent, even though the inherited operations are not implicitly
   -- declared until the private part below.

   type New_Camera is private;

   function TC_Get_Aper (C: New_Camera) return Aperture;

   -- ...Other operations.

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

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

   -- procedure Set_Shutter_Speed (C     : in out Auto_Speed;    -- Implicitly
   --                              Speed : in     Shutter_Speed) -- declared
                                                                 -- here.

   -- function Set_Aperture (C : Auto_Speed) return Aperture;    -- Implicitly
                                                                 -- declared.

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

   -- For the improved remote camera, perhaps the focusing algorithm is
   -- different, so the original Focus operation is overridden here.

   Auto_Camera : Auto_Speed;

   type New_Camera is record
      Aper : Aperture := Set_Aperture (Auto_Camera);  -- Calls the overridden,
   end record;                                        -- not the inherited op.

end C392005_0.C392005_1;


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


package body C392005_0.C392005_1 is

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

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

   -----------------------------------------------------------
   function Set_Aperture (C : Auto_Speed) return Aperture is
   begin
      -- Artificial for testing purposes.
      return Sixteen;
   end Set_Aperture;

   -----------------------------------------------------------
   function TC_Get_Aper (C: New_Camera) return Aperture is
   begin
      return C.Aper;
   end TC_Get_Aper;

end C392005_0.C392005_1;


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


with C392005_0.C392005_1;

with Report;

procedure C392005 is
   Basic_Camera : C392005_0.Remote_Camera;
   Auto_Camera1 : C392005_0.C392005_1.Auto_Speed;
   Auto_Camera2 : C392005_0.C392005_1.Auto_Speed;
   Auto_Depth   : C392005_0.Depth_Of_Field := 67;
   New_Camera1  : C392005_0.C392005_1.New_Camera;
   TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46;
   TC_Expected_Auto_Depth  : constant C392005_0.Depth_Of_Field := 57;
   TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed  
                           := C392005_0.Thousand;
   TC_Expected_Auto_Speed  : constant C392005_0.Shutter_Speed  
                           := C392005_0.Two_Fifty;
   TC_Expected_New_Aper    : constant C392005_0.Aperture 
                           := C392005_0.Sixteen;

   use type C392005_0.Depth_Of_Field;
   use type C392005_0.Shutter_Speed;
   use type C392005_0.Aperture;

begin
   Report.Test ("C392005", "Dispatching for overridden primitive "        &
                "subprograms: private extension declared in child unit, " &
                "parent is tagged private whose full view is tagged record");

-- Call the class-wide operation for Remote_Camera'Class, which itself makes
-- dispatching calls to Focus and Set_Shutter_Speed:


   -- For an object of type Remote_Camera, the dispatching calls should
   -- dispatch to the bodies declared for the root type:
     
   C392005_0.Self_Test(Basic_Camera);

   if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth 
     or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed
   then
      Report.Failed ("Calls dispatched incorrectly for root type");
   end if;


   -- For an object of type Auto_Speed, the dispatching calls should
   -- dispatch to the bodies declared for the derived type:
     
   C392005_0.Self_Test(Auto_Camera1);

   if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth

      or
      C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed
   then
      Report.Failed ("Calls dispatched incorrectly for derived type");
   end if;

   -- For an object of type Auto_Speed, a non-dispatching call to Focus should

   -- execute the body declared for the derived type (even through it is 
   -- declared in the private part).

   C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth);

   if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth

   then
      Report.Failed ("Non-dispatching call to privately overriding " &
                     "subprogram executed the wrong body");
   end if;

   -- For an object of type New_Camera, the initialization using Set_Ap 
   -- should execute the overridden body, not the inherited one.

   if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper  
   then
      Report.Failed ("Non-dispatching call to visible overriding " &
                     "subprogram executed the wrong body");
   end if;

   Report.Result;

end C392005;