------------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--             S Y S T E M . T A S K _ T I M E R _ S E R V I C E            --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                             $Revision: 1.18 $                             --
--                                                                          --
--       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
--                                                                          --
-- GNARL is free software; you can redistribute it  and/or modify it  under --
-- terms  of  the  GNU  Library General Public License  as published by the --
-- Free Software  Foundation;  either version 2, or (at  your  option)  any --
-- later  version.  GNARL is distributed  in the hope that  it will be use- --
-- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
-- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
-- eral Library Public License  for more details.  You should have received --
-- a  copy of the GNU Library General Public License along with GNARL;  see --
-- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
-- Mass Ave, Cambridge, MA 02139, USA.                                      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Calendar.Conv;
--  Used for, Time_To_Stimespec

with System.Compiler_Exceptions;
--  Used for, Current_Exception

with Ada.Real_Time.Conv;
--  Used for, Time_Span_To_Stimespec
--            Time_To_Stimespec

with System.Task_Primitives;
--  Used for, Condition_Variable
--            Lock, Unlock
--            Write_Lock
--            Cond_Signal
--            Initialize_Lock
--            Initialize_Cond
--            Cond_Timed_wait

with System.Tasking.Utilities;
--  Used for, Make_Independent

with System.Task_Clock;

with System.Task_Clock.Machine_Specifics;
--  Used for, Machine_Specifics.Clock

with System.Tasking.Protected_Objects;

with System.Tasking;

with Unchecked_Conversion;

with Unchecked_Deallocation;

