path: root/gcc/testsuite/ada/acats/tests/c9/c940007.a

-- 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;