| -- 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; |
