Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c9/c940005.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- C940005.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 body of a protected function can have internal calls
28 -- to other protected functions and that the body of a protected
29 -- procedure can have internal calls to protected procedures and to
30 -- protected functions.
31 --
32 -- TEST DESCRIPTION:
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 - in this case only
37 -- one is shown (Test_Ramp). The routines to sample and alter the states
38 -- of the various sensors, to queue the vehicles on the meter and to
39 -- release them are all part of the protected object and can be shared
40 -- by various tasks. Apart from the function/procedure tests this example
41 -- has a mix of other tasking features.
42 --
43 --
44 -- CHANGE HISTORY:
45 -- 06 Dec 94 SAIC ACVC 2.0
46 -- 13 Nov 95 SAIC Updated and fixed bugs ACVC 2.0.1
47 --
48 --!
49
50
51 with Report;
52 with ImpDef;
53 with Ada.Calendar;
54
55 procedure C940005 is
56
57 begin
58
59 Report.Test ("C940005", "Check internal calls of protected functions" &
60 " and procedures");
61
62 declare -- encapsulate the test
63
64 function "+" (Left : Ada.Calendar.Time; Right: Duration)
65 return Ada.Calendar.Time renames Ada.Calendar."+";
66
67 -- Weighted load given to each potential problem area and accumulated
68 type Load_Factor is range 0..8;
69 Clear_Level : constant Load_Factor := 0;
70 Minimum_Level : constant Load_Factor := 1;
71 Moderate_Level : constant Load_Factor := 2;
72 Serious_Level : constant Load_Factor := 4;
73 Critical_Level : constant Load_Factor := 6;
74
75 -- Weighted loads given to each Sample Point (pure weights, not levels)
76 Local_Overload_wt : constant Load_Factor := 1;
77 Next_Ramp_in_Overload_wt : constant Load_Factor := 1;
78 Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght
79 -- :::: other weighted loads
80
81 TC_Multiplier : integer := 1; -- changed half way through
82 TC_Expected_Passage_Total : constant integer := 486;
83
84 -- This is the time between synchronizing pulses to the ramps.
85 -- In reality one would expect a time of 5 to 10 seconds. In
86 -- the interests of speeding up the test suite a shorter time
87 -- is used
88 Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task;
89
90 -- control over stopping tasks
91 protected Control is
92 procedure Stop_Now;
93 function Stop return Boolean;
94 private
95 Halt : Boolean := False;
96 end Control;
97
98 protected body Control is
99 procedure Stop_Now is
100 begin
101 Halt := True;
102 end Stop_Now;
103
104 function Stop return Boolean is
105 begin
106 return Halt;
107 end Stop;
108 end Control;
109
110 task Pulse_Task; -- task to generate a pulse for each ramp
111
112 -- Carrier task. One is created for each vehicle arriving at the ramp
113 task type Vehicle;
114 type acc_Vehicle is access Vehicle;
115
116 --================================================================
117 protected Test_Ramp is
118 function Next_Ramp_in_Overload return Load_Factor;
119 function Local_Overload return Load_Factor;
120 function Freeway_Overload return Load_Factor;
121 function Freeway_Breakdown return Boolean;
122 function Meter_in_use_State return Boolean;
123 procedure Set_Local_Overload;
124 procedure Add_Meter_Queue;
125 procedure Subtract_Meter_Queue;
126 procedure Time_Pulse_Received;
127 entry Wait_at_Meter;
128 procedure TC_Passage (Pass_Point : Integer);
129 function TC_Get_Passage_Total return integer;
130 -- ::::::::: many routines are not shown (for example none of the
131 -- clears, none of the real-time-sensor handlers)
132
133 private
134
135 Release_One_Vehicle : Boolean := false;
136 Meter_in_Use : Boolean := false;
137 Fwy_Break_State : Boolean := false;
138
139
140 Ramp_Count : integer range 0..20 := 0;
141 Ramp_Count_Threshold : integer := 15;
142
143 -- Current state of the various Sample Points
144 Local_State : Load_Factor := Clear_Level;
145 Next_Ramp_State : Load_Factor := Clear_Level;
146 -- :::: other Sample Point states not shown
147
148 TC_Passage_Total : integer := 0;
149 end Test_Ramp;
150 --================================================================
151 protected body Test_Ramp is
152
153 procedure Start_Meter is
154 begin
155 Meter_in_Use := True;
156 null; -- stub :::: trigger the metering hardware
157 end Start_Meter;
158
159 -- External call for Meter_in_Use
160 function Meter_in_Use_State return Boolean is
161 begin
162 return Meter_in_Use;
163 end Meter_in_Use_State;
164
165 -- Trace the paths through the various routines by totaling the
166 -- weighted call parameters
167 procedure TC_Passage (Pass_Point : Integer) is
168 begin
169 TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
170 end TC_Passage;
171
172 -- For the final check of the whole test
173 function TC_Get_Passage_Total return integer is
174 begin
175 return TC_Passage_Total;
176 end TC_Get_Passage_Total;
177
178 -- These Set/Clear routines are triggered by real-time sensors that
179 -- reflect traffic state
180 procedure Set_Local_Overload is
181 begin
182 Local_State := Local_Overload_wt;
183 if not Meter_in_Use then
184 Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
185 end if;
186 end Set_Local_Overload;
187
188 --::::: Set/Clear routines for all the other sensors not shown
189
190 function Local_Overload return Load_Factor is
191 begin
192 return Local_State;
193 end Local_Overload;
194
195 function Next_Ramp_in_Overload return Load_Factor is
196 begin
197 return Next_Ramp_State;
198 end Next_Ramp_in_Overload;
199
200 -- :::::::: other overload factor states not shown
201
202 -- return the summation of all the load factors
203 function Freeway_Overload return Load_Factor is
204 begin
205 return Local_Overload -- EACH IS A CALL OF A
206 -- + :::: others -- FUNCTION FROM WITHIN
207 + Next_Ramp_in_Overload; -- A FUNCTION
208 end Freeway_Overload;
209
210 -- Freeway Breakdown is defined as traffic moving < 5mph
211 function Freeway_Breakdown return Boolean is
212 begin
213 return Fwy_Break_State;
214 end Freeway_Breakdown;
215
216 -- Keep count of vehicles currently on meter queue - we can't use
217 -- the 'count because we need the outcall trigger
218 procedure Add_Meter_Queue is
219 TC_Pass_Point : constant integer := 22;
220 begin
221 Ramp_Count := Ramp_Count + 1;
222 TC_Passage ( TC_Pass_Point ); -- note passage through here
223 if Ramp_Count > Ramp_Count_Threshold then
224 null; -- :::: stub, trigger surface street notification
225 end if;
226 end Add_Meter_Queue;
227 --
228 procedure Subtract_Meter_Queue is
229 TC_Pass_Point : constant integer := 24;
230 begin
231 Ramp_Count := Ramp_Count - 1;
232 TC_Passage ( TC_Pass_Point ); -- note passage through here
233 end Subtract_Meter_Queue;
234
235 -- Here each Vehicle task queues itself awaiting release
236 entry Wait_at_Meter when Release_One_Vehicle is
237 -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
238 TC_Pass_Point : constant integer := 23;
239 begin
240 TC_Passage ( TC_Pass_Point ); -- note passage through here
241 Release_One_Vehicle := false; -- Consume the signal
242 -- Decrement number of vehicles on ramp
243 Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY
244 end Wait_at_Meter;
245
246
247 procedure Time_Pulse_Received is
248 Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL
249 -- FUNCTION
250 -- FROM WITHIN PROCEDURE
251 begin
252 -- if broken down, no vehicles are released
253 if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE
254 if Load < Moderate_Level then
255 Release_One_Vehicle := true;
256 end if;
257 null; -- stub ::: If other levels, release every other
258 -- pulse, every third pulse etc.
259 end if;
260 end Time_Pulse_Received;
261
262 end Test_Ramp;
263 --================================================================
264
265
266 -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
267 -- generation of an accompanying carrier task
268 procedure New_Arrival is
269 Next_Vehicle_Task: acc_Vehicle := new Vehicle;
270 TC_Pass_Point : constant integer := 3;
271 begin
272 Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here
273 null;
274 end New_arrival;
275
276
277 -- Carrier task. One is created for each vehicle arriving at the ramp
278 task body Vehicle is
279 TC_Pass_point : constant integer := 1;
280 TC_Pass_Point_2 : constant integer := 21;
281 TC_Pass_Point_3 : constant integer := 2;
282 begin
283 Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage through here
284 if Test_Ramp.Meter_in_Use_State then
285 Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage
286 -- Increment count of number of vehicles on ramp
287 Test_Ramp.Add_Meter_Queue; -- CALL a protected PROCEDURE
288 -- which is also called from within
289 -- enter the meter queue
290 Test_Ramp.Wait_at_Meter; -- CALL a protected ENTRY
291 end if;
292 Test_Ramp.TC_Passage ( TC_Pass_Point_3 ); -- note passage thru here
293 null; --:::: call to the first in the series of the Ramp_Sensors
294 -- this "passes" the vehicle from one sensor to the next
295 exception
296 when others =>
297 Report.Failed ("Unexpected exception in Vehicle Task");
298 end Vehicle;
299
300
301 -- Task transmits a synchronizing "pulse" to all ramps
302 --
303 task body Pulse_Task is
304 Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
305 begin
306 While not Control.Stop loop
307 delay until Pulse_Time;
308 Test_Ramp.Time_Pulse_Received; -- causes INTERNAL CALLS
309 -- :::::::::: and to all the others
310 Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
311 end loop;
312 exception
313 when others =>
314 Report.Failed ("Unexpected exception in Pulse_Task");
315 end Pulse_Task;
316
317
318 begin -- declare
319
320 -- Test driver. This is ALL test control code
321
322 -- First simulate calls to the protected functions and procedures
323 -- from without the protected object
324 --
325 -- CALL FUNCTIONS
326 if Test_Ramp.Local_Overload /= Clear_Level then
327 Report.Failed ("External Call to Local_Overload incorrect");
328 end if;
329 if Test_Ramp.Next_Ramp_in_Overload /= Clear_Level then
330 Report.Failed ("External Call to Next_Ramp_in_Overload incorrect");
331 end if;
332 if Test_Ramp.Freeway_Overload /= Clear_Level then
333 Report.Failed ("External Call to Freeway_Overload incorrect");
334 end if;
335
336 -- Now Simulate the arrival of a vehicle to verify path through test
337 New_Arrival;
338 delay Pulse_Time_Delta*2; -- allow it to pass through the complex
339
340 TC_Multiplier := 5; -- change the weights for the paths for the next
341 -- part of the test
342
343 -- Simulate a real-time sensor reporting overload
344 Test_Ramp.Set_Local_Overload; -- CALL A PROCEDURE (and change levels)
345
346 -- CALL FUNCTIONS again
347 if Test_Ramp.Local_Overload /= Minimum_Level then
348 Report.Failed ("External Call to Local_Overload incorrect - 2");
349 end if;
350 if Test_Ramp.Freeway_Overload /= Minimum_Level then
351 Report.Failed ("External Call to Freeway_Overload incorrect -2");
352 end if;
353
354 -- Now Simulate the arrival of another vehicle again causing
355 -- INTERNAL CALLS but following different paths (queuing on the
356 -- meter etc.)
357 New_Arrival;
358 delay Pulse_Time_Delta*2; -- allow it to pass through the complex
359
360 Control.Stop_Now; -- finish test
361
362 if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then
363 Report.Failed ("Unexpected paths taken");
364 end if;
365
366 end; -- declare
367
368 Report.Result;
369
370 end C940005;