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/c940005.a | 370 +++++++++++++++++++++++++++++ 1 file changed, 370 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940005.a (limited to 'gcc/testsuite/ada/acats/tests/c9/c940005.a') diff --git a/gcc/testsuite/ada/acats/tests/c9/c940005.a b/gcc/testsuite/ada/acats/tests/c9/c940005.a new file mode 100644 index 000000000..47a97bf2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940005.a @@ -0,0 +1,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; -- cgit v1.2.3