-----------------------------------------------------------------------------
--                                                                          --
--                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
--                                                                          --
--      S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S     --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                             $Revision: 1.30 $                            --
--                                                                          --
--       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.Compiler_Exceptions;
--  Used for, "="
--            Raise_Exceptions
--            Exception_ID
--            Compiler_Exceptions.Null_Exception
--            Program_Error_ID

with System.Tasking.Abortion;
--  Used for, Abortion.Defer_Abortion,
--            Abortion.Undefer_Abortion,
--            Abortion.Change_Base_Priority

with System.Task_Primitives; use System.Task_Primitives;

with System.Tasking.Queuing; use System.Tasking.Queuing;
--  Used for, Queuing.Enqueue,
--            Queuing.Dequeue,
--            Queuing.Head,
--            Queuing.Dequeue_Head,
--            Queuing.Count_Waiting,
--            Queuing.Select_Protected_Entry_Call

with System.Tasking.Utilities;
--  Used for  Utilities.Abort_To_Level

with System.Tasking.Stages;
pragma Elaborate_All (System.Tasking.Stages);
--  Just for elaboration.

with Unchecked_Conversion;

package body System.Tasking.Protected_Objects is

   procedure Defer_Abortion
     renames Abortion.Defer_Abortion;

   procedure Internal_Lock
     (Object : Protection_Access;
      Ceiling_Violation : out Boolean);
   --  This version of lock is used internally to lock a protected
   --  object.  It returns a Ceiling_Violation flag instead of raising
   --  program error, avoiding the need for exception handlers in the
   --  runtime to clean up after a ceiling violation.

   procedure Internal_Lock_Read_Only
     (Object : Protection_Access;
      Ceiling_Violation : out Boolean);
   --  This version of lock is used internally to lock a protected
   --  object for read access.
   --  It returns a Ceiling_Violation flag instead of raising
   --  program error, avoiding the need for exception handlers in the
   --  runtime to clean up after a ceiling violation.

   procedure Send_Program_Error (Entry_Call : Entry_Call_Link);
   --  Raise Program_Error in the caller of the specified entry
   --  call.

   procedure Unclaim
     (Entry_Call : Entry_Call_Link;
      Cancelled  : out Boolean);
   --  This procedure "unclaims" a protected entry call.  It breaks
   --  the race condition between attempts to service and cancel the
   --  call by checking to see if an
   --  attempt has been made to cancel the call and, if so, contending with
   --  the cancellation operation for the right to cancel it.

   procedure Undefer_Abortion
     renames Abortion.Undefer_Abortion;

   function "=" (L, R : System.Compiler_Exceptions.Exception_ID) return Boolean
     renames System.Compiler_Exceptions."=";

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

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

   procedure Vulnerable_Cancel_Protected_Entry_Call
     (Current_Task   : Task_ID;
      Call           : Entry_Call_Link;
      PO             : Protection_Access;
      Call_Cancelled : out Boolean);
   --  This procedure is used to cancel a protected entry call from
   --  within the runtime (including from the interface procedure
   --  Cancel_Protected_Entry_Call).  It assumes that abortion is
   --  deferred.

   -----------------------------
   -- Raise_Pending_Exception --
   -----------------------------

   procedure Raise_Pending_Exception (Block : Communication_Block) is
      T  : Task_ID := Block.Self;
      Ex : System.Compiler_Exceptions.Exception_ID := T.Exception_To_Raise;
   begin

      T.Exception_To_Raise := System.Compiler_Exceptions.Null_Exception;
      System.Compiler_Exceptions.Raise_Exception (Ex);
   end Raise_Pending_Exception;

   ---------------------------
   -- Initialize_Protection --
   ---------------------------

   procedure Initialize_Protection
     (Object           : Protection_Access;
      Ceiling_Priority : Integer;
      Service_Info     : System.Address)
   is
      Init_Priority : Integer := Ceiling_Priority;

      First_Entry_Index : Protected_Entry_Index := 1;
      Last_Entry_Index : Protected_Entry_Index := Object.Num_Entries;

   begin
      if Init_Priority = Unspecified_Priority then
         Init_Priority := System.Default_Priority;
      end if;

      Initialize_Lock (Init_Priority, Object.L);
      Object.Ceiling := System.Priority (Init_Priority);
      Object.Service_Info := Service_Info;
      Object.Pending_Action := False;
      Object.Pending_Call := null;
      Object.Call_In_Progress := null;

      --  ??? Take out loop on Entry_Queues'Range to program around
      --  an intermitant bug.
      --  for E in Object.Entry_Queues'Range loop

      for E in First_Entry_Index .. Last_Entry_Index loop
         Object.Entry_Queues (E).Head := null;
         Object.Entry_Queues (E).Tail := null;
      end loop;
   end Initialize_Protection;

   -------------------------
   -- Finalize_Protection --
   -------------------------

   procedure Finalize_Protection (Object : Protection_Access) is
   begin
      --  Need to purge entry queues and pending entry call here. ???

      Finalize_Lock (Object.L);
   end Finalize_Protection;

   -------------------
   -- Internal_Lock --
   -------------------

   procedure Internal_Lock
     (Object : Protection_Access;
      Ceiling_Violation : out Boolean) is
   begin
      Write_Lock (Object.L, Ceiling_Violation);
   end Internal_Lock;

   -----------------------------
   -- Internal_Lock_Read_Only --
   -----------------------------

   procedure Internal_Lock_Read_Only
     (Object : Protection_Access;
      Ceiling_Violation : out Boolean) is
   begin
      Read_Lock (Object.L, Ceiling_Violation);
   end Internal_Lock_Read_Only;

   ----------
   -- Lock --
   ----------

   procedure Lock (Object : Protection_Access) is
      Ceiling_Violation : Boolean;
   begin
      Internal_Lock (Object, Ceiling_Violation);
      if Ceiling_Violation then
         raise Program_Error;
      end if;
   end Lock;

   --------------------
   -- Lock_Read_Only --
   --------------------

   procedure Lock_Read_Only (Object : Protection_Access) is
      Ceiling_Violation : Boolean;
   begin
      Internal_Lock_Read_Only (Object, Ceiling_Violation);
      if Ceiling_Violation then
         raise Program_Error;
      end if;
   end Lock_Read_Only;

   ------------
   -- Unlock --
   ------------

   procedure Unlock (Object : Protection_Access) is
      Caller : Task_ID := Self;
      Error  : Boolean;
   begin
      if Object.Pending_Action then
         Object.Pending_Action := False;
         Write_Lock (Caller.L, Error);
         Caller.New_Base_Priority := Object.Old_Base_Priority;
         Abortion.Change_Base_Priority (Caller);
         Unlock (Caller.L);
      end if;
      Unlock (Object.L);
   end Unlock;

   --------------------------
   -- Protected_Entry_Call --
   --------------------------

   procedure Protected_Entry_Call
     (Object    : Protection_Access;
      E         : Protected_Entry_Index;
      Uninterpreted_Data : System.Address;
      Mode      : Call_Modes;
      Block     : out Communication_Block)
   is
      Level : ATC_Level;
      Caller : Task_ID := Self;

   begin
      Block.Self := Caller;
      Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
      Level := Caller.ATC_Nesting_Level;

      Object.Pending_Call := Caller.Entry_Calls (Level)'Access;

      --  The caller's lock is not needed here.  The call record does not
      --  need protection, since other tasks only access these records
      --  when they are queued, which this one is not.  The Pending_Call
      --  field is protected, and will be until the call is removed by
      --  Next_Entry_Call.

      Object.Pending_Call.Next := null;
      Object.Pending_Call.Call_Claimed := False;
      Object.Pending_Call.Mode := Mode;
      Object.Pending_Call.Abortable := True;
      Object.Pending_Call.Cancel_Requested := False;
      Object.Pending_Call.Cancelled := False;
      Object.Pending_Call.Done := False;
      Object.Pending_Call.E := Entry_Index (E);
      Object.Pending_Call.Prio := Caller.Current_Priority;
      Object.Pending_Call.Uninterpreted_Data := Uninterpreted_Data;
      Object.Pending_Call.Called_PO := Protection_Access_To_Address (Object);

      Object.Pending_Call.Called_Task := Null_Task;
      Object.Pending_Call.Exception_To_Raise :=
        System.Compiler_Exceptions.Null_Exception;

   end Protected_Entry_Call;

   --------------------------------------------
   -- Vulnerable_Cancel_Protected_Entry_Call --
   --------------------------------------------

   procedure Vulnerable_Cancel_Protected_Entry_Call
     (Current_Task   : Task_ID;
      Call           : Entry_Call_Link;
      PO             : Protection_Access;
      Call_Cancelled : out Boolean)
   is
      TAS_Result : Boolean;
      Ceiling_Violation : Boolean;
      Old_Base_Priority : System.Priority;

   begin

      Call.Cancel_Requested := True;
      --  Set the flag indicating that this call should be cancelled if
      --  it is ever queued with abort.

      Test_And_Set (Call.Call_Claimed'Address, TAS_Result);

      if TAS_Result then

         Internal_Lock (PO, Ceiling_Violation);
         if Ceiling_Violation then
            Write_Lock (Current_Task.L, Ceiling_Violation);
            Old_Base_Priority := Current_Task.Base_Priority;
            Current_Task.New_Base_Priority := PO.Ceiling;
            Abortion.Change_Base_Priority (Current_Task);
            Unlock (Current_Task.L);
            Lock (PO);
            PO.Old_Base_Priority := Old_Base_Priority;
            PO.Pending_Action := True;
         end if;

         if Onqueue (Call) then
            Dequeue (PO.Entry_Queues (Protected_Entry_Index (Call.E)), Call);
         end if;

         Write_Lock (Current_Task.L, Ceiling_Violation);
         Call.Cancelled := True;

      else

         --  Someone else has claimed the call.  Wait until they either
         --  complete it or cancel it.

         Write_Lock (Current_Task.L, Ceiling_Violation);
         while not Call.Done and then not Call.Cancelled loop
            Cond_Wait (Current_Task.Cond, Current_Task.L);
         end loop;

         --  ??? Note that the Cancelled flag returned by this operation
         --      has two meanings; that the call was
         --      cancelled, and that this operation actually did the
         --      cancellation.  Now that the cancellation can be done
         --      by requeuing the call abortably, this last meaning is
         --      not always accurate.  For the time being, just lock the
         --      protected object if the call has been cancelled by
         --      some other task and let the user code call the service
         --      entries procedure (which is not needed in this case) and
         --      unlock it.  Perhaps another flag should be added to
         --      avoid this unnecessary work.

         if Call.Cancelled then

            Unlock (Current_Task.L);
            Internal_Lock (PO, Ceiling_Violation);
            if Ceiling_Violation then
               Write_Lock (Current_Task.L, Ceiling_Violation);
               Old_Base_Priority := Current_Task.Base_Priority;
               Current_Task.New_Base_Priority := PO.Ceiling;
               Abortion.Change_Base_Priority (Current_Task);
               Unlock (Current_Task.L);
               Lock (PO);
               PO.Old_Base_Priority := Old_Base_Priority;
               PO.Pending_Action := True;
            end if;

            Write_Lock (Current_Task.L, Ceiling_Violation);

         end if;

      end if;

      --   If we have reached the desired ATC nesting level, reset the
      --   requested level to effective infinity, to allow further calls.

      Current_Task.ATC_Nesting_Level := Current_Task.ATC_Nesting_Level - 1;

      if Current_Task.Pending_ATC_Level = Current_Task.ATC_Nesting_Level then
         Current_Task.Pending_ATC_Level := ATC_Level_Infinity;
         Current_Task.Aborting := False;
      end if;

      Unlock (Current_Task.L);

      Current_Task.Exception_To_Raise := Call.Exception_To_Raise;
      Call_Cancelled := Call.Cancelled;

   end Vulnerable_Cancel_Protected_Entry_Call;

   -------------------------
   -- Wait_For_Completion --
   -------------------------

   --  Control flow procedure.
   --  Abortion must be deferred before calling this procedure.

   procedure Wait_For_Completion (Block : in out Communication_Block)
   is
      Current_Task : Task_ID := Block.Self;
      Call         : Entry_Call_Link;
      PO           : Protection_Access;
      Error        : Boolean;

   begin

      pragma Assert (Current_Task.ATC_Nesting_Level > ATC_Level_Base'First,
        "Attempt to wait on a nonexistent protected entry call.");

      Call := Current_Task.Entry_Calls (Current_Task.ATC_Nesting_Level)'Access;

      pragma Assert (Call.Mode = Simple_Call,
        "Attempt to wait on a on a conditional or asynchronous call");

      PO := Address_To_Protection_Access (Call.Called_PO);

      Write_Lock (Current_Task.L, Error);

      if Call.Abortable then
         Current_Task.Suspended_Abortably := True;

         while not Call.Done loop
            if Current_Task.Pending_Action then
               if Current_Task.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Current_Task);
                  --  requeue call at new priority
                  Unlock (Current_Task.L);
                  Lock (PO);
                  if Onqueue (Call) then  --  Dequeued by proxy?
                     Dequeue (PO.Entry_Queues (
                       Protected_Entry_Index (Call.E)), Call);
                     Enqueue (PO.Entry_Queues (
                       Protected_Entry_Index (Call.E)), Call);
                  end if;
                  Unlock (PO);
                  Write_Lock (Current_Task.L, Error);
               end if;

               exit when
                  Current_Task.Pending_ATC_Level <
                    Current_Task.ATC_Nesting_Level;
               Current_Task.Pending_Action := False;
            end if;
            Cond_Wait (Current_Task.Cond, Current_Task.L);
         end loop;

         Current_Task.Suspended_Abortably := False;

      else
         while not Call.Done loop
            Cond_Wait (Current_Task.Cond, Current_Task.L);
         end loop;
      end if;

      Unlock (Current_Task.L);

      Vulnerable_Cancel_Protected_Entry_Call
        (Current_Task, Call, PO, Block.Cancelled);

      Block.Service_Info := PO.Service_Info;

   end Wait_For_Completion;

   ---------------------------------
   -- Cancel_Protected_Entry_Call --
   ---------------------------------

   procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block)
   is
      Current_Task : Task_ID := Block.Self;
      Call         : Entry_Call_Link;
      PO           : Protection_Access;
      TAS_Result   : Boolean;

   begin
      Defer_Abortion;

      pragma Assert (Current_Task.ATC_Nesting_Level > ATC_Level_Base'First,
        "Attempt to cancel a nonexistent task entry call.");

      Call := Current_Task.Entry_Calls (Current_Task.ATC_Nesting_Level)'Access;

      pragma Assert (Call.Mode = Asynchronous_Call,
        "Attempt to cancel a conditional or simple call");

      pragma Assert (Call.Called_Task = Null_Task,
        "Attempt to use Cancel_Protected_Entry_Call on task entry call.");

      PO := Address_To_Protection_Access (Call.Called_PO);
      Vulnerable_Cancel_Protected_Entry_Call (
        Current_Task, Call, PO, Block.Cancelled);
      Undefer_Abortion;

      Block.Service_Info := PO.Service_Info;

   end Cancel_Protected_Entry_Call;

   --------------------------
   -- Wait_Until_Abortable --
   --------------------------

   procedure Wait_Until_Abortable (Block : in out Communication_Block) is
      Caller     : Task_ID := Block.Self;
      Call       : Entry_Call_Link;
      Error : Boolean;
   begin
      pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First,
        "Attempt to wait for a nonexistent call to be abortable.");
      Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
      pragma Assert (Call.Mode = Asynchronous_Call,
        "Attempt to wait for a non-asynchronous call to be abortable");

      Write_Lock (Caller.L, Error);
      while not Call.Abortable loop
         Cond_Wait (Caller.Cond, Caller.L);
      end loop;
      Unlock (Caller.L);
   end Wait_Until_Abortable;

   ---------------------
   -- Next_Entry_Call --
   ---------------------

   --   This procedure assumes that a task will have to enter the eggshell to
   --   cancel a call, so there is no need to check for cancellation here.
   --   This seems to obviate the need to lock the task at this point, since
   --   the task will be forced to wait before doing the cancellation, meaning
   --   that it will not take place.

   procedure Next_Entry_Call
     (Object    : Protection_Access;
      Barriers  : Barrier_Vector;
      Uninterpreted_Data : out System.Address;
      E         : out Protected_Entry_Index)
   is
      TAS_Result         : Boolean;
      Pend               : Entry_Call_Link := Object.Pending_Call;
      Ceiling_Violation  : Boolean;
   begin
      Object.Pending_Call := null;
      Object.Call_In_Progress := null;
      if Pend /= null then

         pragma Assert (Self = Pend.Self,
           "Pending call handled by a task that did not pend it.");

         --   Note that the main cost of the above assertion is likely
         --   to be the call to Self.  If this is not optimized away,
         --   nulling out Assert will not be of much value.

         if Barriers (Protected_Entry_Index (Pend.E)) then
            if not Pend.Abortable then
               Object.Call_In_Progress := Pend;
            else

               Test_And_Set
                 (Pend.Call_Claimed'Address, TAS_Result);

               --  If the call was not claimed, it must have been claimed
               --  for cancellation; it can only get here already claimed
               --  if it has been requeued nonabortably, which is taken
               --  care of above.

               if TAS_Result then

                  --  If the call is claimed but has been cancelled,
                  --  then cancellation has lost the race but is waiting
                  --  for someone to do the cancel.  Do it here by simply
                  --  ignoring it.
                  --  ??? This is OK, I think, but if we claim the call
                  --      it is also OK to service it.  We just have to
                  --      make sure that the caller is awakened
                  --      after service is complete.  This would probably
                  --      be a better solution.

                  if Pend.Cancel_Requested then
                     declare
                        Caller : Task_ID := Object.Call_In_Progress.Self;
                     begin
                        Write_Lock (Caller.L, Ceiling_Violation);
                        Pend.Cancelled := True;
                        Cond_Signal (Caller.Cond);
                        Unlock (Caller.L);
                     end;
                  else
                     Object.Call_In_Progress := Pend;
                  end if;
               end if;

            end if;

         else
            Enqueue (
              Object.Entry_Queues (
              Protected_Entry_Index (Pend.E)),
              Pend);
         end if;

      end if;

      if Object.Call_In_Progress = null then
         Select_Protected_Entry_Call
           (Object,
            Barriers,
            Object.Call_In_Progress);
      end if;

      if Object.Call_In_Progress /= null then
         E := Protected_Entry_Index (Object.Call_In_Progress.E);
         Uninterpreted_Data := Object.Call_In_Progress.Uninterpreted_Data;

      else
         E := Null_Protected_Entry;
      end if;

   end Next_Entry_Call;

   -------------------------
   -- Complete_Entry_Body --
   -------------------------

   procedure Complete_Entry_Body
     (Object           : Protection_Access;
      Pending_Serviced : out Boolean)
   is
   begin
      Exceptional_Complete_Entry_Body
        (Object, Pending_Serviced, System.Compiler_Exceptions.Null_Exception);

   end Complete_Entry_Body;

   -------------------------------------
   -- Exceptional_Complete_Entry_Body --
   -------------------------------------

   procedure Exceptional_Complete_Entry_Body
     (Object           : Protection_Access;
      Pending_Serviced : out Boolean;
      Ex               : System.Compiler_Exceptions.Exception_ID)
   is
      Caller : Task_ID := Object.Call_In_Progress.Self;
      Error : Boolean;

   begin
      Pending_Serviced := False;
      Object.Call_In_Progress.Exception_To_Raise := Ex;

      if Object.Pending_Call /= null then
         pragma Assert (Object.Pending_Call = Object.Call_In_Progress,
           "Serviced a protected entry call when another was pending");

         Pending_Serviced := True;
         Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
         Object.Pending_Call := null;
      end if;

      --   If we have completed a pending entry call, pop it and set the
      --   Pending_Serviced flag to indicate that it is complete.

      Write_Lock (Caller.L, Error);
      Object.Call_In_Progress.Done := True;
      Unlock (Caller.L);

      if Object.Call_In_Progress.Mode = Asynchronous_Call then
         Utilities.Abort_To_Level
           (Caller, Object.Call_In_Progress.Level - 1);

      elsif Object.Call_In_Progress.Mode = Simple_Call then
         Cond_Signal (Caller.Cond);
      end if;

      Object.Pending_Call := null;

   end Exceptional_Complete_Entry_Body;

   -------------
   -- Unclaim --
   -------------

   procedure Unclaim
     (Entry_Call : Entry_Call_Link;
      Cancelled  : out Boolean)
   is
      E                 : Protected_Entry_Index :=
        Protected_Entry_Index (Entry_Call.E);
      Object            : Protection_Access     :=
        Address_To_Protection_Access (Entry_Call.Called_PO);
      Caller : Task_ID  := Entry_Call.Self;
      TAS_Result        : Boolean;
      Ceiling_Violation : Boolean;
   begin
      Cancelled := False;
      if Entry_Call.Abortable then

         Entry_Call.Call_Claimed := False;

         --  If cancellation has been requested, try to claim the
         --  call again.  If this fails, the cancellation operation
         --  has claimed it an will take care of the cancel.  If
         --  it succeeds, do the cancel here.

         if Entry_Call.Cancel_Requested then

            Cancelled := True;

            Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);

            if TAS_Result then
               Write_Lock (Caller.L, Ceiling_Violation);
               Entry_Call.Cancelled := True;
               Cond_Signal (Caller.Cond);
               Unlock (Caller.L);
            end if;

         end if;
      end if;
   end Unclaim;

   -----------------------------
   -- Requeue_Protected_Entry --
   -----------------------------

   procedure Requeue_Protected_Entry
     (Object     : Protection_Access;
      New_Object : Protection_Access;
      E          : Protected_Entry_Index;
      With_Abort : Boolean)
   is
      Entry_Call         : Entry_Call_Link := Object.Call_In_Progress;
      Ceiling_Violation  : Boolean;
      Call_Cancelled     : Boolean := False;
   begin
      Entry_Call.Abortable := With_Abort;
      if With_Abort then
         Unclaim (Entry_Call, Call_Cancelled);
      end if;
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Called_PO := Protection_Access_To_Address (New_Object);

      if not Call_Cancelled then
         if Object = New_Object then
            Enqueue (Object.Entry_Queues (E), Entry_Call);
         else
            New_Object.Pending_Call := Entry_Call;
         end if;
      end if;

      Object.Call_In_Progress := null;

   end Requeue_Protected_Entry;

   -------------------------------------
   -- Requeue_Task_To_Protected_Entry --
   -------------------------------------

   procedure Requeue_Task_To_Protected_Entry
     (New_Object : Protection_Access;
      E          : Protected_Entry_Index;
      With_Abort : Boolean)
   is
      Old_Acceptor : Task_ID := Self;
      Entry_Call : Entry_Call_Link;
      Error : Boolean;

   begin
      Write_Lock (Old_Acceptor.L, Error);
      Entry_Call := Old_Acceptor.Call;
      Old_Acceptor.Call := null;
      Unlock (Old_Acceptor.L);
      Entry_Call.Abortable := With_Abort;
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Called_PO := Protection_Access_To_Address (New_Object);

      if With_Abort then
         Entry_Call.Call_Claimed := False;
      end if;

      New_Object.Pending_Call := Entry_Call;
   end Requeue_Task_To_Protected_Entry;

   ---------------------
   -- Protected_Count --
   ---------------------

   function Protected_Count
     (Object : Protection;
      E      : Protected_Entry_Index)
      return   Natural
   is
   begin
      return Count_Waiting (Object.Entry_Queues (E));
   end Protected_Count;

   ------------------------
   -- Send_Program_Error --
   ------------------------

   procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is
      Current_Task  : Task_ID;
      Error : Boolean;
   begin
      Current_Task := Entry_Call.Self;
      Entry_Call.Exception_To_Raise :=
        System.Compiler_Exceptions.Program_Error_ID;
      Write_Lock (Current_Task.L, Error);
      Entry_Call.Done := True;
      Unlock (Current_Task.L);
      Utilities.Abort_To_Level
        (Current_Task, Entry_Call.Level - 1);
   end Send_Program_Error;

   -----------------------------
   -- Broadcast_Program_Error --
   -----------------------------

   procedure Broadcast_Program_Error
     (Object        : Protection_Access) is
      Entry_Call    : Entry_Call_Link;

   begin
      Entry_Call := Object.Pending_Call;
      if Entry_Call /= null then
         Send_Program_Error (Entry_Call);
         Object.Pending_Call := null;
      end if;

      for E in Object.Entry_Queues'Range loop
         Dequeue_Head (Object.Entry_Queues (E), Entry_Call);

         while Entry_Call /= null loop
            pragma Assert (Entry_Call.Mode /= Conditional_Call or else
              Utilities.Runtime_Assert_Shutdown (
                "Conditional call found on entry queue."));
            Send_Program_Error (Entry_Call);
            Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
         end loop;
      end loop;
   end Broadcast_Program_Error;

end System.Tasking.Protected_Objects;
