|
111
|
1 -- C3A0013.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 a general access type object may reference allocated
|
|
|
28 -- pool objects as well as aliased objects. (3,4)
|
|
|
29 -- Check that formal parameters of tagged types are implicitly
|
|
|
30 -- defined as aliased; check that the 'Access of these formal
|
|
|
31 -- parameters designates the correct object with the correct
|
|
|
32 -- tag. (5)
|
|
|
33 -- Check that the current instance of a limited type is defined as
|
|
|
34 -- aliased. (5)
|
|
|
35 --
|
|
|
36 -- TEST DESCRIPTION:
|
|
|
37 -- This test takes from the hierarchy defined in C390003; making
|
|
|
38 -- the root type Vehicle limited private. It also shifts the
|
|
|
39 -- abstraction to include the notion of a transmission, an object
|
|
|
40 -- which is contained within any vehicle. Using an access
|
|
|
41 -- discriminant, any subprogram which operates on a transmission
|
|
|
42 -- may also reference the vehicle in which it is installed.
|
|
|
43 --
|
|
|
44 -- Class Hierarchy:
|
|
|
45 -- Vehicle Transmission
|
|
|
46 -- / \
|
|
|
47 -- Truck Car
|
|
|
48 --
|
|
|
49 -- Contains:
|
|
|
50 -- Vehicle( Transmission )
|
|
|
51 --
|
|
|
52 --
|
|
|
53 --
|
|
|
54 -- CHANGE HISTORY:
|
|
|
55 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
56 -- 16 Dec 94 SAIC Fixed accessibility problems
|
|
|
57 --
|
|
|
58 --!
|
|
|
59
|
|
|
60 package C3A0013_1 is
|
|
|
61 type Vehicle is tagged limited private;
|
|
|
62 type Vehicle_ID is access all Vehicle'Class;
|
|
|
63
|
|
|
64 -- Constructors
|
|
|
65 procedure Create ( It : in out Vehicle;
|
|
|
66 Wheels : Natural := 4 );
|
|
|
67 -- Modifiers
|
|
|
68 procedure Accelerate ( It : in out Vehicle );
|
|
|
69 procedure Decelerate ( It : in out Vehicle );
|
|
|
70 procedure Up_Shift ( It : in out Vehicle );
|
|
|
71 procedure Stop ( It : in out Vehicle );
|
|
|
72
|
|
|
73 -- Selectors
|
|
|
74 function Speed ( It : Vehicle ) return Natural;
|
|
|
75 function Wheels ( It : Vehicle ) return Natural;
|
|
|
76 function Gear_Factor( It : Vehicle ) return Natural;
|
|
|
77
|
|
|
78 -- TC_Ops
|
|
|
79 procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural );
|
|
|
80
|
|
|
81 -- dispatching procedure used to check tag correctness
|
|
|
82 procedure TC_Validate( It : Vehicle;
|
|
|
83 TC_ID : Character);
|
|
|
84
|
|
|
85 private
|
|
|
86
|
|
|
87 type Transmission(Within: access Vehicle'Class) is limited record
|
|
|
88 Engaged : Boolean := False;
|
|
|
89 Gear : Integer range -1..5 := 0;
|
|
|
90 end record;
|
|
|
91
|
|
|
92 -- Current instance of a limited type is defined as aliased
|
|
|
93
|
|
|
94 type Vehicle is tagged limited record
|
|
|
95 Wheels: Natural;
|
|
|
96 Speed : Natural;
|
|
|
97 Power_Train: Transmission( Vehicle'Access );
|
|
|
98 end record;
|
|
|
99 end C3A0013_1;
|
|
|
100
|
|
|
101 with C3A0013_1;
|
|
|
102 package C3A0013_2 is
|
|
|
103 type Car is new C3A0013_1.Vehicle with private;
|
|
|
104 procedure TC_Validate( It : Car;
|
|
|
105 TC_ID : Character);
|
|
|
106 function Gear_Factor( It : Car ) return Natural;
|
|
|
107 private
|
|
|
108 type Car is new C3A0013_1.Vehicle with record
|
|
|
109 Displacement : Natural;
|
|
|
110 end record;
|
|
|
111 end C3A0013_2;
|
|
|
112
|
|
|
113 with C3A0013_1;
|
|
|
114 package C3A0013_3 is
|
|
|
115 type Truck is new C3A0013_1.Vehicle with private;
|
|
|
116 procedure TC_Validate( It : Truck;
|
|
|
117 TC_ID : Character);
|
|
|
118 function Gear_Factor( It : Truck ) return Natural;
|
|
|
119 private
|
|
|
120 type Truck is new C3A0013_1.Vehicle with record
|
|
|
121 Displacement : Natural;
|
|
|
122 end record;
|
|
|
123 end C3A0013_3;
|
|
|
124
|
|
|
125 with Report;
|
|
|
126 package body C3A0013_1 is
|
|
|
127
|
|
|
128 procedure Create ( It : in out Vehicle;
|
|
|
129 Wheels : Natural := 4 ) is
|
|
|
130 begin
|
|
|
131 It.Wheels := Wheels;
|
|
|
132 It.Speed := 0;
|
|
|
133 end Create;
|
|
|
134
|
|
|
135 procedure Accelerate( It : in out Vehicle ) is
|
|
|
136 begin
|
|
|
137 It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all );
|
|
|
138 end Accelerate;
|
|
|
139
|
|
|
140 procedure Decelerate( It : in out Vehicle ) is
|
|
|
141 begin
|
|
|
142 It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all );
|
|
|
143 end Decelerate;
|
|
|
144
|
|
|
145 procedure Stop ( It : in out Vehicle ) is
|
|
|
146 begin
|
|
|
147 It.Speed := 0;
|
|
|
148 It.Power_Train.Engaged := False;
|
|
|
149 end Stop;
|
|
|
150
|
|
|
151 function Gear_Factor( It : Vehicle ) return Natural is
|
|
|
152 begin
|
|
|
153 return It.Power_Train.Gear;
|
|
|
154 end Gear_Factor;
|
|
|
155
|
|
|
156 function Speed ( It : Vehicle ) return Natural is
|
|
|
157 begin
|
|
|
158 return It.Speed;
|
|
|
159 end Speed;
|
|
|
160
|
|
|
161 function Wheels ( It : Vehicle ) return Natural is
|
|
|
162 begin
|
|
|
163 return It.Wheels;
|
|
|
164 end Wheels;
|
|
|
165
|
|
|
166 -- formal tagged parameters are implicitly aliased
|
|
|
167
|
|
|
168 procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is
|
|
|
169 License: Vehicle_ID := It'Unchecked_Access;
|
|
|
170 begin
|
|
|
171 if Speed( License.all ) /= Speed_Trap then
|
|
|
172 Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap));
|
|
|
173 end if;
|
|
|
174 end TC_Validate;
|
|
|
175
|
|
|
176 procedure TC_Validate( It : Vehicle;
|
|
|
177 TC_ID : Character) is
|
|
|
178 begin
|
|
|
179 if TC_ID /= 'V' then
|
|
|
180 Report.Failed("Dispatched to Vehicle");
|
|
|
181 end if;
|
|
|
182 if Wheels( It ) /= 1 then
|
|
|
183 Report.Failed("Not a Vehicle");
|
|
|
184 end if;
|
|
|
185 end TC_Validate;
|
|
|
186
|
|
|
187 procedure Up_Shift( It: in out Vehicle ) is
|
|
|
188 begin
|
|
|
189 It.Power_Train.Gear := It.Power_Train.Gear +1;
|
|
|
190 It.Power_Train.Engaged := True;
|
|
|
191 Accelerate( It );
|
|
|
192 end Up_Shift;
|
|
|
193 end C3A0013_1;
|
|
|
194
|
|
|
195 with Report;
|
|
|
196 package body C3A0013_2 is
|
|
|
197
|
|
|
198 procedure TC_Validate( It : Car;
|
|
|
199 TC_ID : Character ) is
|
|
|
200 begin
|
|
|
201 if TC_ID /= 'C' then
|
|
|
202 Report.Failed("Dispatched to Car");
|
|
|
203 end if;
|
|
|
204 if Wheels( It ) /= 4 then
|
|
|
205 Report.Failed("Not a Car");
|
|
|
206 end if;
|
|
|
207 end TC_Validate;
|
|
|
208
|
|
|
209 function Gear_Factor( It : Car ) return Natural is
|
|
|
210 begin
|
|
|
211 return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2;
|
|
|
212 end Gear_Factor;
|
|
|
213
|
|
|
214 end C3A0013_2;
|
|
|
215
|
|
|
216 with Report;
|
|
|
217 package body C3A0013_3 is
|
|
|
218
|
|
|
219 procedure TC_Validate( It : Truck;
|
|
|
220 TC_ID : Character) is
|
|
|
221 begin
|
|
|
222 if TC_ID /= 'T' then
|
|
|
223 Report.Failed("Dispatched to Truck");
|
|
|
224 end if;
|
|
|
225 if Wheels( It ) /= 3 then
|
|
|
226 Report.Failed("Not a Truck");
|
|
|
227 end if;
|
|
|
228 end TC_Validate;
|
|
|
229
|
|
|
230 function Gear_Factor( It : Truck ) return Natural is
|
|
|
231 begin
|
|
|
232 return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3;
|
|
|
233 end Gear_Factor;
|
|
|
234
|
|
|
235 end C3A0013_3;
|
|
|
236
|
|
|
237 package C3A0013_4 is
|
|
|
238 procedure Perform_Tests;
|
|
|
239 end C3A0013_4;
|
|
|
240
|
|
|
241 with Report;
|
|
|
242 with C3A0013_1;
|
|
|
243 with C3A0013_2;
|
|
|
244 with C3A0013_3;
|
|
|
245 package body C3A0013_4 is
|
|
|
246 package Root renames C3A0013_1;
|
|
|
247 package Cars renames C3A0013_2;
|
|
|
248 package Trucks renames C3A0013_3;
|
|
|
249
|
|
|
250 type Car_Pool is array(1..4) of aliased Cars.Car;
|
|
|
251 Commuters : Car_Pool;
|
|
|
252
|
|
|
253 My_Car : aliased Cars.Car;
|
|
|
254 Company_Car : Root.Vehicle_ID;
|
|
|
255 Repair_Shop : Root.Vehicle_ID;
|
|
|
256
|
|
|
257 The_Vehicle : Root.Vehicle;
|
|
|
258 The_Car : Cars.Car;
|
|
|
259 The_Truck : Trucks.Truck;
|
|
|
260
|
|
|
261 procedure TC_Dispatch( Ptr : Root.Vehicle_ID;
|
|
|
262 Char : Character ) is
|
|
|
263 begin
|
|
|
264 Root.TC_Validate( Ptr.all, Char );
|
|
|
265 end TC_Dispatch;
|
|
|
266
|
|
|
267 procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class;
|
|
|
268 Char: Character) is
|
|
|
269 begin
|
|
|
270 TC_Dispatch( Item'Unchecked_Access, Char );
|
|
|
271 end TC_Check_Formal_Access;
|
|
|
272
|
|
|
273 procedure Perform_Tests is
|
|
|
274 begin -- Main test procedure.
|
|
|
275
|
|
|
276 for Lane in Commuters'Range loop
|
|
|
277 Cars.Create( Commuters(Lane) );
|
|
|
278 for Excitement in 1..Lane loop
|
|
|
279 Cars.Up_Shift( Commuters(Lane) );
|
|
|
280 end loop;
|
|
|
281 end loop;
|
|
|
282
|
|
|
283 Cars.Create( My_Car );
|
|
|
284 Cars.Up_Shift( My_Car );
|
|
|
285 Cars.TC_Validate( My_Car, 2 );
|
|
|
286
|
|
|
287 Root.Create( The_Vehicle, 1 );
|
|
|
288 Cars.Create( The_Car , 4 );
|
|
|
289 Trucks.Create( The_Truck, 3 );
|
|
|
290
|
|
|
291 TC_Check_Formal_Access( The_Vehicle, 'V' );
|
|
|
292 TC_Check_Formal_Access( The_Car, 'C' );
|
|
|
293 TC_Check_Formal_Access( The_Truck, 'T' );
|
|
|
294
|
|
|
295 Root.Up_Shift( The_Vehicle );
|
|
|
296 Cars.Up_Shift( The_Car );
|
|
|
297 Trucks.Up_Shift( The_Truck );
|
|
|
298
|
|
|
299 Root.TC_Validate( The_Vehicle, 1 );
|
|
|
300 Cars.TC_Validate( The_Car, 2 );
|
|
|
301 Trucks.TC_Validate( The_Truck, 3 );
|
|
|
302
|
|
|
303 -- general access type may reference allocated objects
|
|
|
304
|
|
|
305 Company_Car := new Cars.Car;
|
|
|
306 Root.Create( Company_Car.all );
|
|
|
307 Root.Up_Shift( Company_Car.all );
|
|
|
308 Root.Up_Shift( Company_Car.all );
|
|
|
309 Root.TC_Validate( Company_Car.all, 6 );
|
|
|
310
|
|
|
311 -- general access type may reference aliased objects
|
|
|
312
|
|
|
313 Repair_Shop := My_Car'Access;
|
|
|
314 Root.TC_Validate( Repair_Shop.all, 2 );
|
|
|
315
|
|
|
316 -- general access type may reference aliased objects
|
|
|
317
|
|
|
318 Construction: declare
|
|
|
319 type Speed_List is array(Commuters'Range) of Natural;
|
|
|
320 Accelerations : constant Speed_List := (2, 6, 12, 20);
|
|
|
321 begin
|
|
|
322 for Rotation in Commuters'Range loop
|
|
|
323 Repair_Shop := Commuters(Rotation)'Access;
|
|
|
324 Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) );
|
|
|
325 end loop;
|
|
|
326 end Construction;
|
|
|
327
|
|
|
328 end Perform_Tests;
|
|
|
329
|
|
|
330 end C3A0013_4;
|
|
|
331
|
|
|
332 with C3A0013_4;
|
|
|
333 with Report;
|
|
|
334 procedure C3A0013 is
|
|
|
335 begin
|
|
|
336
|
|
|
337 Report.Test ("C3A0013", "Check general access types. Check aliased "
|
|
|
338 & "nature of formal tagged type parameters. "
|
|
|
339 & "Check aliased nature of the current "
|
|
|
340 & "instance of a limited type. Check the "
|
|
|
341 & "constraining of actual subtypes for "
|
|
|
342 & "discriminated objects" );
|
|
|
343
|
|
|
344 C3A0013_4.Perform_Tests;
|
|
|
345
|
|
|
346 Report.Result;
|
|
|
347 end C3A0013;
|
