OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C390003.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 for a subtype S of a tagged type T, S'Class denotes a
28
--     class-wide subtype.  Check that T'Tag denotes the tag of the type T,
29
--     and that, for a class-wide tagged type X, X'Tag denotes the tag of X.
30
--     Check that the tags of stand alone objects, record and array
31
--     components, aggregates, and formal parameters identify their type.
32
--     Check that the tag of a value of a formal parameter is that of the
33
--     actual parameter, even if the actual is passed by a view conversion.
34
--
35
-- TEST DESCRIPTION:
36
--     This test defines a class hierarchy (based on C390002) and
37
--     uses it to determine the correctness of the resulting tag
38
--     information generated by the compiler.  A type is defined in the
39
--     class which contains components of the class as part of its
40
--     definition.  This is to reduce the overall number of types
41
--     required, and to achieve the required nesting to accomplish
42
--     this test.  The model is that of a car carrier truck; both car
43
--     and truck being in the class of Vehicle.
44
--
45
--      Class Hierarchy:
46
--                         Vehicle - - - - - - - (Bicycle)
47
--                        /   |   \               /      \
48
--                   Truck   Car   Q_Machine   Tandem  Motorcycle
49
--                     |
50
--                Auto_Carrier
51
--      Contains:
52
--                Auto_Carrier( Car )
53
--                Q_Machine( Car, Motorcycle )
54
--
55
--
56
--
57
-- CHANGE HISTORY:
58
--      06 Dec 94   SAIC    ACVC 2.0
59
--      19 Dec 94   SAIC    Removed ARM references from objective text.
60
--      20 Dec 94   SAIC    Replaced three unnecessary extension
61
--                          aggregates with simple aggregates.
62
--      16 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
63
--
64
--!
65
 
66
----------------------------------------------------------------- C390003_1
67
 
68
with Ada.Tags;
69
package C390003_1 is -- Vehicle
70
 
71
  type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy);
72
  type States  is (Good, Flat, Worn);
73
 
74
  type Wheel_List is array(Positive range <>) of States;
75
 
76
  type Object(Wheels: Positive) is tagged record
77
    Wheel_State : Wheel_List(1..Wheels);
78
  end record;
79
 
80
  procedure TC_Validate( It: Object; Key: TC_Keys );
81
  procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag );
82
 
83
  procedure Create( The_Vehicle : in out Object; Tyres : in States );
84
  procedure Rotate( The_Vehicle : in out Object );
85
  function  Wheels( The_Vehicle : Object ) return Positive;
86
 
87
end C390003_1; -- Vehicle;
88
 
89
----------------------------------------------------------------- C390003_2
90
 
91
with C390003_1;
92
package C390003_2 is -- Motivators
93
 
94
  package Vehicle renames C390003_1;
95
  subtype Bicycle is Vehicle.Object(2);  -- constrained subtype
96
 
97
  type Motorcycle is new Bicycle with record
98
    Displacement : Natural;
99
  end record;
100
  procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys );
101
 
102
  type Tandem is new Bicycle with null record;
103
  procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys );
104
 
105
  type Car is new Vehicle.Object(4) with  -- extended, constrained
106
    record
107
      Displacement : Natural;
108
    end record;
109
  procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys );
110
 
111
  type Truck is new Vehicle.Object with  -- extended, unconstrained
112
    record
113
      Tare : Natural;
114
    end record;
115
  procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys );
116
 
117
end C390003_2; -- Motivators;
118
 
119
----------------------------------------------------------------- C390003_3
120
 
121
with C390003_1;
122
with C390003_2;
123
package C390003_3 is -- Special_Trucks
124
  package Vehicle    renames C390003_1;
125
  package Motivators renames C390003_2;
126
  Max_Cars_On_Vehicle : constant := 6;
127
  type Cargo_Index is range 0..Max_Cars_On_Vehicle;
128
  type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle)
