path: root/gcc/testsuite/ada/acats-4/tests/c3/c393013.a

-- C393013.A
--
--                             Grant of Unlimited Rights
--
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
--     rights in the software and documentation contained herein. Unlimited
--     rights are the same as those granted by the U.S. Government for older
--     parts of the Ada Conformity Assessment Test Suite, and are defined
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--     intends to confer upon all recipients unlimited rights equal to those
--     held by the ACAA. 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 ACAA 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.
--
--                                     Notice
--
--     The ACAA has created and maintains the Ada Conformity Assessment Test
--     Suite for the purpose of conformity assessments conducted in accordance
--     with the International Standard ISO/IEC 18009 - Ada: Conformity
--     assessment of a language processor. This test suite should not be used
--     to make claims of conformance unless used in accordance with
--     ISO/IEC 18009 and any applicable ACAA procedures.
--*
-- OBJECTIVE:
--     Check that a non-abstract function with a controlling result of
--     type T is inherited as non-abstract and does not require overriding
--     for a null extension of T.
--
--     Check that a call on an inherited function for a null extension
--     returns the equivalent of a null extension aggregate.
--
--     For a private extension of type T, check that an inherited non-abstract
--     function with a controlling result does not require overriding if the
--     full type is a null extension of T.


-- TEST DESCRIPTION:
--     The rules in question are 3.4(27/2), 3.9.3(4/2), and 3.9.3(6/2), which
--     are all changes from Ada 95.
--
--     We create a root tagged type with concrete constructor and
--     cloning functions, and then derive from it in various ways.
--     We then check that the constructor and cloning functions
--     return objects with the correct tag.
--
--     Specifically, types Water_Turbine and Alarmed_Generator check the
--     first objective (for non-generic and generic cases, respectively), and
--     types Windmill and Monitored_Generator check the second objective
--     (also for non-generic and generic cases). The main subprogram checks
--     the third objective.
--
-- CHANGE HISTORY:
--     08 Apr 2008 RLB Created test.
--     09 Apr 2008 RLB Added generic cases.
--
package C393013_1 is
   type Generator is tagged private;
   function Power_Output (Obj : in Generator) return Natural;
   procedure Set_Power_Output (Obj : in out Generator; Power : in Natural);
   function Location (Obj : in Generator) return Character;
   procedure Set_Location (Obj : in out Generator; Location : in Character);
       -- Natural and Character stand in for real application data types.
   function Create (Power : in Natural) return Generator;
   function Clone (Obj : in Generator; New_Location : in Character)
     return Generator;
       -- Create a copy of Obj at a new location.
private
   type Generator is tagged record
       Power_Output : Natural := 0;
       Location : Character := ' ';
   end record;
end C393013_1;

package body C393013_1 is

   function Power_Output (Obj : in Generator) return Natural is
   begin
       return Obj.Power_Output;
   end Power_Output;

   procedure Set_Power_Output (Obj : in out Generator; Power : in Natural) is
   begin
      Obj.Power_Output := Power;
   end Set_Power_Output;

   function Location (Obj : in Generator) return Character is
   begin
       return Obj.Location;
   end Location;

   procedure Set_Location (Obj : in out Generator; Location : in Character) is
   begin
       Obj.Location := Location;
   end Set_Location;

   function Create (Power : in Natural) return Generator is
   begin
       return (Power_Output => Power, Location => 'A');
   end Create;

   function Clone (Obj : Generator; New_Location : in Character)
     return Generator is
   begin
       return  (Power_Output => Obj.Power_Output, Location => New_Location);
   end Clone;

end C393013_1;

with C393013_1;
package C393013_2 is
   type Water_Turbine is new C393013_1.Generator with null record;
   -- Inherits all of Power_Output, Set_Power_Output, Location,
   -- Set_Location, Create, and Clone as non-abstract operations.
end C393013_2;

with C393013_1;
package C393013_3 is
   type Windmill is new C393013_1.Generator with private;
   -- Inherits all of Power_Output, Set_Power_Output, Location, and
   -- Set_Location as non-abstract operations.

   -- Clone and Create are inherited as requires overriding operations.
private
   type Windmill is new C393013_1.Generator with null record;
   -- Clone and Create become non-abstract operations here, and no
   -- overriding is required.
end C393013_3;