package body System.Task_Timer_Service is

   use System.Tasking.Protected_Objects;
   use System.Tasking;

   use System.Task_Clock;
   --  Included use clause for comparison operators

   function Clock return Stimespec
     renames Task_Clock.Machine_Specifics.Clock;

   type Q_Rec;
   type Q_Link is access Q_Rec;

   type Q_Rec is record
      S_O      : Signal_Object;
      T        : Task_Clock.Stimespec;    --  wake up time
      Next     : Q_Link;
      Previous : Q_Link;
   end record;

   procedure Deallocate_Q_Rec is new
      Unchecked_Deallocation (Q_Rec, Q_Link);

   Q_Head : Q_Link := null;


   Timer_Condition :  Task_Primitives.Condition_Variable;
   Timer_Lock      :  Task_Primitives.Lock;

   Stimespec_Day : constant Stimespec := Task_Clock.Time_Of (86400, 0);
   Stimespec_Large : Stimespec := Clock + Stimespec_Day;
   --  This value is used to make Timer.Server to sleep until some entry
   --  comes into the timer queue.

   function To_Access is new
     Unchecked_Conversion (System.Address, Protection_Access);

   -------------------
   -- Signal_Object --
   -------------------

   protected body Signal_Object is

      entry Wait when Open is
      begin
         Open := False;
      end Wait;

      procedure Signal is
      begin
         Open := True;
      end Signal;

      function Wait_Count return integer is
      begin
         return Wait'Count;
      end Wait_Count;

   end Signal_Object;

   ------------------------
   -- Timer.Time_Enqueue --
   ------------------------

   --  ??? This should be a private operation of Timer; this currently
   --      does not work.

   procedure Time_Enqueue
     (T : in Task_Clock.Stimespec;
      N : in out Q_Link);

   procedure Time_Enqueue
     (T : in Task_Clock.Stimespec;
      N : in out Q_Link)
   is
      Q_Ptr : Q_Link := Q_Head;
      Error : Boolean;

   begin
      --  Create a queue entry

      N := new Q_Rec;
      N.T := T;

      --  If the new element becomes head of the queue, notify Timer Service

      if Q_Head = null then
         N.Next := null;
         N.Previous := null;
         Q_Head := N;
         Task_Primitives.Write_Lock (Timer_Lock, Error);
         Task_Primitives.Cond_Signal (Timer_Condition);

         --  Signal the timer server to wake up

         Task_Primitives.Unlock (Timer_Lock);

      elsif N.T < Q_Head.T then
         N.Next := Q_Head;
         N.Previous := null;
         Q_Head.Previous := N;
         Q_Head := N;
         Task_Primitives.Write_Lock (Timer_Lock, Error);
         Task_Primitives.Cond_Signal (Timer_Condition);

         --  Signal the timer server to wake up

         Task_Primitives.Unlock (Timer_Lock);

      else
         --  Place in the middle

         while Q_Ptr.Next /= null loop
            if Q_Ptr.Next.T >= N.T then
               N.Next := Q_Ptr.Next;
               N.Previous := Q_Ptr;
               Q_Ptr.Next.Previous := N;
               Q_Ptr.Next := N;
               exit;
            end if;

            Q_Ptr := Q_Ptr.Next;
         end loop;

         if Q_Ptr.Next = null then

            --  Place at the end

            N.Next := null;
            N.Previous := Q_Ptr;
            Q_Ptr.Next := N;
         end if;
      end if;
   end Time_Enqueue;

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

   protected body Timer is

      -------------------
      -- Timer.Service --
      -------------------

      procedure Service (T : out Task_Clock.Stimespec) is
         Q_Ptr : Q_Link := Q_Head;
         W     : integer;
      begin
         while Q_Ptr /= null loop


            if Q_Ptr.T < Clock or else Q_Ptr.S_O.Wait_Count = 0 then

               --  Wake up the waiting task

               Q_Ptr.S_O.Signal;

               --  Remove the entry, case of head entry

               if Q_Ptr = Q_Head then
                  Q_Head := Q_Ptr.Next;

                  if Q_Head /= null then
                     Q_Head.Previous := null;
                  end if;

               --  Case of tail entry

               elsif Q_Ptr.Next = null then
                  Q_Ptr.Previous.Next := null;

               --  Case of middle entry

               else
                  Q_Ptr.Previous.Next := Q_Ptr.Next;
                  Q_Ptr.Next.Previous := Q_Ptr.Previous;
               end if;
            end if;

            Q_Ptr := Q_Ptr.Next;
         end loop;

         if Q_Head = null then
            T := Stimespec_Large;
         else
            T := Q_Head.T;
         end if;

      end Service;

      --  ??? The following entries used to all be called Enqueue; the
      --      compiler does not seem to be able to handle overloading
      --      in requeue statements.

      --  The following for Enqueue procedure enqueues elements in wake-up time
      --  order using a single timer queue  (time in System.Real_Time.Time)
      entry Enqueue_Time_Span (T : in Real_Time.Time_Span) when true is
         N : Q_Link;
      begin
         Time_Enqueue (Clock +
            Real_Time.Conv.Time_Span_To_Stimespec (T), N);
         requeue N.S_O.Wait with abort;
         Deallocate_Q_Rec (N);
      end Enqueue_Time_Span;

      entry Enqueue_Duration (T : in Duration) when true is
         N : Q_Link;
      begin
         Time_Enqueue (Clock + Task_Clock.Duration_To_Stimespec (T), N);
         requeue N.S_O.Wait with abort;
         Deallocate_Q_Rec (N);
      end Enqueue_Duration;

      entry Enqueue_Real_Time (T : in Real_Time.Time) when true is
         N : Q_Link;
      begin
         Time_Enqueue (Real_Time.Conv.Time_To_Stimespec (T), N);
         requeue N.S_O.Wait with abort;
         Deallocate_Q_Rec (N);
      end Enqueue_Real_Time;

      entry Enqueue_Calendar_Time (T : in Ada.Calendar.Time) when true is
         N : Q_Link;
      begin
         Time_Enqueue (Ada.Calendar.Conv.Time_To_Stimespec (T), N);
         requeue N.S_O.Wait with abort;
         Deallocate_Q_Rec (N);
      end Enqueue_Calendar_Time;

   end Timer;

   -------------------
   -- Timer_Service --
   -------------------

   Next_Wakeup_Time : Task_Clock.Stimespec := Stimespec_Large;

   procedure Temp_Init;
   procedure Temp_Wait;
   --  These procedures contain processing that should be local to
   --  Timer_Server---GNAT workaround. ???

   procedure Temp_Init is
   begin
      Tasking.Utilities.Make_Independent;
      Task_Primitives.Initialize_Lock (System.Priority'Last, Timer_Lock);
      Task_Primitives.Initialize_Cond (Timer_Condition);
   end Temp_Init;
   procedure Temp_Wait is
      Result           : Boolean;
      Error            : Boolean;
   begin
      Task_Primitives.Write_Lock (Timer_Lock, Error);
      Task_Primitives.Cond_Timed_Wait
        (Timer_Condition, Timer_Lock, Next_Wakeup_Time, Result);
      Task_Primitives.Unlock (Timer_Lock);
   end Temp_Wait;

   task Timer_Server is
      pragma Priority (System.Priority'Last);
   end Timer_Server;

   task body Timer_Server is
   begin
      Temp_Init;
      loop
         Temp_Wait;
         if Q_Head = null and then Next_Wakeup_Time < Clock then
         --  In the case where current time passes Stimespec_Large
            Stimespec_Large := Stimespec_Large + Stimespec_Day;
            Next_Wakeup_Time := Stimespec_Large;
         else
            Timer.Service (Next_Wakeup_Time);
         end if;
      end loop;
   end Timer_Server;

end System.Task_Timer_Service;