129
                of Motivators.Car;
130
  type Auto_Carrier is new Motivators.Truck(18) with
131
    record
132
      Load_Count : Cargo_Index := 0;
133
      Payload    : Cargo;
134
    end record;
135
  procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys );
136
  procedure Load  ( The_Car : in     Motivators.Car;
137
                    Onto    : in out Auto_Carrier);
138
  procedure Unload( The_Car :    out Motivators.Car;
139
                    Off_of   : in out Auto_Carrier);
140
end C390003_3;
141
 
142
----------------------------------------------------------------- C390003_4
143
 
144
with C390003_1;
145
with C390003_2;
146
package C390003_4 is -- James_Bond
147
 
148
  package Vehicle   renames C390003_1;
149
  package Motivators renames C390003_2;
150
 
151
  type Q_Machine is new Vehicle.Object(4) with record
152
    Car_Part  : Motivators.Car;
153
    Bike_Part : Motivators.Motorcycle;
154
  end record;
155
  procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys );
156
 
157
end C390003_4;
158
 
159
----------------------------------------------------------------- C390003_1
160
 
161
with Report;
162
with Ada.Tags;
163
package body C390003_1 is -- Vehicle
164
 
165
  function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
166
 
167
  procedure TC_Validate( It: Object; Key: TC_Keys ) is
168
  begin
169
    if Key /= Veh then
170
      Report.Failed("Expected Veh Key");
171
    end if;
172
  end TC_Validate;
173
 
174
  procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is
175
  begin
176
    if It'Tag /= The_Tag then
177
      Report.Failed("Unexpected Tag for classwide formal");
178
    end if;
179
  end TC_Validate;
180
 
181
  procedure Create( The_Vehicle : in out Object; Tyres : in States ) is
182
  begin
183
    The_Vehicle.Wheel_State := ( others => Tyres );
184
  end Create;
185
 
186
  function  Wheels( The_Vehicle : Object ) return Positive is
187
  begin
188
    return The_Vehicle.Wheels;
189
  end Wheels;
190
 
191
  procedure Rotate( The_Vehicle : in out Object ) is
192
    Push : States;
193
    Pulled : States
194
         := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last);
195
  begin
196
    for Finger in
197
        The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop
198
      Push := The_Vehicle.Wheel_State(Finger);
199
      The_Vehicle.Wheel_State(Finger) := Pulled;
200
      Pulled := Push;
201
    end loop;
202
  end Rotate;
203
 
204
end C390003_1; -- Vehicle;
205
 
206
----------------------------------------------------------------- C390003_2
207
 
208
with Ada.Tags;
209
with Report;
210
package body C390003_2 is -- Motivators
211
 
212
  function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
213
  function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
214
 
215
  procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is
216
  begin
217
    if Key /= Vehicle.MC then
218
      Report.Failed("Expected MC Key");
219
    end if;
220
  end TC_Validate;
221
 
222
  procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is
223
  begin
224
    if Key /= Vehicle.Tand then
225
      Report.Failed("Expected Tand Key");
226
    end if;
227
  end TC_Validate;
228
 
229
  procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is
230
  begin
231
    if Key /= Vehicle.Car then
232
      Report.Failed("Expected Car Key");
233
    end if;
234
  end TC_Validate;
235
 
236
  procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is
237
  begin
238
    if Key /= Vehicle.Truk then
239
      Report.Failed("Expected Truk Key");
240
    end if;
241
  end TC_Validate;
242
end C390003_2; -- Motivators;
243
 
244
----------------------------------------------------------------- C390003_3
245
 
246
with Ada.Tags;
247
with Report;
248
package body C390003_3 is -- Special_Trucks
249
 
250
  function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
251
  function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
252
 
253
  procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is
254
  begin
255
    if Key /= Vehicle.Heavy then
256
      Report.Failed("Expected Heavy Key");
257
    end if;
258
  end TC_Validate;
