2003-12-26 Guilhem Lavaux <guilhem@kaffe.org>

[official-gcc.git] / gcc / testsuite / ada / acats / tests / c7 / c730002.a

-- C730002.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 the full view of a private extension may be derived
--      indirectly from the ancestor type (i.e., the parent type of the full
--      type may be any descendant of the ancestor type). Check that, for
--      a primitive subprogram of the private extension that is inherited from
--      the ancestor type and not overridden, the formal parameter names and
--      default expressions come from the corresponding primitive subprogram
--      of the ancestor type, while the body comes from that of the parent
--      type.
--      Check for a case where the parent type is derived from the ancestor
--      type through a series of types produced by generic instantiations.
--      Examine both the static and dynamic binding cases.
--
-- TEST DESCRIPTION:
--      Consider:
--
--      package P is
--         type Ancestor is tagged ...
--         procedure Op (P1: Ancestor; P2: Boolean := True);
--      end P;
--
--      with P;
--      generic
--         type T is new P.Ancestor with private;  
--      package Gen1 is
--         type Enhanced is new T with private;
--         procedure Op (A: Enhanced; B: Boolean := True);
--         -- other specific procedures...
--      private
--         type Enhanced is new T with ...
--      end Gen1;
--
--      with P, Gen1;
--      package N is new Gen1 (P.Ancestor);
--
--      with N;
--      generic
--         type T is new N.Enhanced with private;
--      package Gen2 is
--         type Enhanced_Again is new T with private;
--         procedure Op (X: Enhanced_Again; Y: Boolean := False);
--         -- other specific procedures...
--      private
--         type Enhanced_Again is new T with ...
--      end Gen2;
--
--      with N, Gen2;
--      package Q is new Gen2 (N.Enhanced);
--
--      with P, Q;
--      package R is
--         type Priv_Ext is new P.Ancestor with private;         -- (A)
--         -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
--         -- But body executed is that of Q.Op.
--      private
--         type Priv_Ext is new Q.Enhanced_Again with record ... -- (B)
--      end R;
--
--      The ancestor type in (A) differs from the parent type in (B); the
--      parent of the full type is descended from the ancestor type of the
--      private extension, in this case through a series of types produced
--      by generic instantiations.  Gen1 redefines the implementation of Op
--      for any type that has one.  N is an instance of Gen1 for the ancestor
--      type. Gen2 again redefines the implementation of Op for any type that
--      has one. Q is an instance of Gen2 for the extension of the P.Ancestor
--      declared in N.  Both N and Q could define other operations which we
--      don't want to be available in R.  For a call to Op (from outside the
--      scope of the full view) with an operand of type R.Priv_Ext, the body
--      executed will be that of Q.Op (the parent type's version), but the
--      formal parameter names and default expression come from that of P.Op
--      (the ancestor type's version).
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      27 Feb 97   CTA.PWB Added elaboration pragmas.
--!

package C730002_0 is

   type Hours_Type      is range 0..1000;
   type Personnel_Type  is range 0..10;
   type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry);

   type Engine_Type is tagged record
      Ave_Repair_Time    : Hours_Type     := 0;     -- Default init. for
      Personnel_Required : Personnel_Type := 0;     -- component fields.
      Specialist         : Specialist_ID  := Manny;
   end record;

   procedure Routine_Maintenance (Engine     : in out Engine_Type ; 
                                  Specialist : in     Specialist_ID := Moe);

   -- The Routine_Maintenance procedure implements the processing required
   -- for an engine.

end C730002_0;

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

package body C730002_0 is

   procedure Routine_Maintenance (Engine     : in out Engine_Type ; 
                                  Specialist : in     Specialist_ID := Moe) is
   begin
      Engine.Ave_Repair_Time     := 3;
      Engine.Personnel_Required  := 1;
      Engine.Specialist := Specialist;
   end Routine_Maintenance;

end C730002_0;

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

with C730002_0; use C730002_0;
generic
   type T is new C730002_0.Engine_Type with private;
package C730002_1 is

   -- This generic package contains types/procedures specific to engines 
   -- of the diesel variety.

   type Repair_Facility_Type is (On_Site, Repair_Shop, Factory);

   type Diesel_Series is new T with private;

   procedure Routine_Maintenance (Eng      : in out Diesel_Series;
                                  Spec_Req : in     Specialist_ID := Jack);
  
   -- Other diesel specific operations... (not required in this test).

private

   type Diesel_Series is new T with record
      Repair_Facility_Required : Repair_Facility_Type := On_Site;
   end record;

end C730002_1;

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

package body C730002_1 is

   procedure Routine_Maintenance (Eng      : in out Diesel_Series;
                                  Spec_Req : in     Specialist_ID := Jack) is
   begin
      Eng.Ave_Repair_Time          := 6;
      Eng.Personnel_Required       := 2;
      Eng.Specialist               := Spec_Req;
      Eng.Repair_Facility_Required := On_Site;
   end Routine_Maintenance;

end C730002_1;

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

with C730002_0;
with C730002_1;
pragma Elaborate (C730002_1);
package C730002_2 is new C730002_1 (C730002_0.Engine_Type);

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

with C730002_0; use C730002_0;
with C730002_2; use C730002_2;
generic
  type T is new C730002_2.Diesel_Series with private;
package C730002_3 is

   type Time_Of_Operation_Type is range 0..100_000;

   type Electric_Series is new T with private;

   procedure Routine_Maintenance (E  : in out Electric_Series;
                                  SR : in     Specialist_ID := Curly);

   -- Other electric specific operations... (not required in this test).

private

   type Electric_Series is new T with record
      Mean_Time_Between_Repair : Time_Of_Operation_Type := 0;
   end record; 

end C730002_3;

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

package body C730002_3 is

   procedure Routine_Maintenance (E  : in out Electric_Series;
                                  SR : in     Specialist_ID := Curly) is
   begin
      E.Ave_Repair_Time          := 9;
      E.Personnel_Required       := 3;
      E.Specialist               := SR;
      E.Mean_Time_Between_Repair := 1000;
   end Routine_Maintenance;

end C730002_3;

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

with C730002_2;
with C730002_3;
pragma Elaborate (C730002_3);
package C730002_4 is new C730002_3 (C730002_2.Diesel_Series);

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

with C730002_0;  use C730002_0;
with C730002_4;  use C730002_4;

package C730002_5 is

   type Inspection_Type is (AAA, MIL_STD, NRC);

   type Nuclear_Series is new Engine_Type with private;              -- (A)

   -- Inherits procedure Routine_Maintenance from ancestor; does not override.
   --                      (Engine     : in out Nuclear_Series; 
   --                       Specialist : in     Specialist_ID := Moe);
   -- But body executed will be that of C730002_4.Routine_Maintenance, 
   -- the parent type.

   function TC_Specialist         (E : Nuclear_Series) return Specialist_ID;
   function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type;
   function TC_Time_Required      (E : Nuclear_Series) return Hours_Type;

   -- Dispatching subprogram.
   procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class);

