From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/c9/c940007.a | 427 +++++++++++++++++++++++++++++ 1 file changed, 427 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940007.a (limited to 'gcc/testsuite/ada/acats/tests/c9/c940007.a') diff --git a/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc/testsuite/ada/acats/tests/c9/c940007.a new file mode 100644 index 000000000..41e80f4e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940007.a @@ -0,0 +1,427 @@ +-- 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.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 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; -- cgit v1.2.3