aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940007.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940007.a')
-rw-r--r--gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940007.a427
1 files changed, 427 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c9/c940007.a
new file mode 100644
index 000000000..41e80f4e2
--- /dev/null
+++ b/gcc-4.9/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;