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

-- C392002.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 use of a class-wide formal parameter allows for the 
--      proper dispatching of objects to the appropriate implementation of 
--      a primitive operation.  Check this in the case where the root tagged
--      type is defined in a generic package, and the type derived from it is
--      defined in that same generic package.
--
-- TEST DESCRIPTION:
--      Declare a root tagged type, and some associated primitive operations.
--      Extend the root type, and override one or more primitive operations, 
--      inheriting the other primitive operations from the root type.
--      Derive from the extended type, again overriding some primitive
--      operations and inheriting others (including some that the parent 
--      inherited).
--      Define a subprogram with a class-wide parameter, inside of which is a 
--      call on a dispatching primitive operation.  These primitive operations
--      modify global variables (the class-wide parameter has mode IN).
--     
--  The following hierarchy of tagged types and primitive operations is 
--  utilized in this test:
--
--
--    type Vehicle (root)
--            |
--    type Motorcycle
--            |
--            | Operations
--            |   Engine_Size
--            |   Catalytic_Converter
--            |   Emissions_Produced
--            |
--    type Automobile (extended from Motorcycle)
--            |
--            | Operations
--            |   (Engine_Size)       (inherited)
--            |   Catalytic_Converter (overridden)
--            |   Emissions_Produced  (overridden)
--            |
--    type Truck (extended from Automobile)
--            |
--            | Operations
--            |   (Engine_Size)         (inherited twice - Motorcycle)
--            |   (Catalytic_Converter) (inherited - Automobile)
--            |   Emissions_Produced    (overridden)
-- 
--
-- In this test, we are concerned with the following selection of dispatching
-- calls, accomplished with the use of a Vehicle'Class IN procedure 
-- parameter :
--
--                       \ Type
--               Prim. Op \   Motorcycle      Automobile        Truck
--                         \------------------------------------------------ 
--             Engine_Size |      X               X               X
--     Catalytic_Converter |      X               X               X
--     Emissions_Produced  |      X               X               X
--
--
--
-- The location of the declaration and derivation of the root and extended
-- types will be varied over a series of tests.  Locations of declaration
-- and derivation for a particular test are marked with an asterisk (*).
--
-- Root type:
--       
--       Declared in package.                                          
--    *  Declared in generic package.
--
-- Extended types:
--
--    *  Derived in parent location.
--       Derived in a nested package.
--       Derived in a nested subprogram.
--       Derived in a nested generic package.
--       Derived in a separate package.
--       Derived in a separate visible child package.
--       Derived in a separate private child package.
--
-- Primitive Operations:
--
--    *  Procedures with same parameter profile.
--       Procedures with different parameter profile.
--    *  Functions with same parameter profile.
--       Functions with different parameter profile.
--    *  Mixture of Procedures and Functions.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      09 May 96   SAIC    Made single-file for 2.1
--
--!

------------------------------------------------------------------- C392002_0

-- Declare the root and extended types, along with their primitive
-- operations in a generic package.

generic

   type Cubic_Inches     is range <>;
   type Emission_Measure is digits <>;
   Emissions_per_Engine_Cubic_Inch : Emission_Measure;

package C392002_0 is       -- package Vehicle_Simulation

   --
   -- Equipment types and their primitive operations.
   --

   -- Root type.

   type Vehicle is abstract tagged 
      record 
         Weight : Integer;
         Wheels : Positive;
      end record;

   -- Abstract operations of type Vehicle.
   function Engine_Size         (V : in Vehicle) return Cubic_Inches
            is abstract;
   function Catalytic_Converter (V : in Vehicle) return Boolean
            is abstract;
   function Emissions_Produced  (V : in Vehicle) return Emission_Measure
            is abstract;

   --

   type Motorcycle is new Vehicle with
      record
         Size_Of_Engine : Cubic_Inches;
      end record;

   -- Primitive operations of type Motorcycle.
   function Engine_Size         (V : in Motorcycle) return Cubic_Inches;
   function Catalytic_Converter (V : in Motorcycle) return Boolean;
   function Emissions_Produced  (V : in Motorcycle) return Emission_Measure;

   --
                          
   type Automobile is new Motorcycle with
      record
         Passenger_Capacity : Integer;
      end record;

   -- Function Engine_Size inherited from parent (Motorcycle).
   -- Primitive operations (Overridden).
   function Catalytic_Converter (V : in Automobile) return Boolean;
   function Emissions_Produced  (V : in Automobile) return Emission_Measure;
                          
   --

   type Truck is new Automobile with
      record
         Hauling_Capacity : Natural;
      end record;

   -- Function Engine_Size inherited twice.
   -- Function Catalytic_Converter inherited from parent (Automobile).
   -- Primitive operation (Overridden).
   function Emissions_Produced  (V : in Truck) return Emission_Measure;

