------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 2005-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- Boston, MA 02110-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with System.Tasking.Utilities; -- for Make_Independent with Ada.Containers.Doubly_Linked_Lists; pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists); package body Ada.Real_Time.Timing_Events is type Any_Timing_Event is access all Timing_Event'Class; -- We must also handle user-defined types derived from Timing_Event ------------ -- Events -- ------------ package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event); ----------------- -- Event_Queue -- ----------------- protected Event_Queue is pragma Priority (System.Priority'Last); procedure Insert (This : Any_Timing_Event); -- Inserts This into the queue in ascending order by Timeout procedure Process_Events; -- Iterates over the list of events and calls the handlers for any of -- those that have timed out. Deletes those that have timed out. private All_Events : Events.List; end Event_Queue; ----------- -- Timer -- ----------- task Timer is pragma Priority (System.Priority'Last); end Timer; task body Timer is Period : constant Time_Span := Milliseconds (100); -- This is a "chiming" clock timer that fires periodically. The period -- selected is arbitrary and could be changed to suit the application -- requirements. Obviously a shorter period would give better resolution -- at the cost of more overhead. begin System.Tasking.Utilities.Make_Independent; loop Event_Queue.Process_Events; delay until Clock + Period; end loop; end Timer; ------------ -- Sooner -- ------------ function Sooner (Left, Right : Any_Timing_Event) return Boolean; -- Used by the Event_Queue insertion routine to keep the events in -- ascending order by timeout value. ----------------- -- Event_Queue -- ----------------- protected body Event_Queue is procedure Insert (This : Any_Timing_Event) is package By_Timeout is new Events.Generic_Sorting (Sooner); -- Used to keep the events in ascending order by timeout value begin All_Events.Append (This); -- A critical property of the implementation of this package is that -- all occurrences are in ascending order by Timeout. Thus the first -- event in the queue always has the "next" value for the Timer task -- to use in its delay statement. By_Timeout.Sort (All_Events); end Insert; procedure Process_Events is Next_Event : Any_Timing_Event; begin while not All_Events.Is_Empty loop Next_Event := All_Events.First_Element; -- Clients can cancel a timeout (setting the handler to null) but -- cannot otherwise change the timeout/handler tuple until the -- call to Reset below. if Next_Event.Control.Current_Timeout > Clock then -- We found one that has not yet timed-out. The queue is in -- ascending order by Timeout so there is no need to continue -- processing (and indeed we must not continue since we always -- delete the first element). return; end if; declare Response : Timing_Event_Handler; begin -- We take a local snapshot of the handler to avoid a race -- condition because we evaluate the handler value in the -- if-statement and again in the call and the client might have -- set it to null between those two evaluations. Response := Next_Event.Control.Current_Handler; if Response /= null then -- D.15 (13/2) says we only invoke the handler if it is -- set when the timeout expires. Response (Timing_Event (Next_Event.all)); end if; exception when others => null; -- per D.15 (21/2) end; Next_Event.Control.Reset; -- Clients can now change the timeout/handler pair for this event -- And now we can delete the event from the queue. Any item we -- delete would be the first in the queue because we exit the loop -- when we first find one that is not yet timed-out. This fact -- allows us to use these "First oriented" list processing -- routines instead of the cursor oriented versions because we can -- avoid handling the way deletion affects cursors. All_Events.Delete_First; end loop; end Process_Events; end Event_Queue; ----------------- -- Set_Handler -- ----------------- procedure Set_Handler (Event : in out Timing_Event; At_Time : Time; Handler : Timing_Event_Handler) is begin Event.Control.Cancel; if At_Time <= Clock then if Handler /= null then Handler (Event); end if; return; end if; if Handler /= null then Event.Control.Set (At_Time, Handler); Event_Queue.Insert (Event'Unchecked_Access); end if; end Set_Handler; ----------------- -- Set_Handler -- ----------------- procedure Set_Handler (Event : in out Timing_Event; In_Time : Time_Span; Handler : Timing_Event_Handler) is begin Event.Control.Cancel; if In_Time <= Time_Span_Zero then if Handler /= null then Handler (Event); end if; return; end if; if Handler /= null then Event.Control.Set (Clock + In_Time, Handler); Event_Queue.Insert (Event'Unchecked_Access); end if; end Set_Handler; ----------------- -- Event_State -- ----------------- protected body Event_State is entry Set (Timeout : Time; Handler : Timing_Event_Handler) when Available is begin Event_State.Timeout := Set.Timeout; Event_State.Handler := Set.Handler; Available := False; end Set; procedure Reset is begin Cancel; Available := True; end Reset; procedure Cancel is begin Handler := null; Timeout := Time_First; end Cancel; function Current_Timeout return Time is begin return Timeout; end Current_Timeout; function Current_Handler return Timing_Event_Handler is begin return Handler; end Current_Handler; end Event_State; --------------------- -- Current_Handler -- --------------------- function Current_Handler (Event : Timing_Event) return Timing_Event_Handler is begin return Event.Control.Current_Handler; end Current_Handler; -------------------- -- Cancel_Handler -- -------------------- procedure Cancel_Handler (Event : in out Timing_Event; Cancelled : out Boolean) is begin Cancelled := Event.Control.Current_Handler /= null; Event.Control.Cancel; end Cancel_Handler; ------------------- -- Time_Of_Event -- ------------------- function Time_Of_Event (Event : Timing_Event) return Time is begin return Event.Control.Current_Timeout; end Time_Of_Event; ------------ -- Sooner -- ------------ function Sooner (Left, Right : Any_Timing_Event) return Boolean is begin return Left.Control.Current_Timeout < Right.Control.Current_Timeout; end Sooner; -------------- -- Finalize -- -------------- procedure Finalize (This : in out Timing_Event) is begin -- D.15 (19/2) says finalization clears the event This.Control.Cancel; end Finalize; end Ada.Real_Time.Timing_Events;