259
 
260
  procedure Load  ( The_Car : in     Motivators.Car;
261
                    Onto    : in out Auto_Carrier) is
262
  begin
263
    Onto.Load_Count := Onto.Load_Count +1;
264
    Onto.Payload(Onto.Load_Count) := The_Car;
265
  end Load;
266
  procedure Unload( The_Car :    out Motivators.Car;
267
                    Off_of   : in out Auto_Carrier) is
268
  begin
269
    The_Car := Off_of.Payload(Off_of.Load_Count);
270
    Off_of.Load_Count := Off_of.Load_Count -1;
271
  end Unload;
272
 
273
end C390003_3;
274
 
275
----------------------------------------------------------------- C390003_4
276
 
277
with Report, Ada.Tags;
278
package body C390003_4 is -- James_Bond
279
 
280
  function "="(A,B: Ada.Tags.Tag)    return Boolean renames Ada.Tags."=";
281
  function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
282
 
283
  procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is
284
  begin
285
    if Key /= Vehicle.Q then
286
      Report.Failed("Expected Q Key");
287
    end if;
288
  end TC_Validate;
289
 
290
end C390003_4;
291
 
292
------------------------------------------------------------------- C390003
293
 
294
with Report;
295
with C390003_1;
296
with C390003_2;
297
with C390003_3;
298
with C390003_4;
299
procedure C390003 is
300
 
301
  package Vehicle        renames C390003_1;  use Vehicle;
302
  package Motivators     renames C390003_2;
303
  package Special_Trucks renames C390003_3;
304
  package James_Bond     renames C390003_4;
305
 
306
  -- The cast, in order of complexity:
307
 
308
  Pennys_Bike : Motivators.Bicycle;
309
  Weekender   : Motivators.Tandem;
310
  Qs_Moped    : Motivators.Motorcycle;
311
  Ms_Limo     : Motivators.Car;
312
  Yard_Van    : Motivators.Truck(8);
313
  Specter_X   : Special_Trucks.Auto_Carrier;
314
  Gen_II      : James_Bond.Q_Machine;
315
 
316
 
317
  -- Check compatibility with the corresponding class wide type.
318
 
319
  procedure Vehicle_Shop( It  : in out Vehicle.Object'Class;
320
                          Key : in     Vehicle.TC_Keys ) is
321
 
322
    -- Check that Subtype'Class is defined for tagged subtypes.
323
    procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is
324
    begin
325
        -- Dispatch to appropriate TC_Validate
326
      Vehicle.TC_Validate( Bike, Key );
327
    end Bike_Shop;
328
 
329
  begin
330
    Vehicle.TC_Validate( It, Key );
331
    if Vehicle.Wheels( It ) = 2 then
332
      Bike_Shop( It );  -- only call Bike_Shop when It has 2 wheels
333
    end if;
334
  end Vehicle_Shop;
335
 
336
begin  -- Main test procedure.
337
 
338
  Report.Test ("C390003", "Check that for a subtype S of a tagged type " &
339
               "T, S'Class denotes a class-wide subtype.  Check that " &
340
               "T'Tag denotes the tag of the type T, and that, for a " &
341
               "class-wide tagged type X, X'Tag denotes the tag of X.  " &
342
               "Check that the tags of stand alone objects, record and " &
343
               "array components, aggregates, and formal parameters " &
344
               "identify their type. Check that the tag of a value of a " &
345
               "formal parameter is that of the actual parameter, even " &
346
               "if the actual is passed by a view conversion" );
347
 
348
--     Check that the tags of stand alone objects, record and array
349
--     components, aggregates, and formal parameters identify their type.
350
--     Check that the tag of a value of a formal parameter is that of the
351
--     actual parameter, even if the actual is passed by a view conversion.
352
 
353
  Vehicle_Shop( Pennys_Bike,          Veh );
354
  Vehicle_Shop( Weekender,            Tand );