end C392002_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body c392002_0 is

   --
   -- Primitive operations for Motorcycle.
   --

   function Engine_Size         (V : in Motorcycle) return Cubic_Inches is
   begin
      return (V.Size_Of_Engine);
   end Engine_Size;


   function Catalytic_Converter (V : in Motorcycle) return Boolean is
   begin
      return (False);
   end Catalytic_Converter;


   function Emissions_Produced  (V : in Motorcycle) return Emission_Measure is
   begin
      return 100.00;
   end Emissions_Produced;

   --
   -- Overridden operations for Automobile type.
   --

   function Catalytic_Converter (V : in Automobile) return Boolean is
   begin
      return (True);
   end Catalytic_Converter;


   function Emissions_Produced  (V : in Automobile) return Emission_Measure is
   begin
      return 200.00;
   end Emissions_Produced;

   --
   -- Overridden operation for Truck type.
   --

   function Emissions_Produced  (V : in Truck) return Emission_Measure is
   begin
      return 300.00;
   end Emissions_Produced;
                     
end C392002_0;

--------------------------------------------------------------------- C392002

with C392002_0;        -- with Vehicle_Simulation;
with Report;

procedure C392002 is  

   type Decade                     is (c1970, c1980, c1990);
   type Vehicle_Emissions          is digits 6;
   type Engine_Emissions_by_Decade is array (Decade) of Vehicle_Emissions;
   subtype Engine_Size             is Integer range 100 .. 1000;

   Five_Tons                  : constant Natural := 10000;
   Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8;
   Truck_Adjustment_Factor    : constant Vehicle_Emissions := 1.2;


   Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00,
                                                           c1980 =>  8.00,
                                                           c1990 =>  5.00);

   -- Instantiate generic package for 1970 simulation.

   package Sim_1970 is new C392002_0
     (Cubic_Inches                    => Engine_Size,
      Emission_Measure                => Vehicle_Emissions,
      Emissions_Per_Engine_Cubic_Inch => Engine_Emission_Factor (c1970));


   -- Declare and initialize vehicle objects.

   Cycle_1970 : Sim_1970.Motorcycle := (Weight         => 400, 
                                        Wheels         =>   2,
                                        Size_Of_Engine => 100);

   Auto_1970  : Sim_1970.Automobile := (2000, 4, 500, 5);

   Truck_1970 : Sim_1970.Truck      := (Weight             => 5000, 
                                        Wheels             => 18, 
                                        Size_Of_Engine     => 1000, 
                                        Passenger_Capacity => 2, 
                                        Hauling_Capacity   => Five_Tons);

   -- Function Get_Engine_Size performs a dispatching call on a
   -- primitive operation that has been defined for an ancestor type and 
   -- inherited by each type derived from the ancestor.

   function Get_Engine_Size (V : in Sim_1970.Vehicle'Class) 
     return Engine_Size is
   begin
     return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag.
   end Get_Engine_Size;
 

   -- Function Catalytic_Converter_Present performs a dispatching call on 
   -- a primitive operation that has been defined for an ancestor type, 
   -- overridden in the parent extended type, and inherited by the subsequent 
   -- extended type.

   function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class)
     return Boolean is
   begin
      return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag.
   end Catalytic_Converter_Present;


   -- Function Air_Quality_Measure performs a dispatching call on 
   -- a primitive operation that has been defined for an ancestor type, and
   -- overridden in each subsequent extended type.

   function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class)
     return Vehicle_Emissions is
   begin
      return (Sim_1970.Emissions_Produced (V));  -- Dispatch according to tag.
   end Air_Quality_Measure;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

begin  -- Main test procedure.

   Report.Test ("C392002",  "Check that the use of a class-wide parameter "
                          & "allows for proper dispatching where root type "
                          & "and extended types are declared in the same "
                          & "generic package" );

   if (Get_Engine_Size (Cycle_1970) /=  100) or
      (Get_Engine_Size (Auto_1970)  /=  500) or
      (Get_Engine_Size (Truck_1970) /= 1000) 
   then
      Report.Failed ("Failed dispatch to Get_Engine_Size");
   end if;

   if Catalytic_Converter_Present (Cycle_1970)    or
      not Catalytic_Converter_Present (Auto_1970) or
      not Catalytic_Converter_Present (Truck_1970)
   then
      Report.Failed ("Failed dispatch to Catalytic_Converter_Present");
   end if;

   if ((Air_Quality_Measure (Cycle_1970) /= 100.00) or
       (Air_Quality_Measure (Auto_1970)  /= 200.00) or
       (Air_Quality_Measure (Truck_1970) /= 300.00)) 
   then
      Report.Failed ("Failed dispatch to Air_Quality_Measure");
   end if;

   Report.Result;

end C392002;