3 -- Grant of Unlimited Rights
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7 -- unlimited rights in the software and documentation contained herein.
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
9 -- this public release, the Government intends to confer upon all
10 -- recipients unlimited rights equal to those held by the Government.
11 -- These rights include rights to use, duplicate, release or disclose the
12 -- released technical data and computer software in whole or in part, in
13 -- any manner and for any purpose whatsoever, and to have or permit others
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
27 -- Check that the use of a class-wide formal parameter allows for the
28 -- proper dispatching of objects to the appropriate implementation of
29 -- a primitive operation. Check this in the case where the root tagged
30 -- type is defined in a generic package, and the type derived from it is
31 -- defined in that same generic package.
34 -- Declare a root tagged type, and some associated primitive operations.
35 -- Extend the root type, and override one or more primitive operations,
36 -- inheriting the other primitive operations from the root type.
37 -- Derive from the extended type, again overriding some primitive
38 -- operations and inheriting others (including some that the parent
40 -- Define a subprogram with a class-wide parameter, inside of which is a
41 -- call on a dispatching primitive operation. These primitive operations
42 -- modify global variables (the class-wide parameter has mode IN).
44 -- The following hierarchy of tagged types and primitive operations is
45 -- utilized in this test:
48 -- type Vehicle (root)
54 -- | Catalytic_Converter
55 -- | Emissions_Produced
57 -- type Automobile (extended from Motorcycle)
60 -- | (Engine_Size) (inherited)
61 -- | Catalytic_Converter (overridden)
62 -- | Emissions_Produced (overridden)
64 -- type Truck (extended from Automobile)
67 -- | (Engine_Size) (inherited twice - Motorcycle)
68 -- | (Catalytic_Converter) (inherited - Automobile)
69 -- | Emissions_Produced (overridden)
72 -- In this test, we are concerned with the following selection of dispatching
73 -- calls, accomplished with the use of a Vehicle'Class IN procedure
77 -- Prim. Op \ Motorcycle Automobile Truck
78 -- \------------------------------------------------
79 -- Engine_Size | X X X
80 -- Catalytic_Converter | X X X
81 -- Emissions_Produced | X X X
85 -- The location of the declaration and derivation of the root and extended
86 -- types will be varied over a series of tests. Locations of declaration
87 -- and derivation for a particular test are marked with an asterisk (*).
91 -- Declared in package.
92 -- * Declared in generic package.
96 -- * Derived in parent location.
97 -- Derived in a nested package.
98 -- Derived in a nested subprogram.
99 -- Derived in a nested generic package.
100 -- Derived in a separate package.
101 -- Derived in a separate visible child package.
102 -- Derived in a separate private child package.
104 -- Primitive Operations:
106 -- * Procedures with same parameter profile.
107 -- Procedures with different parameter profile.
108 -- * Functions with same parameter profile.
109 -- Functions with different parameter profile.
110 -- * Mixture of Procedures and Functions.
114 -- 06 Dec 94 SAIC ACVC 2.0
115 -- 09 May 96 SAIC Made single-file for 2.1
119 ------------------------------------------------------------------- C392002_0
121 -- Declare the root and extended types, along with their primitive
122 -- operations in a generic package.
126 type Cubic_Inches
is range <>;
127 type Emission_Measure
is digits <>;
128 Emissions_per_Engine_Cubic_Inch
: Emission_Measure
;
130 package C392002_0
is -- package Vehicle_Simulation
133 -- Equipment types and their primitive operations.
138 type Vehicle
is abstract tagged
144 -- Abstract operations of type Vehicle.
145 function Engine_Size
(V
: in Vehicle
) return Cubic_Inches
147 function Catalytic_Converter
(V
: in Vehicle
) return Boolean
149 function Emissions_Produced
(V
: in Vehicle
) return Emission_Measure
154 type Motorcycle
is new Vehicle
with
156 Size_Of_Engine
: Cubic_Inches
;
159 -- Primitive operations of type Motorcycle.
160 function Engine_Size
(V
: in Motorcycle
) return Cubic_Inches
;
161 function Catalytic_Converter
(V
: in Motorcycle
) return Boolean;
162 function Emissions_Produced
(V
: in Motorcycle
) return Emission_Measure
;
166 type Automobile
is new Motorcycle
with
168 Passenger_Capacity
: Integer;
171 -- Function Engine_Size inherited from parent (Motorcycle).
172 -- Primitive operations (Overridden).
173 function Catalytic_Converter
(V
: in Automobile
) return Boolean;
174 function Emissions_Produced
(V
: in Automobile
) return Emission_Measure
;
178 type Truck
is new Automobile
with
180 Hauling_Capacity
: Natural;
183 -- Function Engine_Size inherited twice.
184 -- Function Catalytic_Converter inherited from parent (Automobile).
185 -- Primitive operation (Overridden).
186 function Emissions_Produced
(V
: in Truck
) return Emission_Measure
;
190 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
192 package body c392002_0
is
195 -- Primitive operations for Motorcycle.
198 function Engine_Size
(V
: in Motorcycle
) return Cubic_Inches
is
200 return (V
.Size_Of_Engine
);
204 function Catalytic_Converter
(V
: in Motorcycle
) return Boolean is
207 end Catalytic_Converter
;
210 function Emissions_Produced
(V
: in Motorcycle
) return Emission_Measure
is
213 end Emissions_Produced
;
216 -- Overridden operations for Automobile type.
219 function Catalytic_Converter
(V
: in Automobile
) return Boolean is
222 end Catalytic_Converter
;
225 function Emissions_Produced
(V
: in Automobile
) return Emission_Measure
is
228 end Emissions_Produced
;
231 -- Overridden operation for Truck type.
234 function Emissions_Produced
(V
: in Truck
) return Emission_Measure
is
237 end Emissions_Produced
;
241 --------------------------------------------------------------------- C392002
243 with C392002_0
; -- with Vehicle_Simulation;
248 type Decade
is (c1970
, c1980
, c1990
);
249 type Vehicle_Emissions
is digits 6;
250 type Engine_Emissions_by_Decade
is array (Decade
) of Vehicle_Emissions
;
251 subtype Engine_Size
is Integer range 100 .. 1000;
253 Five_Tons
: constant Natural := 10000;
254 Catalytic_Converter_Offset
: constant Vehicle_Emissions
:= 0.8;
255 Truck_Adjustment_Factor
: constant Vehicle_Emissions
:= 1.2;
258 Engine_Emission_Factor
: Engine_Emissions_by_Decade
:= (c1970
=> 10.00,
262 -- Instantiate generic package for 1970 simulation.
264 package Sim_1970
is new C392002_0
265 (Cubic_Inches
=> Engine_Size
,
266 Emission_Measure
=> Vehicle_Emissions
,
267 Emissions_Per_Engine_Cubic_Inch
=> Engine_Emission_Factor
(c1970
));
270 -- Declare and initialize vehicle objects.
272 Cycle_1970
: Sim_1970
.Motorcycle
:= (Weight
=> 400,
274 Size_Of_Engine
=> 100);
276 Auto_1970
: Sim_1970
.Automobile
:= (2000, 4, 500, 5);
278 Truck_1970
: Sim_1970
.Truck
:= (Weight
=> 5000,
280 Size_Of_Engine
=> 1000,
281 Passenger_Capacity
=> 2,
282 Hauling_Capacity
=> Five_Tons
);
284 -- Function Get_Engine_Size performs a dispatching call on a
285 -- primitive operation that has been defined for an ancestor type and
286 -- inherited by each type derived from the ancestor.
288 function Get_Engine_Size
(V
: in Sim_1970
.Vehicle
'Class)
289 return Engine_Size
is
291 return (Sim_1970
.Engine_Size
(V
)); -- Dispatch according to tag.
295 -- Function Catalytic_Converter_Present performs a dispatching call on
296 -- a primitive operation that has been defined for an ancestor type,
297 -- overridden in the parent extended type, and inherited by the subsequent
300 function Catalytic_Converter_Present
(V
: in Sim_1970
.Vehicle
'Class)
303 return (Sim_1970
.Catalytic_Converter
(V
)); -- Dispatch according to tag.
304 end Catalytic_Converter_Present
;
307 -- Function Air_Quality_Measure performs a dispatching call on
308 -- a primitive operation that has been defined for an ancestor type, and
309 -- overridden in each subsequent extended type.
311 function Air_Quality_Measure
(V
: in Sim_1970
.Vehicle
'Class)
312 return Vehicle_Emissions
is
314 return (Sim_1970
.Emissions_Produced
(V
)); -- Dispatch according to tag.
315 end Air_Quality_Measure
;
317 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
319 begin -- Main test procedure.
321 Report
.Test
("C392002", "Check that the use of a class-wide parameter "
322 & "allows for proper dispatching where root type "
323 & "and extended types are declared in the same "
324 & "generic package" );
326 if (Get_Engine_Size
(Cycle_1970
) /= 100) or
327 (Get_Engine_Size
(Auto_1970
) /= 500) or
328 (Get_Engine_Size
(Truck_1970
) /= 1000)
330 Report
.Failed
("Failed dispatch to Get_Engine_Size");
333 if Catalytic_Converter_Present
(Cycle_1970
) or
334 not Catalytic_Converter_Present
(Auto_1970
) or
335 not Catalytic_Converter_Present
(Truck_1970
)
337 Report
.Failed
("Failed dispatch to Catalytic_Converter_Present");
340 if ((Air_Quality_Measure
(Cycle_1970
) /= 100.00) or
341 (Air_Quality_Measure
(Auto_1970
) /= 200.00) or
342 (Air_Quality_Measure
(Truck_1970
) /= 300.00))
344 Report
.Failed
("Failed dispatch to Air_Quality_Measure");