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 body of a protected function declared as an object of a
28 -- given type can have internal calls to other protected functions and
29 -- that a protected procedure in such an object can have internal calls
30 -- to protected procedures and to protected functions.
33 -- Simulate a meter at a freeway on-ramp which, when real-time sensors
34 -- determine that the freeway is becoming saturated, triggers stop lights
35 -- which control the access of vehicles to prevent further saturation.
36 -- Each on-ramp is represented by a protected object of the type Ramp.
37 -- The routines to sample and alter the states of the various sensors, to
38 -- queue the vehicles on the meter and to release them are all part of
39 -- the protected object and can be shared by various tasks. Apart from
40 -- the function/procedure tests this example has a mix of other tasking
41 -- features. In this test two objects representing two adjacent ramps
42 -- are created from the same type. The same "traffic" is simulated for
43 -- each ramp. The results should be identical.
47 -- 06 Dec 94 SAIC ACVC 2.0
48 -- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop
49 -- with a protected object.
64 Report
.Test
("C940007", "Check internal calls of protected functions" &
65 " and procedures in objects declared as a type");
67 declare -- encapsulate the test
69 function "+" (Left
: Ada
.Calendar
.Time
; Right
: Duration)
70 return Ada
.Calendar
.Time
renames Ada
.Calendar
."+";
72 -- Weighted load given to each potential problem area and accumulated
73 type Load_Factor
is range 0..8;
74 Clear_Level
: constant Load_Factor
:= 0;
75 Minimum_Level
: constant Load_Factor
:= 1;
76 Moderate_Level
: constant Load_Factor
:= 2;
77 Serious_Level
: constant Load_Factor
:= 4;
78 Critical_Level
: constant Load_Factor
:= 6;
80 -- Weighted loads given to each Sample Point (pure weights, not levels)
81 Local_Overload_wt
: constant Load_Factor
:= 1;
82 Next_Ramp_in_Overload_wt
: constant Load_Factor
:= 1;
83 Ramp_Junction_in_Overload_wt
: constant Load_Factor
:=2; --higher wght
84 -- :::: other weighted loads
86 TC_Expected_Passage_Total
: integer := 486;
89 -- This is the time between synchronizing pulses to the ramps.
90 -- In reality one would expect a time of 5 to 10 seconds. In
91 -- the interests of speeding up the test suite a shorter time
93 Pulse_Time_Delta
: constant duration := ImpDef
.Switch_To_New_Task
;
96 -- control over stopping tasks
99 function Stop
return Boolean;
101 Halt
: Boolean := False;
104 protected body Control
is
105 procedure Stop_Now
is
110 function Stop
return Boolean is
117 task Pulse_Task
; -- task to generate a pulse for each ramp
119 -- Carrier tasks. One is created for each vehicle arriving at each ramp
120 task type Vehicle_31
; -- For Ramp_31
121 type acc_Vehicle_31
is access Vehicle_31
;
123 task type Vehicle_32
; -- For Ramp_32
124 type acc_Vehicle_32
is access Vehicle_32
;
126 --================================================================
127 protected type Ramp
is
128 function Next_Ramp_in_Overload
return Load_Factor
;
129 function Local_Overload
return Load_Factor
;
130 function Freeway_Overload
return Load_Factor
;
131 function Freeway_Breakdown
return Boolean;
132 function Meter_in_Use_State
return Boolean;
133 procedure Set_Local_Overload
;
134 procedure Add_Meter_Queue
;
135 procedure Subtract_Meter_Queue
;
136 procedure Time_Pulse_Received
;
138 procedure TC_Passage
(Pass_Point
: Integer);
139 function TC_Get_Passage_Total
return integer;
140 -- ::::::::: many routines are not shown (for example none of the
141 -- clears, none of the real-time-sensor handlers)
145 Release_One_Vehicle
: Boolean := false;
146 Meter_in_Use
: Boolean := false;
147 Fwy_Break_State
: Boolean := false;
150 Ramp_Count
: integer range 0..20 := 0;
151 Ramp_Count_Threshold
: integer := 15;
153 -- Current state of the various Sample Points
154 Local_State
: Load_Factor
:= Clear_Level
;
155 Next_Ramp_State
: Load_Factor
:= Clear_Level
;
156 -- :::: other Sample Point states not shown
158 TC_Multiplier
: integer := 1; -- changed half way through
159 TC_Passage_Total
: integer := 0;
161 --================================================================
162 protected body Ramp
is
164 procedure Start_Meter
is
166 Meter_in_Use
:= True;
167 null; -- stub :::: trigger the metering hardware
170 function Meter_in_Use_State
return Boolean is
173 end Meter_in_Use_State
;
175 -- Trace the paths through the various routines by totaling the
176 -- weighted call parameters
177 procedure TC_Passage
(Pass_Point
: Integer) is
179 TC_Passage_Total
:= TC_Passage_Total
+(Pass_Point
*TC_Multiplier
);
182 -- For the final check of the whole test
183 function TC_Get_Passage_Total
return integer is
185 return TC_Passage_Total
;
186 end TC_Get_Passage_Total
;
188 -- These Set/Clear routines are triggered by real-time sensors that
189 -- reflect traffic state
190 procedure Set_Local_Overload
is
192 Local_State
:= Local_Overload_wt
;
193 if not Meter_in_Use
then
194 Start_Meter
; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
196 -- Change the weights for the paths for the next part of the test
198 end Set_Local_Overload
;
200 --::::: Set/Clear routines for all the other sensors not shown
202 function Local_Overload
return Load_Factor
is
207 function Next_Ramp_in_Overload
return Load_Factor
is
209 return Next_Ramp_State
;
210 end Next_Ramp_in_Overload
;
212 -- :::::::: other overload factor states not shown
214 -- return the summation of all the load factors
215 function Freeway_Overload
return Load_Factor
is
217 return Local_Overload
-- EACH IS A CALL OF A
218 -- + :::: others -- FUNCTION FROM WITHIN
219 + Next_Ramp_in_Overload
; -- A FUNCTION
220 end Freeway_Overload
;
222 -- Freeway Breakdown is defined as traffic moving < 5mph
223 function Freeway_Breakdown
return Boolean is
225 return Fwy_Break_State
;
226 end Freeway_Breakdown
;
228 -- Keep count of vehicles currently on meter queue - we can't use
229 -- the 'count because we need the outcall trigger
230 procedure Add_Meter_Queue
is
231 TC_Pass_Point
: constant integer := 22;
233 Ramp_Count
:= Ramp_Count
+ 1;
234 TC_Passage
( TC_Pass_Point
); -- note passage through here
235 if Ramp_Count
> Ramp_Count_Threshold
then
236 null; -- :::: stub, trigger surface street notification
240 procedure Subtract_Meter_Queue
is
241 TC_Pass_Point
: constant integer := 24;
243 Ramp_Count
:= Ramp_Count
- 1;
244 TC_Passage
( TC_Pass_Point
); -- note passage through here
245 end Subtract_Meter_Queue
;
247 -- Here each Vehicle task queues itself awaiting release
248 entry Wait_at_Meter
when Release_One_Vehicle
is
249 -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
250 TC_Pass_Point
: constant integer := 23;
252 TC_Passage
( TC_Pass_Point
); -- note passage through here
253 Release_One_Vehicle
:= false; -- Consume the signal
254 -- Decrement number of vehicles on ramp
255 Subtract_Meter_Queue
; -- CALL PROCEDURE FROM WITHIN ENTRY BODY
259 procedure Time_Pulse_Received
is
260 Load
: Load_factor
:= Freeway_Overload
; -- CALL MULTILEVEL FUNCTN
261 -- FROM WITHIN PROCEDURE
263 -- if broken down, no vehicles are released
264 if not Freeway_Breakdown
then -- CALL FUNCTION FROM A PROCEDURE
265 if Load
< Moderate_Level
then
266 Release_One_Vehicle
:= true;
268 null; -- stub ::: If other levels, release every other
269 -- pulse, every third pulse etc.
271 end Time_Pulse_Received
;
274 --================================================================
276 -- Now create two Ramp objects from this type
282 -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31
283 -- and the generation of an accompanying carrier task
284 procedure New_Arrival_31
is
285 Next_Vehicle_Task_31
: acc_Vehicle_31
:= new Vehicle_31
;
286 TC_Pass_Point
: constant integer := 3;
288 Ramp_31
.TC_Passage
( TC_Pass_Point
); -- Note passage through here
293 -- Carrier task. One is created for each vehicle arriving at Ramp_31
294 task body Vehicle_31
is
295 TC_Pass_point
: constant integer := 1;
296 TC_Pass_Point_2
: constant integer := 21;
297 TC_Pass_Point_3
: constant integer := 2;
299 Ramp_31
.TC_Passage
( TC_Pass_Point
); -- note passage through here
300 if Ramp_31
.Meter_in_Use_State
then
301 Ramp_31
.TC_Passage
( TC_Pass_Point_2
); -- note passage
302 -- Increment count of number of vehicles on ramp
303 Ramp_31
.Add_Meter_Queue
; -- CALL a protected PROCEDURE
304 -- which is also called from within
305 -- enter the meter queue
306 Ramp_31
.Wait_at_Meter
; -- CALL a protected ENTRY
308 Ramp_31
.TC_Passage
( TC_Pass_Point_3
); -- note passage through here
309 null; --:::: call to the first in the series of the Ramp_Sensors
310 -- this "passes" the vehicle from one sensor to the next
313 Report
.Failed
("Unexpected exception in Vehicle Task");
317 -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
318 -- generation of an accompanying carrier task
319 procedure New_Arrival_32
is
320 Next_Vehicle_Task_32
: acc_Vehicle_32
:= new Vehicle_32
;
321 TC_Pass_Point
: constant integer := 3;
323 Ramp_32
.TC_Passage
( TC_Pass_Point
); -- Note passage through here
328 -- Carrier task. One is created for each vehicle arriving at Ramp_32
329 task body Vehicle_32
is
330 TC_Pass_point
: constant integer := 1;
331 TC_Pass_Point_2
: constant integer := 21;
332 TC_Pass_Point_3
: constant integer := 2;
334 Ramp_32
.TC_Passage
( TC_Pass_Point
); -- note passage through here
335 if Ramp_32
.Meter_in_Use_State
then
336 Ramp_32
.TC_Passage
( TC_Pass_Point_2
); -- note passage
337 -- Increment count of number of vehicles on ramp
338 Ramp_32
.Add_Meter_Queue
; -- CALL a protected PROCEDURE
339 -- which is also called from within
340 -- enter the meter queue
341 Ramp_32
.Wait_at_Meter
; -- CALL a protected ENTRY
343 Ramp_32
.TC_Passage
( TC_Pass_Point_3
); -- note passage through here
344 null; --:::: call to the first in the series of the Ramp_Sensors
345 -- this "passes" the vehicle from one sensor to the next
348 Report
.Failed
("Unexpected exception in Vehicle Task");
352 -- Task transmits a synchronizing "pulse" to all ramps
354 task body Pulse_Task
is
355 Pulse_Time
: Ada
.Calendar
.Time
:= Ada
.Calendar
.Clock
;
357 While not Control
.Stop
loop
358 delay until Pulse_Time
;
359 Ramp_31
.Time_Pulse_Received
; -- CALL OF PROCEDURE CAUSES
360 Ramp_32
.Time_Pulse_Received
; -- INTERNAL CALLS
361 -- :::::::::: and to all the others
362 Pulse_Time
:= Pulse_Time
+ Pulse_Time_Delta
; -- calculate next
366 Report
.Failed
("Unexpected exception in Pulse_Task");
372 -- Test driver. This is ALL test control code
374 -- First simulate calls to the protected functions and procedures
375 -- from without the protected object
378 if not ( Ramp_31
.Local_Overload
= Clear_Level
and
379 Ramp_31
.Next_Ramp_in_Overload
= Clear_Level
and
380 Ramp_31
.Freeway_Overload
= Clear_Level
) then
381 Report
.Failed
("Initial Calls to Ramp_31 incorrect");
383 if not ( Ramp_32
.Local_Overload
= Clear_Level
and
384 Ramp_32
.Next_Ramp_in_Overload
= Clear_Level
and
385 Ramp_32
.Freeway_Overload
= Clear_Level
) then
386 Report
.Failed
("Initial Calls to Ramp_32 incorrect");
389 -- Now Simulate the arrival of a vehicle at each ramp to verify
390 -- basic paths through the test
393 delay Pulse_Time_Delta
*2; -- allow them to pass through the complex
395 -- Simulate real-time sensors reporting overload
396 Ramp_31
.Set_Local_Overload
; -- CALL A PROCEDURE (and change levels)
397 Ramp_32
.Set_Local_Overload
; -- CALL A PROCEDURE (and change levels)
399 -- CALL FUNCTIONS again
400 if not ( Ramp_31
.Local_Overload
= Minimum_Level
and
401 Ramp_31
.Freeway_Overload
= Minimum_Level
) then
402 Report
.Failed
("Secondary Calls to Ramp_31 incorrect");
404 if not ( Ramp_32
.Local_Overload
= Minimum_Level
and
405 Ramp_32
.Freeway_Overload
= Minimum_Level
) then
406 Report
.Failed
("Secondary Calls to Ramp_32 incorrect");
409 -- Now Simulate the arrival of another vehicle at each ramp again causing
410 -- INTERNAL CALLS but following different paths (queuing on the
414 delay Pulse_Time_Delta
*2; -- allow them to pass through the complex
416 Control
.Stop_Now
; -- finish test
418 if not (TC_Expected_Passage_Total
= Ramp_31
.TC_Get_Passage_Total
and
419 TC_Expected_Passage_Total
= Ramp_32
.TC_Get_Passage_Total
) then
420 Report
.Failed
("Unexpected paths taken");