------------------------------------------------------------------------------
--                                                                          --
--                         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.Task_Primitives.Operations;
with System.Tasking.Utilities;
with System.Soft_Links;
--  used for Abort_Defer/Undefer

with Ada.Containers.Doubly_Linked_Lists;
pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);

---------------------------------
-- Ada.Real_Time.Timing_Events --
---------------------------------

package body Ada.Real_Time.Timing_Events is

   use System.Task_Primitives.Operations;
   --  for Write_Lock and Unlock

   package SSL renames System.Soft_Links;

   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);
   --  Provides the type for the container holding pointers to events

   All_Events : Events.List;
   --  The queue of pending events, ordered by increasing timeout value, that
   --  have been "set" by the user via Set_Handler.

   Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
   --  Used for mutually exclusive access to All_Events

   procedure Process_Queued_Events;
   --  Examine the queue of pending events for any that have timed-out. For
   --  those that have timed-out, remove them from the queue and invoke their
   --  handler (unless the user has cancelled the event by setting the handler
   --  pointer to null). Mutually exclusive access is held via Event_Queue_Lock
   --  during part of the processing.

   procedure Insert_Into_Queue (This : Any_Timing_Event);
   --  Insert the specified event pointer into the queue of pending events
   --  with mutually exclusive access via Event_Queue_Lock.

   procedure Remove_From_Queue (This : Any_Timing_Event);
   --  Remove the specified event pointer from the queue of pending events
   --  with mutually exclusive access via Event_Queue_Lock.
   --  This procedure is used by the client-side routines (Set_Handler, etc.).

   -----------
   -- Timer --
   -----------

   task Timer is
      pragma Priority (System.Priority'Last);
      entry Start;
   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;

      --  We await the call to Start to ensure that Event_Queue_Lock has been
      --  initialized by the package executable part prior to accessing it in
      --  the loop. The task is activated before the first statement of the
      --  executable part so it would otherwise be possible for the task to
      --  call EnterCriticalSection in Process_Queued_Events before the
      --  initialization.

      --  We don't simply put the initialization here, prior to the loop,
      --  because other application tasks could call the visible routines that
      --  also call Enter/LeaveCriticalSection prior to this task doing the
      --  initialization.

      accept Start;

      loop
         Process_Queued_Events;
         delay until Clock + Period;
      end loop;
   end Timer;

   ---------------------------
   -- Process_Queued_Events --
   ---------------------------

   procedure Process_Queued_Events is
      Next_Event : Any_Timing_Event;

   begin
      loop
         SSL.Abort_Defer.all;

         Write_Lock (Event_Queue_Lock'Access);

         if All_Events.Is_Empty then
            Unlock (Event_Queue_Lock'Access);
            SSL.Abort_Undefer.all;
            return;
         else
            Next_Event := All_Events.First_Element;
         end if;

         if Next_Event.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).

            Unlock (Event_Queue_Lock'Access);
            SSL.Abort_Undefer.all;
            return;
         end if;

         --  We have an event that has timed out so we will process it. It
         --  must be the first in the queue so no search is needed.

         All_Events.Delete_First;

         --  A fundamental issue is that the invocation of the event's handler
         --  might call Set_Handler on itself to re-insert itself back into the
         --  queue of future events. Thus we cannot hold the lock on the queue
         --  while invoking the event's handler.

         Unlock (Event_Queue_Lock'Access);

         SSL.Abort_Undefer.all;

         --  There is no race condition with the user changing the handler
         --  pointer while we are processing because we are executing at the
         --  highest possible application task priority and are not doing
         --  anything to block prior to invoking their handler.

         declare
            Handler : constant Timing_Event_Handler := Next_Event.Handler;
         begin
            --  The first act is to clear the event, per D.15 (13/2). Besides,
            --  we cannot clear the handler pointer *after* invoking the
            --  handler because the handler may have re-inserted the event via
            --  Set_Event. Thus we take a copy and then clear the component.

            Next_Event.Handler := null;

            if Handler /= null then
               Handler (Timing_Event (Next_Event.all));
            end if;
         exception
            when others =>
               null;
         end;
      end loop;
   end Process_Queued_Events;

   -----------------------
   -- Insert_Into_Queue --
   -----------------------

   procedure Insert_Into_Queue (This : Any_Timing_Event) is

      function Sooner (Left, Right : Any_Timing_Event) return Boolean;
      --  Compares events in terms of timeout values

      package By_Timeout is new Events.Generic_Sorting (Sooner);
      --  Used to keep the events in ascending order by timeout value

      function Sooner (Left, Right : Any_Timing_Event) return Boolean is
      begin
         return Left.Timeout < Right.Timeout;
      end Sooner;

   begin
      SSL.Abort_Defer.all;

      Write_Lock (Event_Queue_Lock'Access);

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

      Unlock (Event_Queue_Lock'Access);

      SSL.Abort_Undefer.all;
   end Insert_Into_Queue;

   -----------------------
   -- Remove_From_Queue --
   -----------------------

   procedure Remove_From_Queue (This : Any_Timing_Event) is
      use Events;
      Location : Cursor;
   begin
      SSL.Abort_Defer.all;

      Write_Lock (Event_Queue_Lock'Access);

      Location := All_Events.Find (This);
      if Location /= No_Element then
         All_Events.Delete (Location);
      end if;

      Unlock (Event_Queue_Lock'Access);

      SSL.Abort_Undefer.all;
   end Remove_From_Queue;

   -----------------
   -- Set_Handler --
   -----------------

   procedure Set_Handler
     (Event   : in out Timing_Event;
      At_Time : Time;
      Handler : Timing_Event_Handler)
   is
   begin
      Remove_From_Queue (Event'Unchecked_Access);
      Event.Handler := null;
      if At_Time <= Clock then
         if Handler /= null then
            Handler (Event);
         end if;
         return;
      end if;
      if Handler /= null then
         Event.Timeout := At_Time;
         Event.Handler := Handler;
         Insert_Into_Queue (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
      Remove_From_Queue (Event'Unchecked_Access);
      Event.Handler := null;
      if In_Time <= Time_Span_Zero then
         if Handler /= null then
            Handler (Event);
         end if;
         return;
      end if;
      if Handler /= null then
         Event.Timeout := Clock + In_Time;
         Event.Handler := Handler;
         Insert_Into_Queue (Event'Unchecked_Access);
      end if;
   end Set_Handler;

   ---------------------
   -- Current_Handler --
   ---------------------

   function Current_Handler
     (Event : Timing_Event) return Timing_Event_Handler
   is
   begin
      return Event.Handler;
   end Current_Handler;

   --------------------
   -- Cancel_Handler --
   --------------------

   procedure Cancel_Handler
     (Event     : in out Timing_Event;
      Cancelled : out Boolean)
   is
   begin
      Remove_From_Queue (Event'Unchecked_Access);
      Cancelled := Event.Handler /= null;
      Event.Handler := null;
   end Cancel_Handler;

   -------------------
   -- Time_Of_Event --
   -------------------

   function Time_Of_Event (Event : Timing_Event) return Time is
   begin
      return Event.Timeout;
   end Time_Of_Event;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (This : in out Timing_Event) is
   begin
      --  D.15 (19/2) says finalization clears the event

      This.Handler := null;
      Remove_From_Queue (This'Unchecked_Access);
   end Finalize;

begin
   Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level);
   Timer.Start;
end Ada.Real_Time.Timing_Events;