File : asl-semaphore-nested_prio.adb


-- The Ada Structured Library - A set of container classes and general
--   tools for use with Ada95.
-- Copyright (C) 1998-1999  Corey Minyard (minyard@acm.org)
--
-- This library is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 2 of the License, or (at your
-- option) any later version.
--
-- This library is distributed in the hope that it will be useful, but
-- WITHOUT 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 along
-- with this library; if not, write to the Free Software Foundation, Inc.,
-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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.
--

with Ada.Task_Identification; use type Ada.Task_Identification.Task_Id;
with System; use type System.Any_Priority;

package body Asl.Semaphore.Nested_Prio is

   ------------------------------------------------------------------------
   -- Take creates a task data structure on the stack.  This way, we don't
   -- have to allocate one with dynamic allocation.  This should be safe to
   -- do since it will only be used in the context of this routine.
   procedure Take (O : in out Object) is
      My_Task : aliased Task_Data;
   begin
      O.The_Mutex.Add_Task(My_Task'Unchecked_Access);
      O.The_Mutex.Wait;
      O.The_Mutex.Remove_Task(My_Task'Unchecked_Access);
      -- Fixme - Do I need to add an exception handler or some way to
      -- handle aborts?
   end Take;

   ------------------------------------------------------------------------
   procedure Give (O : in out Object) is
   begin
      O.The_Mutex.Release;
   end Give;

   ------------------------------------------------------------------------
   procedure Try_To_Take (O       : in out Object;
                          Success : out Boolean;
                          Timeout : in Duration := 0.0) is
      My_Task : aliased Task_Data;
   begin
      O.The_Mutex.Add_Task(My_Task'Unchecked_Access);
      select
         O.The_Mutex.Wait;
         Success := True;
      or
         delay Timeout;
         Success := False;
      end select;
      O.The_Mutex.Remove_Task(My_Task'Unchecked_Access);
      -- Fixme - Do I need to add an exception handler or some way to
      -- handle aborts?
   end Try_To_Take;

   ------------------------------------------------------------------------
   ------------------------------------------------------------------------
   protected body Mutex is

      ---------------------------------------------------------------------
      -- Add a task to the list of waiting tasks and update the priority
      -- accordingly.
      procedure Add_Task (Info : in Task_Data_Ptr) is
      begin
         -- Fill in the task's data and put it into the list.
         Info.Id := Task_Ident.Current_Task;
         Info.Prio := Task_Prio.Get_Priority;
         Info.Next := Waiting_Tasks;
         Waiting_Tasks := Info;

         -- If the new tasks priority is greater than the current priority,
         -- up the priority of the running task.  The check here is needed
         -- for a running task due to a race condition between adding a
         -- task and claiming the semaphore.
         if ((Owner /= Task_Ident.Null_Task_Id)
             and (Info.Prio > Max_Wait_Prio))
         then
            Max_Wait_Prio := Info.Prio;
            Task_Prio.Set_Priority(Max_Wait_Prio, Owner);
         end if;
      end Add_Task;

      ---------------------------------------------------------------------
      -- Remove the task from the list of waiting tasks and decrease the
      -- priority if necessary.
      procedure Remove_Task (Info : in Task_Data_Ptr) is
         Prev     : Task_Data_Ptr := null;
         Curr     : Task_Data_Ptr := Waiting_Tasks;
         New_Prio : System.Any_Priority;
      begin
         while ((Curr /= null) and then (Curr /= Info)) loop
            Prev := Curr;
            Curr := Curr.Next;
         end loop;
         if (Curr = null) then
            raise Internal_Nested_Prio_Error;
         end if;
         if (Prev = null) then
            Waiting_Tasks := Curr.Next;
         else
            Prev.Next := Curr.Next;
         end if;

         -- The deleted task is the highest priority, perhaps we need to
         -- reduce Max_Wait_Prio.
         if (Info.Prio = Max_Wait_Prio) then

            -- Search for the highest priority.
            Curr := Waiting_Tasks;
            New_Prio := System.Any_Priority'First;
            while (Curr /= null) loop
               if (Curr.Prio > New_Prio) then
                  New_Prio := Curr.Prio;
               end if;
               Curr := Curr.Next;
            end loop;

            if (New_Prio /= Max_Wait_Prio) then
               -- The highest waiting priority has changed.

               if ((Owner /= Task_Ident.Null_Task_Id)
                   and (Max_Wait_Prio > Orig_Prio))
               then
                  -- We have changed the owner's priority previously, so
                  -- reduce it to either the natural priority or to the new
                  -- max priority.  We need to check the owner because of
                  -- possible race conditions.
                  if (New_Prio > Orig_Prio) then
                     Task_Prio.Set_Priority(New_Prio, Owner);
                  else
                     Task_Prio.Set_Priority(Orig_Prio, Owner);
                  end if;
               end if;

               Max_Wait_Prio := New_Prio;
            end if;
         end if;
      end Remove_Task;

      ---------------------------------------------------------------------
      -- Let the task in if no other task has the semaphore or if the
      -- calling task already owns the semaphore.
      entry Wait when ((Count = 0) or (Task_Ident.Current_Task = Owner)) is
      begin
         if (Count = 0) then
            Owner := Wait'Caller;
            Orig_Prio := Task_Prio.Get_Priority(Owner);
            if (Max_Wait_Prio > Orig_Prio) then
               Task_Prio.Set_Priority(Max_Wait_Prio, Owner);
            end if;
         end if;
         Count := Count + 1;
      end Wait;

      ---------------------------------------------------------------------
      procedure Release is
      begin
         if (Task_Ident.Current_Task /= Owner) then
            raise Tasking_Error;
         end if;

         Count := Count - 1;
         if (Count = 0) then
            -- We are releasing the semaphore, so set our priority back
            -- if necessary.
            if (Max_Wait_Prio > Orig_Prio) then
               Task_Prio.Set_Priority(Orig_Prio, Owner);
            end if;
            Owner := Task_Ident.Null_Task_Id;
         end if;
      end Release;

   end Mutex;

end Asl.Semaphore.Nested_Prio;