OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c392002.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392002.A
2
--
3
--                             Grant of Unlimited Rights
4
--
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
14
--     to do so.
15
--
16
--                                    DISCLAIMER
17
--
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.
24
--*
25
--
26
-- OBJECTIVE:
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.
32
--
33
-- TEST DESCRIPTION:
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
39
--      inherited).
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).
43
--
44
--  The following hierarchy of tagged types and primitive operations is
45
--  utilized in this test:
46
--
47
--
48
--    type Vehicle (root)
49
--            |
50
--    type Motorcycle
51
--            |
52
--            | Operations
53
--            |   Engine_Size
54
--            |   Catalytic_Converter
55
--            |   Emissions_Produced
56
--            |
57
--    type Automobile (extended from Motorcycle)
58
--            |
59
--            | Operations
60
--            |   (Engine_Size)       (inherited)
61
--            |   Catalytic_Converter (overridden)
62
--            |   Emissions_Produced  (overridden)
63
--            |
64
--    type Truck (extended from Automobile)
65
--            |
66
--            | Operations
67
--            |   (Engine_Size)         (inherited twice - Motorcycle)
68
--            |   (Catalytic_Converter) (inherited - Automobile)
69
--            |   Emissions_Produced    (overridden)
70
--
71
--
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
74
-- parameter :
75
--
76
--                       \ Type
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
82
--
83
--
84
--
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 (*).
88
--
89
-- Root type:
90
--
91
--       Declared in package.
92
--    *  Declared in generic package.
93
--
94
-- Extended types:
95
--
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.
103
--
104
-- Primitive Operations:
105
--
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.
111
--
112
--
113
-- CHANGE HISTORY:
114
--      06 Dec 94   SAIC    ACVC 2.0
115
--      09 May 96   SAIC    Made single-file for 2.1
116
--
117
--!
118
 
119
------------------------------------------------------------------- C392002_0
120
 
121
-- Declare the root and extended types, along with their primitive
122
-- operations in a generic package.
123
 
124
generic
125
 
126
   type Cubic_Inches     is range <>;
127
   type Emission_Measure is digits <>;
128
   Emissions_per_Engine_Cubic_Inch : Emission_Measure;
129
 
130
package C392002_0 is       -- package Vehicle_Simulation
131
 
132
   --
133
   -- Equipment types and their primitive operations.
134
   --
135
 
136
   -- Root type.
137
 
138
   type Vehicle is abstract tagged
139
      record
140
         Weight : Integer;
141
         Wheels : Positive;
142
      end record;
143
 
144
   -- Abstract operations of type Vehicle.
145
   function Engine_Size         (V : in Vehicle) return Cubic_Inches
146
            is abstract;
147
   function Catalytic_Converter (V : in Vehicle) return Boolean
148
            is abstract;
149
   function Emissions_Produced  (V : in Vehicle) return Emission_Measure
150
            is abstract;
151
 
152
   --
153
 
154
   type Motorcycle is new Vehicle with
155
      record
156
         Size_Of_Engine : Cubic_Inches;
157
      end record;
158
 
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;
163
 
164
   --
165
 
166
   type Automobile is new Motorcycle with
167
      record
168
         Passenger_Capacity : Integer;
169
      end record;
170
 
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;
175
 
176
   --
177
 
178
   type Truck is new Automobile with
179
      record
180
         Hauling_Capacity : Natural;
181
      end record;
182
 
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;
187
 
188
end C392002_0;
189
 
190
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
191
 
192
package body c392002_0 is
193
 
194
   --
195
   -- Primitive operations for Motorcycle.
196
   --
197
 
198
   function Engine_Size         (V : in Motorcycle) return Cubic_Inches is
199
   begin
200
      return (V.Size_Of_Engine);
201
   end Engine_Size;
202
 
203
 
204
   function Catalytic_Converter (V : in Motorcycle) return Boolean is
205
   begin
206
      return (False);
207
   end Catalytic_Converter;
208
 
209
 
210
   function Emissions_Produced  (V : in Motorcycle) return Emission_Measure is
211
   begin
212
      return 100.00;
213
   end Emissions_Produced;
214
 
215
   --
216
   -- Overridden operations for Automobile type.
217
   --
218
 
219
   function Catalytic_Converter (V : in Automobile) return Boolean is
220
   begin
221
      return (True);
222
   end Catalytic_Converter;
223
 
224
 
225
   function Emissions_Produced  (V : in Automobile) return Emission_Measure is
226
   begin
227
      return 200.00;
228
   end Emissions_Produced;
229
 
230
   --
231
   -- Overridden operation for Truck type.
232
   --
233
 
234
   function Emissions_Produced  (V : in Truck) return Emission_Measure is
235
   begin
236
      return 300.00;
237
   end Emissions_Produced;
238
 
239
end C392002_0;
240
 
241
--------------------------------------------------------------------- C392002
242
 
243
with C392002_0;        -- with Vehicle_Simulation;
244
with Report;
245
 
246
procedure C392002 is
247
 
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;
252
 
253
   Five_Tons                  : constant Natural := 10000;
254
   Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8;
255
   Truck_Adjustment_Factor    : constant Vehicle_Emissions := 1.2;
256
 
257
 
258
   Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00,
259
                                                           c1980 =>  8.00,
260
                                                           c1990 =>  5.00);
261
 
262
   -- Instantiate generic package for 1970 simulation.
263
 
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));
268
 
269
 
270
   -- Declare and initialize vehicle objects.
271
 
272
   Cycle_1970 : Sim_1970.Motorcycle := (Weight         => 400,
273
                                        Wheels         =>   2,
274
                                        Size_Of_Engine => 100);
275
 
276
   Auto_1970  : Sim_1970.Automobile := (2000, 4, 500, 5);
277
 
278
   Truck_1970 : Sim_1970.Truck      := (Weight             => 5000,
279
                                        Wheels             => 18,
280
                                        Size_Of_Engine     => 1000,
281
                                        Passenger_Capacity => 2,
282
                                        Hauling_Capacity   => Five_Tons);
283
 
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.
287
 
288
   function Get_Engine_Size (V : in Sim_1970.Vehicle'Class)
289
     return Engine_Size is
290
   begin
291
     return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag.
292
   end Get_Engine_Size;
293
 
294
 
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
298
   -- extended type.
299
 
300
   function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class)
301
     return Boolean is
302
   begin
303
      return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag.
304
   end Catalytic_Converter_Present;
305
 
306
 
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.
310
 
311
   function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class)
312
     return Vehicle_Emissions is
313
   begin
314
      return (Sim_1970.Emissions_Produced (V));  -- Dispatch according to tag.
315
   end Air_Quality_Measure;
316
 
317
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
318
 
319
begin  -- Main test procedure.
320
 
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" );
325
 
326
   if (Get_Engine_Size (Cycle_1970) /=  100) or
327
      (Get_Engine_Size (Auto_1970)  /=  500) or
328
      (Get_Engine_Size (Truck_1970) /= 1000)
329
   then
330
      Report.Failed ("Failed dispatch to Get_Engine_Size");
331
   end if;
332
 
333
   if Catalytic_Converter_Present (Cycle_1970)    or
334
      not Catalytic_Converter_Present (Auto_1970) or
335
      not Catalytic_Converter_Present (Truck_1970)
336
   then
337
      Report.Failed ("Failed dispatch to Catalytic_Converter_Present");
338
   end if;
339
 
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))
343
   then
344
      Report.Failed ("Failed dispatch to Air_Quality_Measure");
345
   end if;
346
 
347
   Report.Result;
348
 
349
end C392002;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.