private

   type Nuclear_Series is new Electric_Series with record           -- (B)
      Inspector_Rep : Inspection_Type := NRC;
   end record;

   -- The ancestor type is used in the type extension (A), while the parent
   -- of the full type (B) is a descendent of the ancestor type, through a
   -- series of types produced by generic instantiation.

end C730002_5;

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

package body C730002_5 is

   function TC_Specialist (E : Nuclear_Series) return Specialist_ID is
   begin
      return E.Specialist;
   end TC_Specialist;

   function TC_Personnel_Required (E : Nuclear_Series) 
     return Personnel_Type is
   begin
      return E.Personnel_Required;
   end TC_Personnel_Required;

   function TC_Time_Required (E : Nuclear_Series) return Hours_Type is
   begin
      return E.Ave_Repair_Time;
   end TC_Time_Required;

   -- Dispatching subprogram.
   procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is
   begin
      Routine_Maintenance (The_Engine);
   end Maintain_The_Engine;


end C730002_5;

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

with Report;
with C730002_0;  use C730002_0;
with C730002_2;  use C730002_2;
with C730002_4;  use C730002_4;
with C730002_5;  use C730002_5;

procedure C730002 is
begin

   Report.Test ("C730002", "Check that the full view of a private "        &
                           "extension may be derived indirectly from "     &
                           "the ancestor type.  Check for a case where "   &
                           "the parent type is derived from the ancestor " &
                           "type through a series of types produced by "   &
                           "generic instantiations");

   Test_Block:
   declare
      Nuclear_Drive : Nuclear_Series;
      Warp_Drive    : Nuclear_Series;
   begin

      -- Non-Dispatching Case:
      -- Call Routine_Maintenance using formal parameter name from
      -- C730002_0.Routine_Maintenance (ancestor version).
      -- Give no second parameter so that the default expression must be
      -- used.

      Routine_Maintenance (Engine => Nuclear_Drive);

      -- The value of the Specialist component should equal "Moe",
      -- which is the default value from the ancestor's version of
      -- Routine_Maintenance, and not the default value from the parent's
      -- version of Routine_Maintenance.

      if TC_Specialist (Nuclear_Drive) /= Moe then
         Report.Failed
           ("Default expression for ancestor op not used " &
            " - non-dispatching case");
      end if;

      -- However the value of the Ave_Repair_Time and Personnel_Required 
      -- components should be those assigned in the parent type's version 
      -- of the body of Routine_Maintenance.
      -- Note: Only components associated with the ancestor type are
      --       evaluated for the purposes of this test.

      if TC_Personnel_Required (Nuclear_Drive) /= 3  or
         TC_Time_Required (Nuclear_Drive)      /= 9
      then
         Report.Failed("Wrong body was executed - non-dispatching case");
      end if;

      -- Dispatching Case:
      -- Use a dispatching subprogram to ensure that the correct body is 
      -- used at runtime.

      Maintain_The_Engine (Warp_Drive);

      -- The resulting assignments to the fields of the Warp_Drive variable
      -- should be the same as those of the Nuclear_Drive above, indicating
      -- that the body of the parent version of the inherited subprogram
      -- was used.

      if TC_Specialist (Warp_Drive) /= Moe then
         Report.Failed
           ("Default expression for ancestor op not used - dispatching case");
      end if;

      if TC_Personnel_Required (Nuclear_Drive) /= 3  or
         TC_Time_Required (Nuclear_Drive)      /= 9
      then
         Report.Failed("Wrong body was executed - dispatching case");
      end if;


   exception
      when others => Report.Failed("Exception raised in Test_Block");
   end Test_Block;

   Report.Result;

end C730002;