diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392002.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392002.a | 349 |
1 files changed, 0 insertions, 349 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392002.a b/gcc/testsuite/ada/acats/tests/c3/c392002.a deleted file mode 100644 index 41493c22779..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392002.a +++ /dev/null @@ -1,349 +0,0 @@ --- 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; |