with C393013_1;
package C393013_4 is
   type Gas_Turbine is new C393013_1.Generator with private;
   -- Inherits all of Power_Output, Set_Power_Output, Location, and
   -- Set_Location as non-abstract operations.
   -- Clone and Create are inherited as requires overriding operations.
   type Gas_Kind_Type is (Natural_Gas, Gasoline, Biomass_Methane);
   not overriding
   function Kind (Obj : in Gas_Turbine) return Gas_Kind_Type;
   not overriding
   procedure Set_Kind (Obj : in out Gas_Turbine; Kind : in Gas_Kind_Type);
private
   type Gas_Turbine is new C393013_1.Generator with record
       Kind : Gas_Kind_Type;
   end record;
   -- Create and Clone must be overridden:
   overriding
   function Create (Power : in Natural) return Gas_Turbine;
   overriding
   function Clone (Obj : in Gas_Turbine; New_Location : in Character)
     return Gas_Turbine;
       -- Create a copy of Obj at a new location.
end C393013_4;

package body C393013_4 is

   function Kind (Obj : in Gas_Turbine) return Gas_Kind_Type is
   begin
       return Obj.Kind;
   end Kind;

   procedure Set_Kind (Obj : in out Gas_Turbine; Kind : in Gas_Kind_Type) is
   begin
      Obj.Kind := Kind;
   end Set_Kind;

   function Create (Power : in Natural) return Gas_Turbine is
   begin
       return (C393013_1.Create (Power) with Kind => Natural_Gas);
   end Create;

   function Clone (Obj : Gas_Turbine; New_Location : in Character)
     return Gas_Turbine is
   begin
       return  (C393013_1.Clone (C393013_1.Generator(Obj), New_Location) with
           Kind => Natural_Gas);
   end Clone;

end C393013_4;

with C393013_1;
generic
   type Original_Generator is new C393013_1.Generator with private;
package C393013_G1 is
   type Alarmed_Generator is new Original_Generator with null record;
   -- Inherits all of Power_Output, Set_Power_Output, Location,
   -- Set_Location, Create, and Clone as non-abstract operations.

   -- Alarm operations would be here.
end C393013_G1;

with C393013_1;
generic
   type Original_Generator is new C393013_1.Generator with private;
package C393013_G2 is
   type Monitored_Generator is new Original_Generator with private;
   -- Inherits all of Power_Output, Set_Power_Output, Location, and
   -- Set_Location as non-abstract operations.
   -- Clone and Create are inherited as requires overriding operations.

   -- Monitor operations would be here.
private
   type Monitored_Generator is new Original_Generator with null record;
   -- Clone and Create become non-abstract operations here, and no
   -- overriding is required.
end C393013_G2;

with C393013_1;
with C393013_2;
with C393013_3;
with C393013_4;
with C393013_G1;
with C393013_G2;
package C393013_5 is

   package Alarmed_Windmill is new C393013_G1 (C393013_3.Windmill);

   package Monitored_Hydro is new C393013_G2 (C393013_2.Water_Turbine);

   package Monitored_Gas_Turbine is new C393013_G2 (C393013_4.Gas_Turbine);

end C393013_5;

with C393013_1; use C393013_1;
with C393013_2;
with C393013_3;
with C393013_4;
with C393013_5;
with Report;
with Ada.Tags;
procedure C393013 is
   -- Static objects of each type:
   Gen : C393013_1.Generator;
   H2O : C393013_2.Water_Turbine;
   Wind: C393013_3.Windmill;
   Gas : C393013_4.Gas_Turbine;
   A_Wind : C393013_5.Alarmed_Windmill.Alarmed_Generator;
   M_H2O  : C393013_5.Monitored_Hydro.Monitored_Generator;
   M_Gas  : C393013_5.Monitored_Gas_Turbine.Monitored_Generator;
   use type Ada.Tags.Tag;

   procedure Make_Farm (First_Obj : Generator'Class;
			TC_Tag : Ada.Tags.Tag; TC_Id : String) is
     -- Clone First_Obj with dispatching calls:
     Obj1 : Generator'Class := First_Obj.Clone (New_Location => 'X');
     Obj2 : Generator'Class := First_Obj.Clone (New_Location => 'Y');
     Obj3 : Generator'Class := First_Obj.Clone (New_Location => 'Z');
   begin
     if Obj1.Location /= 'X' or else Obj2.Location /= 'Y' or else
        Obj3.Location /= 'Z' then
        Report.Failed ("Farm locations wrong - " & TC_Id);
     end if;
     if Obj1'Tag /= TC_Tag or else Obj2'Tag /= TC_Tag or else
        Obj3'Tag /= TC_Tag then
        Report.Failed ("Farm tag wrong - " & TC_Id);
     end if;
   end Make_Farm;

