summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c9/c940005.a
blob: 47a97bf2de65a22e09f1de9e0a35ffa20159dfb1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
-- C940005.A 
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that the body of a protected function can have internal calls
--      to other protected functions and that the body of a protected
--      procedure can have internal calls to protected procedures and to 
--      protected functions.
--
-- TEST DESCRIPTION:
--      Simulate a meter at a freeway on-ramp which, when real-time sensors
--      determine that the freeway is becoming saturated, triggers stop lights
--      which control the access of vehicles to prevent further saturation. 
--      Each on-ramp is represented by a protected object - in this case only
--      one is shown (Test_Ramp).  The routines to sample and alter the states
--      of the various sensors, to queue the vehicles on the meter and to
--      release them are all part of the  protected object and can be shared
--      by various tasks. Apart from the function/procedure tests this example
--      has a mix of other tasking features. 
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      13 Nov 95   SAIC    Updated and fixed bugs ACVC 2.0.1
--
--!


with Report;
with ImpDef;
with Ada.Calendar;
                
procedure C940005 is

begin

   Report.Test ("C940005", "Check internal calls of protected functions" &
                        " and procedures");

   declare  -- encapsulate the test

      function "+" (Left : Ada.Calendar.Time; Right: Duration)
                            return Ada.Calendar.Time renames Ada.Calendar."+";

      -- Weighted load given to each potential problem area and accumulated
      type Load_Factor is range 0..8;
      Clear_Level    : constant Load_Factor := 0;
      Minimum_Level  : constant Load_Factor := 1;
      Moderate_Level : constant Load_Factor := 2;
      Serious_Level  : constant Load_Factor := 4;
      Critical_Level : constant Load_Factor := 6;

      -- Weighted loads given to each  Sample Point (pure weights, not levels)
      Local_Overload_wt         : constant Load_Factor := 1;
      Next_Ramp_in_Overload_wt  : constant Load_Factor := 1;
      Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght
      -- ::::  other weighted loads
          
      TC_Multiplier : integer := 1;  -- changed half way through
      TC_Expected_Passage_Total : constant integer := 486;

      -- This is the time between synchronizing pulses to the ramps.
      -- In reality one would expect a time of 5 to 10 seconds.  In
      -- the interests of speeding up the test suite a shorter time
      -- is used
      Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task;

      -- control over stopping tasks
      protected Control is
         procedure Stop_Now;
         function Stop return Boolean;
      private
         Halt : Boolean := False;
      end Control;

      protected body Control is
         procedure Stop_Now is
         begin
            Halt := True;
         end Stop_Now;

         function Stop return Boolean is
         begin
            return Halt;
         end Stop;
      end Control;

      task Pulse_Task;       -- task to generate a pulse for each ramp

      -- Carrier task. One is created for each vehicle arriving at the ramp
      task type Vehicle;      
      type acc_Vehicle is access Vehicle;

      --================================================================
      protected Test_Ramp is
         function Next_Ramp_in_Overload return Load_Factor;
         function Local_Overload        return Load_Factor;
         function Freeway_Overload      return Load_Factor;
         function Freeway_Breakdown     return Boolean;
         function Meter_in_use_State    return Boolean; 
         procedure Set_Local_Overload;
         procedure Add_Meter_Queue;
         procedure Subtract_Meter_Queue;
         procedure Time_Pulse_Received;
         entry Wait_at_Meter;
         procedure TC_Passage (Pass_Point : Integer);
         function TC_Get_Passage_Total return integer;
         -- ::::::::: many routines are not shown (for example none of the
         --            clears, none of the real-time-sensor handlers)
   
      private

         Release_One_Vehicle : Boolean := false;
         Meter_in_Use        : Boolean := false;
         Fwy_Break_State     : Boolean := false;
               
   
         Ramp_Count : integer range 0..20 := 0;
         Ramp_Count_Threshold : integer := 15;
   
         -- Current state of the various Sample Points
         Local_State     : Load_Factor := Clear_Level;
         Next_Ramp_State : Load_Factor := Clear_Level;
            -- ::::  other Sample Point states not shown
   
         TC_Passage_Total : integer := 0;
      end Test_Ramp;  
      --================================================================
      protected body Test_Ramp is
   
            procedure Start_Meter is
            begin
               Meter_in_Use := True;
               null;  -- stub  :::: trigger the metering hardware
            end Start_Meter;
         
         -- External call for Meter_in_Use
         function Meter_in_Use_State return Boolean is
         begin
            return Meter_in_Use;
         end Meter_in_Use_State;
   
         -- Trace the paths through the various routines by totaling the
         -- weighted call parameters
         procedure TC_Passage (Pass_Point : Integer) is
         begin
            TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier);
         end TC_Passage;
   
         -- For the final check of the whole test
         function TC_Get_Passage_Total return integer is
         begin
            return TC_Passage_Total;
         end TC_Get_Passage_Total;
   
         -- These Set/Clear routines are triggered by real-time sensors that
         -- reflect traffic state
         procedure Set_Local_Overload is
         begin
            Local_State := Local_Overload_wt;
            if not Meter_in_Use then
               Start_Meter;   -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE
            end if;
         end Set_Local_Overload;
   
         --::::: Set/Clear routines for all the other sensors not shown

         function Local_Overload return Load_Factor is
         begin
            return Local_State;
         end Local_Overload;
   
         function Next_Ramp_in_Overload return Load_Factor is
         begin
            return Next_Ramp_State;
         end Next_Ramp_in_Overload;
   
         -- ::::::::  other overload factor states not shown
   
         -- return the summation of all the load factors
         function Freeway_Overload return Load_Factor is
         begin
            return    Local_Overload                    -- EACH IS A CALL OF A
                      -- + :::: others                  -- FUNCTION FROM WITHIN
                      + Next_Ramp_in_Overload;          -- A FUNCTION
         end Freeway_Overload;

         -- Freeway Breakdown is defined as traffic moving < 5mph
         function Freeway_Breakdown return Boolean is
         begin
            return Fwy_Break_State;
         end Freeway_Breakdown;
   
         -- Keep count of vehicles currently on meter queue - we can't use
         -- the 'count because we need the outcall trigger
         procedure Add_Meter_Queue is
            TC_Pass_Point : constant integer := 22;
         begin
            Ramp_Count := Ramp_Count + 1;  
            TC_Passage ( TC_Pass_Point );  -- note passage through here
            if Ramp_Count > Ramp_Count_Threshold then
               null;  -- :::: stub, trigger surface street notification
            end if;
         end Add_Meter_Queue;  
         --
         procedure Subtract_Meter_Queue is
            TC_Pass_Point : constant integer := 24;
         begin
            Ramp_Count := Ramp_Count - 1;  
            TC_Passage ( TC_Pass_Point );  -- note passage through here
         end Subtract_Meter_Queue;  
   
         -- Here each Vehicle task queues itself awaiting release
         entry Wait_at_Meter when Release_One_Vehicle is
         -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL
            TC_Pass_Point : constant integer := 23;
         begin
            TC_Passage ( TC_Pass_Point );   -- note passage through here
            Release_One_Vehicle := false;   -- Consume the signal
            -- Decrement number of vehicles on ramp 
            Subtract_Meter_Queue;  -- CALL PROCEDURE FROM WITHIN ENTRY BODY
         end Wait_at_Meter;      
   
   
         procedure Time_Pulse_Received is
            Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL
                                                    -- FUNCTION 
                                                    -- FROM WITHIN PROCEDURE
         begin
            -- if broken down, no vehicles are released
            if not Freeway_Breakdown then    -- CALL FUNCTION FROM A PROCEDURE
               if Load < Moderate_Level then
                  Release_One_Vehicle := true;
               end if;
               null;    -- stub  ::: If other levels, release every other
                        --           pulse, every third pulse  etc.
            end if;
         end Time_Pulse_Received;
       
      end Test_Ramp;  
      --================================================================
       

      -- Simulate the arrival of a vehicle at the Ramp_Receiver and the
      -- generation of an accompanying carrier task
      procedure New_Arrival is
         Next_Vehicle_Task: acc_Vehicle := new Vehicle;
         TC_Pass_Point : constant integer := 3; 
      begin
         Test_Ramp.TC_Passage ( TC_Pass_Point );  -- Note passage through here
         null;
      end New_arrival;


      -- Carrier task. One is created for each vehicle arriving at the ramp
      task body Vehicle is
         TC_Pass_point   : constant integer :=  1;
         TC_Pass_Point_2 : constant integer := 21;
         TC_Pass_Point_3 : constant integer :=  2;
      begin
         Test_Ramp.TC_Passage ( TC_Pass_Point );  -- note passage through here
         if Test_Ramp.Meter_in_Use_State then  
            Test_Ramp.TC_Passage ( TC_Pass_Point_2 );  -- note passage
            -- Increment count of number of vehicles on ramp 
            Test_Ramp.Add_Meter_Queue;    -- CALL a protected PROCEDURE
                                          -- which is also called from within
            -- enter the meter queue
            Test_Ramp.Wait_at_Meter;      -- CALL a protected ENTRY   
         end if;
         Test_Ramp.TC_Passage ( TC_Pass_Point_3 );  -- note passage thru here
         null;  --:::: call to the first in the series of the Ramp_Sensors
                --     this "passes" the vehicle from one sensor to the next
      exception
         when others => 
               Report.Failed ("Unexpected exception in Vehicle Task");
      end Vehicle;


      -- Task transmits a synchronizing "pulse" to all ramps
      --
      task body Pulse_Task is
         Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         While not Control.Stop loop
            delay until Pulse_Time;  
            Test_Ramp.Time_Pulse_Received;  -- causes INTERNAL CALLS
            -- ::::::::::  and to all the others
            Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next
         end loop;
      exception
         when others => 
               Report.Failed ("Unexpected exception in Pulse_Task");
      end Pulse_Task;


   begin -- declare

      -- Test driver.  This is ALL test control code

      -- First simulate calls to the protected functions and procedures
      -- from without the protected object
      --
      -- CALL FUNCTIONS
      if Test_Ramp.Local_Overload /= Clear_Level then
         Report.Failed ("External Call to Local_Overload incorrect");
      end if;
      if Test_Ramp.Next_Ramp_in_Overload /= Clear_Level then
         Report.Failed ("External Call to Next_Ramp_in_Overload incorrect");
      end if;
      if Test_Ramp.Freeway_Overload /= Clear_Level then
         Report.Failed ("External Call to Freeway_Overload incorrect");
      end if;

      -- Now Simulate the arrival of a vehicle to verify path through test
      New_Arrival; 
      delay Pulse_Time_Delta*2;  -- allow it to pass through the complex

      TC_Multiplier := 5;  -- change the weights for the paths for the next
                           -- part of the test
      
      -- Simulate a real-time sensor reporting overload
      Test_Ramp.Set_Local_Overload;  -- CALL A PROCEDURE  (and change levels)

      -- CALL FUNCTIONS again
      if Test_Ramp.Local_Overload /= Minimum_Level then
         Report.Failed ("External Call to Local_Overload incorrect - 2");
      end if;
      if Test_Ramp.Freeway_Overload /= Minimum_Level then
         Report.Failed ("External Call to Freeway_Overload incorrect -2");
      end if;

      -- Now Simulate the arrival of another vehicle again causing
      -- INTERNAL CALLS but following different paths (queuing on the 
      -- meter etc.)
      New_Arrival; 
      delay Pulse_Time_Delta*2;  -- allow it to pass through the complex

      Control.Stop_Now;  -- finish test

      if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then
         Report.Failed ("Unexpected paths taken");
      end if;

   end; -- declare

   Report.Result;

end C940005;