------------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--                 S Y S T E M . T A S K I N G . Q U E U I N G              --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                             $Revision: 1.7 $                             --
--                                                                          --
--       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 System.Task_Primitives; use System.Task_Primitives;

package body System.Tasking.Queuing is

   --  Entry Queues implemented as doubly linked list, priority ordered

   -------------
   -- Enqueue --
   -------------

   --  Enqueue call priority ordered, FIFO at same priority level

   procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
      Temp : Entry_Call_Link := E.Head;
   begin
      if Temp = null then
         Call.Prev := Call;
         Call.Next := Call;
         E.Head := Call;
         E.Tail := Call;
      else
         loop  --  find the entry that the new guy should precede
            exit when Call.Prio > Temp.Prio;
            Temp := Temp.Next;
            if Temp = E.Head then
               Temp := null;
               exit;
            end if;
         end loop;

         if Temp = null then -- insert at tail
            Call.Prev := E.Tail;
            Call.Next := E.Head;
            E.Tail := Call;
         else
            Call.Prev := Temp.Prev;
            Call.Next := Temp;

            if Temp = E.Head then -- insert at head
               E.Head := Call;
            end if;
         end if;

         Call.Prev.Next := Call;
         Call.Next.Prev := Call;

      end if;
   end Enqueue;

   -------------
   -- Dequeue --
   -------------

   --  Dequeue call from entry_queue E

   procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
      Prev : Entry_Call_Link;

   begin
      --  If empty queue, simply return

      if E.Head = null then
         return;
      end if;

      Call.Prev.Next := Call.Next;
      Call.Next.Prev := Call.Prev;

      if E.Head = Call then
         if E.Tail = Call then
            E.Head := null; --  case of one element
            E.Tail := null;
         else
            E.Head := Call.Next;
         end if;
      elsif E.Tail = Call then
         E.Tail := Call.Prev;
      end if;

      --  Successfully dequeued

      Call.Prev := null;
      Call.Next := null;

   end Dequeue;

   ----------
   -- Head --
   ----------

   --  Return the head of entry_queue E

   function Head (E : in Entry_Queue) return Entry_Call_Link is
   begin
      return E.Head;
   end Head;

   ------------------
   -- Dequeue_Head --
   ------------------

   --  Remove and return the head of entry_queue E

   procedure Dequeue_Head
     (E    : in out Entry_Queue;
      Call : out Entry_Call_Link)
   is
      Temp : Entry_Call_Link;

   begin
      --  If empty queue, return null pointer

      if E.Head = null then
         Call := null;
         return;
      end if;

      Temp := E.Head;

      if E.Head = E.Tail then
         E.Head := null; --  case of one element
         E.Tail := null;
      else
         E.Head := Temp.Next;
         Temp.Prev.Next := Temp.Next;
         Temp.Next.Prev := Temp.Prev;
      end if;

      --  Successfully dequeued

      Temp.Prev := null;
      Temp.Next := null;
      Call := Temp;
   end Dequeue_Head;

   -------------
   -- Onqueue --
   -------------

   --  Return True if Call is on any entry_queue at all

   function Onqueue (Call : Entry_Call_Link) return Boolean is
   begin
      --  Utilize the fact that every queue is circular, so if Call
      --  is on any queue at all, Call.Next must NOT be null.

      return Call.Next /= null;
   end Onqueue;

   -------------------
   -- Count_Waiting --
   -------------------

   --  Return number of calls on the waiting queue of E

   function Count_Waiting (E : in Entry_Queue) return Natural is
      Count : Natural;
      Temp : Entry_Call_Link;

   begin
      Count := 0;

      if E.Head /= null then
         Temp := E.Head;

         loop
            Count := Count + 1;
            exit when E.Tail = Temp;
            Temp := Temp.Next;
         end loop;
      end if;

      return Count;
   end Count_Waiting;

   ----------------------------
   -- Select_Task_Entry_Call --
   ----------------------------

   --  Select an entry for rendezvous

   procedure Select_Task_Entry_Call
     (Acceptor     : Utilities.ATCB_Ptr;
      Open_Accepts : Accept_List_Access;
      Call         : out Entry_Call_Link;
      Selection    : out Select_Index)
   is
      Entry_Call  : Entry_Call_Link;
      Temp_Call   : Entry_Call_Link;
      Entry_Index : Task_Entry_Index;
      Temp_Entry  : Task_Entry_Index;
      TAS_Result  : Boolean;
   begin
      loop
         Entry_Call := null;

         for J in Open_Accepts'Range loop
            Temp_Entry := Open_Accepts (J).S;
            if Temp_Entry /= Null_Task_Entry then
               Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
               if Temp_Call /= null and then
                 (Entry_Call = null or else
                  Entry_Call.Prio < Temp_Call.Prio)
               then
                  Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
                  Entry_Index := Temp_Entry;
                  Selection := J;
               end if;
            end if;
         end loop;

         if Entry_Call = null then
            Selection := No_Rendezvous;
            exit;
         end if;

         --  Guard is open
         Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
         Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
         exit when TAS_Result;
         --  TAS_Result = False only when the call is already canceled
         --  in that case, we go on to the next call on the queue
      end loop;

      Call := Entry_Call;

   end Select_Task_Entry_Call;

   ---------------------------------
   -- Select_Protected_Entry_Call --
   ---------------------------------

   --  Select an entry of a protected object

   procedure Select_Protected_Entry_Call
     (Object    : Protection_Access;
      Barriers  : Barrier_Vector;
      Call      : out Entry_Call_Link)
   is
      Entry_Call  : Entry_Call_Link;
      Temp_Call   : Entry_Call_Link;
      Entry_Index : Protected_Entry_Index;
      TAS_Result  : Boolean;
   begin
      loop
         Entry_Call := null;

         for J in Barriers'Range loop
            if Barriers (J) then
               Temp_Call := Head (Object.Entry_Queues (J));
               if Temp_Call /= null and then
                  (Entry_Call = null or else
                   Entry_Call.Prio < Temp_Call.Prio)
               then
                  Entry_Call := Temp_Call;
                  Entry_Index := J;
               end if;
            end if;
         end loop;

         exit when Entry_Call = null;

         --  Barrier is open
         Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
         if Entry_Call.Abortable then
            Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
            exit when TAS_Result;
         --  If call is not abortable, it has already been claimed for us
         else
            exit;
         end if;

      end loop;

      Call := Entry_Call;

   end Select_Protected_Entry_Call;

end System.Tasking.Queuing;