begin
   Report.Test ("C393013", "Check that a non-abstract function with a " &
                           "controlling result of type T is inherited " &
                           "as non-abstract and does not require " &
                           "overriding for a null extension of T " &
                           "and that the result of calling the inherited " &
                           "function has the tag of the extension");

   begin
      Gen := C393013_1.Create (10);
      if Gen.Power_Output /= Report.Ident_Int(10) then
          Report.Failed ("Wrong value for Gen");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for Gen.Create");
   end;

   begin
      H2O := C393013_2.Create (65);
      if H2O.Power_Output /= Report.Ident_Int(65) then
          Report.Failed ("Wrong value for H2O");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for H2O.Create");
   end;

   begin
      Wind := C393013_3.Create (23);
      if Wind.Power_Output /= Report.Ident_Int(23) then
          Report.Failed ("Wrong value for Wind");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for Wind.Create");
   end;

   begin
      Gas := C393013_4.Create (135);
      if Gas.Power_Output /= Report.Ident_Int(135) then
          Report.Failed ("Wrong value for Gas");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for Gas.Create");
   end;

   begin
      A_Wind := C393013_5.Alarmed_Windmill.Create (90);
      if A_Wind.Power_Output /= Report.Ident_Int(90) then
          Report.Failed ("Wrong value for A_Wind");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for A_Wind.Create");
   end;

   begin
      M_H2O := C393013_5.Monitored_Hydro.Create (43);
      if M_H2O.Power_Output /= Report.Ident_Int(43) then
          Report.Failed ("Wrong value for M_H2O");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for M_H2O.Create");
   end;

   begin
      M_Gas := C393013_5.Monitored_Gas_Turbine.Create (850);
      if M_Gas.Power_Output /= Report.Ident_Int(850) then
          Report.Failed ("Wrong value for M_Gas");
      end if;
   exception
      when Constraint_Error =>
          Report.Failed ("Constraint_Error raised; tag wrong for M_Gas.Create");
   end;

   declare
      G1 : Generator'Class := C393013_1.Create (20);
      G2 : Generator'Class := C393013_2.Create (55);
      G3 : Generator'Class := C393013_3.Create (16);
      G4 : Generator'Class := C393013_4.Create (134);
      G5 : Generator'Class := C393013_5.Alarmed_Windmill.Create (40);
      G6 : Generator'Class := C393013_5.Monitored_Hydro.Create (1200);
      G7 : Generator'Class := C393013_5.Monitored_Gas_Turbine.Create (450);
      -- Test cloning; these are dispatching calls:
      G11 : Generator'Class := G1.Clone (New_Location => 'B');
      G12 : Generator'Class := G2.Clone (New_Location => 'C');
      G13 : Generator'Class := G3.Clone (New_Location => 'D');
      G14 : Generator'Class := G4.Clone (New_Location => 'E');
      G15 : Generator'Class := G5.Clone (New_Location => 'F');
      G16 : Generator'Class := G6.Clone (New_Location => 'G');
      G17 : Generator'Class := G7.Clone (New_Location => 'H');
   begin
      if G1.Power_Output /= Report.Ident_Int(20) or else
         G1.Location /= 'A' then
          Report.Failed ("Wrong values for G1");
      end if;
      if G1'Tag /= C393013_1.Generator'Tag then
          Report.Failed ("Wrong tag for G1");
      end if;

      if G2.Power_Output /= Report.Ident_Int(55) or else
         G2.Location /= 'A' then
          Report.Failed ("Wrong values for G2");
      end if;
      if G2'Tag /= C393013_2.Water_Turbine'Tag then
          Report.Failed ("Wrong tag for G2");
      elsif G2'Tag = G1'Tag then
          Report.Failed ("Tags same for objects of different types - G2");
      end if;

      if G3.Power_Output /= Report.Ident_Int(16) or else
         G3.Location /= 'A' then
          Report.Failed ("Wrong values for G3");
      end if;
      if G3'Tag /= C393013_3.Windmill'Tag then
          Report.Failed ("Wrong tag for G3");
      elsif G3'Tag = G1'Tag then
          Report.Failed ("Tags same for objects of different types - G3");
      end if;

      if G4.Power_Output /= Report.Ident_Int(134) or else
         G4.Location /= 'A' then
          Report.Failed ("Wrong values for G4");
      end if;
      if G4'Tag /= C393013_4.Gas_Turbine'Tag then
          Report.Failed ("Wrong tag for G4");
      elsif G4'Tag = G1'Tag then
          Report.Failed ("Tags same for objects of different types - G4");
      end if;

      if G5.Power_Output /= Report.Ident_Int(40) or else
         G5.Location /= 'A' then
          Report.Failed ("Wrong values for G5");
      end if;
      if G5'Tag /= C393013_5.Alarmed_Windmill.Alarmed_Generator'Tag then
          Report.Failed ("Wrong tag for G5");
      elsif G5'Tag = G1'Tag or else G5'Tag = G3'Tag then
          Report.Failed ("Tags same for objects of different types - G5");
      end if;

      if G6.Power_Output /= Report.Ident_Int(1200) or else
         G6.Location /= 'A' then
          Report.Failed ("Wrong values for G6");
      end if;
      if G6'Tag /= C393013_5.Monitored_Hydro.Monitored_Generator'Tag then
          Report.Failed ("Wrong tag for G6");
      elsif G6'Tag = G1'Tag or else G6'Tag = G2'Tag then
          Report.Failed ("Tags same for objects of different types - G6");
      end if;

      if G7.Power_Output /= Report.Ident_Int(450) or else
         G7.Location /= 'A' then
          Report.Failed ("Wrong values for G7");
      end if;
      if G7'Tag /= C393013_5.Monitored_Gas_Turbine.Monitored_Generator'Tag then
          Report.Failed ("Wrong tag for G7");
      elsif G7'Tag = G1'Tag or else G7'Tag = G4'Tag then
          Report.Failed ("Tags same for objects of different types - G7");
      end if;

      if G11.Power_Output /= Report.Ident_Int(20) or else
         G11.Location /= 'B' then
          Report.Failed ("Wrong values for G11");
      end if;
      if G11'Tag /= C393013_1.Generator'Tag then
          Report.Failed ("Wrong tag for G11");
      end if;

      if G12.Power_Output /= Report.Ident_Int(55) or else
         G12.Location /= 'C' then
          Report.Failed ("Wrong values for G12");
      end if;
      if G12'Tag /= C393013_2.Water_Turbine'Tag then
          Report.Failed ("Wrong tag for G12");
      end if;

      if G13.Power_Output /= Report.Ident_Int(16) or else
         G13.Location /= 'D' then
          Report.Failed ("Wrong values for G13");
      end if;
      if G13'Tag /= C393013_3.Windmill'Tag then
          Report.Failed ("Wrong tag for G13");
      end if;

      if G14.Power_Output /= Report.Ident_Int(134) or else
         G14.Location /= 'E' then
          Report.Failed ("Wrong values for G14");
      end if;
      if G14'Tag /= C393013_4.Gas_Turbine'Tag then
          Report.Failed ("Wrong tag for G14");
      end if;

      if G15.Power_Output /= Report.Ident_Int(40) or else
         G15.Location /= 'F' then
          Report.Failed ("Wrong values for G15");
      end if;
      if G15'Tag /= C393013_5.Alarmed_Windmill.Alarmed_Generator'Tag then
          Report.Failed ("Wrong tag for G15");
      end if;

      if G16.Power_Output /= Report.Ident_Int(1200) or else
         G16.Location /= 'G' then
          Report.Failed ("Wrong values for G16");
      end if;
      if G16'Tag /= C393013_5.Monitored_Hydro.Monitored_Generator'Tag then
          Report.Failed ("Wrong tag for G16");
      end if;

      if G17.Power_Output /= Report.Ident_Int(450) or else
         G17.Location /= 'H' then
          Report.Failed ("Wrong values for G17");
      end if;
      if G17'Tag /= C393013_5.Monitored_Gas_Turbine.Monitored_Generator'Tag then
          Report.Failed ("Wrong tag for G17");
      end if;

      -- Create a hydropower farm:
      Make_Farm (G2, C393013_2.Water_Turbine'Tag, "Hydro Farm");
      -- and a wind farm:
      Make_Farm (G3, C393013_3.Windmill'Tag,      "Wind Farm");
      -- and Hoover Dam (lots of hydropower, to light Las Vegas):
      Make_Farm (G6, C393013_5.Monitored_Hydro.Monitored_Generator'Tag, "Hoover Dam");
   end;

   Report.Result;

end C393013;