355
  Vehicle_Shop( Qs_Moped,             MC );
356
  Vehicle_Shop( Ms_Limo,              Car );
357
  Vehicle_Shop( Yard_Van,             Truk );
358
  Vehicle_Shop( Specter_X,            Heavy );
359
  Vehicle_Shop( Specter_X.Payload(1), Car );
360
  Vehicle_Shop( Gen_II,               Q );
361
  Vehicle_Shop( Gen_II.Car_Part,      Car );
362
  Vehicle_Shop( Gen_II.Bike_Part,     MC );
363
 
364
  Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag );
365
  Vehicle.TC_Validate( Weekender,   Motivators.Tandem'Tag );
366
  Vehicle.TC_Validate( Qs_Moped,    Motivators.Motorcycle'Tag );
367
  Vehicle.TC_Validate( Ms_Limo,     Motivators.Car'Tag );
368
  Vehicle.TC_Validate( Yard_Van,    Motivators.Truck'Tag );
369
  Vehicle.TC_Validate( Specter_X,   Special_Trucks.Auto_Carrier'Tag );
370
  Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag );
371
  Vehicle.TC_Validate( Gen_II,              James_Bond.Q_Machine'Tag );
372
  Vehicle.TC_Validate( Gen_II.Car_Part,     Motivators.Car'Tag );
373
  Vehicle.TC_Validate( Gen_II.Bike_Part,    Motivators.Motorcycle'Tag );
374
 
375
-- Check the tag generated for an aggregate.
376
 
377
  Rentals: declare
378
    Mikes_Rental : Vehicle.Object'Class :=
379
                     Vehicle.Object'( 3, (Good, Flat, Worn));
380
    Diannes_Car  : Vehicle.Object'Class :=
381
                      Motivators.Tandem'( Wheels      => 2,
382
                                          Wheel_State => (Good, Good) );
383
    Jims_Bike    : Vehicle.Object'Class :=
384
                      Motivators.Motorcycle'( Pennys_Bike
385
                                              with Displacement => 350 );
386
    Bills_Limo   : Vehicle.Object'Class :=
387
                      Motivators.Car'( Wheels       => 4,
388
                                       Wheel_State  => (others => Good),
389
                                       Displacement => 282 );
390
    Alans_Car    : Vehicle.Object'Class :=
391
                      Motivators.Truck'( 18, (others => Worn),
392
                                         Tare => 5_500 );
393
    Pats_Truck   : Vehicle.Object'Class := Specter_X;
394
    Keiths_Car   : Vehicle.Object'Class := Gen_II;
395
    Isaacs_Bus   : Vehicle.Object'Class := Keiths_Car;
396
 
397
  begin
398
    Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag );
399
    Vehicle.TC_Validate( Diannes_Car,  Motivators.Tandem'Tag );
400
    Vehicle.TC_Validate( Jims_Bike,    Motivators.Motorcycle'Tag );
401
    Vehicle.TC_Validate( Bills_Limo,   Motivators.Car'Tag );
402
    Vehicle.TC_Validate( Alans_Car,    Motivators.Truck'Tag );
403
    Vehicle.TC_Validate( Pats_Truck,   Special_Trucks.Auto_Carrier'Tag );
404
    Vehicle.TC_Validate( Keiths_Car,   James_Bond.Q_Machine'Tag );
405
  end Rentals;
406
 
407
-- Check the tag of parameters.
408
-- Check that the tag is not affected by view conversion.
409
 
410
  Vehicle.TC_Validate( Vehicle.Object( Gen_II  ), James_Bond.Q_Machine'Tag );
411
  Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag );
412
  Vehicle.TC_Validate( Motivators.Bicycle( Weekender ),
413
                       Motivators.Tandem'Tag );
414
  Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ),
415
                       Motivators.Motorcycle'Tag );
416
 
417
  Report.Result;
418
 
419
end C390003;

powered by: WebSVN 2.1.0

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