diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c9/c940007.a')
-rw-r--r-- | gcc/testsuite/ada/acats/tests/c9/c940007.a | 427 |
1 files changed, 0 insertions, 427 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc/testsuite/ada/acats/tests/c9/c940007.a deleted file mode 100644 index c678463633a..00000000000 --- a/gcc/testsuite/ada/acats/tests/c9/c940007.a +++ /dev/null @@ -1,427 +0,0 @@ --- C940007.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 declared as an object of a --- given type can have internal calls to other protected functions and --- that a protected procedure in such an object 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 of the type 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. In this test two objects representing two adjacent ramps --- are created from the same type. The same "traffic" is simulated for --- each ramp. The results should be identical. --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop --- with a protected object. --- ACVC 2.0.1 --- ---! - - -with Report; -with ImpDef; -with Ada.Calendar; - - -procedure C940007 is - -begin - - Report.Test ("C940007", "Check internal calls of protected functions" & - " and procedures in objects declared as a type"); - - 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_Expected_Passage_Total : 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.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 tasks. One is created for each vehicle arriving at each ramp - task type Vehicle_31; -- For Ramp_31 - type acc_Vehicle_31 is access Vehicle_31; - -- - task type Vehicle_32; -- For Ramp_32 - type acc_Vehicle_32 is access Vehicle_32; - - --================================================================ - protected type 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_Multiplier : integer := 1; -- changed half way through - TC_Passage_Total : integer := 0; - end Ramp; - --================================================================ - protected body Ramp is - - procedure Start_Meter is - begin - Meter_in_Use := True; - null; -- stub :::: trigger the metering hardware - end Start_Meter; - - 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; - -- Change the weights for the paths for the next part of the test - TC_Multiplier :=5; - 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 FUNCTN - -- 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 Ramp; - --================================================================ - - -- Now create two Ramp objects from this type - Ramp_31 : Ramp; - Ramp_32 : Ramp; - - - - -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 - -- and the generation of an accompanying carrier task - procedure New_Arrival_31 is - Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; - TC_Pass_Point : constant integer := 3; - begin - Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here - null; --::: stub - end New_arrival_31; - - - -- Carrier task. One is created for each vehicle arriving at Ramp_31 - task body Vehicle_31 is - TC_Pass_point : constant integer := 1; - TC_Pass_Point_2 : constant integer := 21; - TC_Pass_Point_3 : constant integer := 2; - begin - Ramp_31.TC_Passage ( TC_Pass_Point ); -- note passage through here - if Ramp_31.Meter_in_Use_State then - Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage - -- Increment count of number of vehicles on ramp - Ramp_31.Add_Meter_Queue; -- CALL a protected PROCEDURE - -- which is also called from within - -- enter the meter queue - Ramp_31.Wait_at_Meter; -- CALL a protected ENTRY - end if; - Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage through 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_31; - - - -- Simulate the arrival of a vehicle at the Ramp_Receiver and the - -- generation of an accompanying carrier task - procedure New_Arrival_32 is - Next_Vehicle_Task_32 : acc_Vehicle_32 := new Vehicle_32; - TC_Pass_Point : constant integer := 3; - begin - Ramp_32.TC_Passage ( TC_Pass_Point ); -- Note passage through here - null; --::: stub - end New_arrival_32; - - - -- Carrier task. One is created for each vehicle arriving at Ramp_32 - task body Vehicle_32 is - TC_Pass_point : constant integer := 1; - TC_Pass_Point_2 : constant integer := 21; - TC_Pass_Point_3 : constant integer := 2; - begin - Ramp_32.TC_Passage ( TC_Pass_Point ); -- note passage through here - if Ramp_32.Meter_in_Use_State then - Ramp_32.TC_Passage ( TC_Pass_Point_2 ); -- note passage - -- Increment count of number of vehicles on ramp - Ramp_32.Add_Meter_Queue; -- CALL a protected PROCEDURE - -- which is also called from within - -- enter the meter queue - Ramp_32.Wait_at_Meter; -- CALL a protected ENTRY - end if; - Ramp_32.TC_Passage ( TC_Pass_Point_3 ); -- note passage through 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_32; - - - -- 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; - Ramp_31.Time_Pulse_Received; -- CALL OF PROCEDURE CAUSES - Ramp_32.Time_Pulse_Received; -- 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 not ( Ramp_31.Local_Overload = Clear_Level and - Ramp_31.Next_Ramp_in_Overload = Clear_Level and - Ramp_31.Freeway_Overload = Clear_Level ) then - Report.Failed ("Initial Calls to Ramp_31 incorrect"); - end if; - if not ( Ramp_32.Local_Overload = Clear_Level and - Ramp_32.Next_Ramp_in_Overload = Clear_Level and - Ramp_32.Freeway_Overload = Clear_Level ) then - Report.Failed ("Initial Calls to Ramp_32 incorrect"); - end if; - - -- Now Simulate the arrival of a vehicle at each ramp to verify - -- basic paths through the test - New_Arrival_31; - New_Arrival_32; - delay Pulse_Time_Delta*2; -- allow them to pass through the complex - - -- Simulate real-time sensors reporting overload - Ramp_31.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) - Ramp_32.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) - - -- CALL FUNCTIONS again - if not ( Ramp_31.Local_Overload = Minimum_Level and - Ramp_31.Freeway_Overload = Minimum_Level ) then - Report.Failed ("Secondary Calls to Ramp_31 incorrect"); - end if; - if not ( Ramp_32.Local_Overload = Minimum_Level and - Ramp_32.Freeway_Overload = Minimum_Level ) then - Report.Failed ("Secondary Calls to Ramp_32 incorrect"); - end if; - - -- Now Simulate the arrival of another vehicle at each ramp again causing - -- INTERNAL CALLS but following different paths (queuing on the - -- meter etc.) - New_Arrival_31; - New_Arrival_32; - delay Pulse_Time_Delta*2; -- allow them to pass through the complex - - Control.Stop_Now; -- finish test - - if not (TC_Expected_Passage_Total = Ramp_31.TC_Get_Passage_Total and - TC_Expected_Passage_Total = Ramp_32.TC_Get_Passage_Total) then - Report.Failed ("Unexpected paths taken"); - end if; - - end; -- declare - - Report.Result; - -end C940007; |