Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --

--                                                                          --

--            S Y S T E M . T A S K I N G . R E N D E Z V O U S             --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--         Copyright (C) 1992-2005, Free Software Foundation, Inc.          --

--                                                                          --

-- GNARL 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. GNARL 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 GNARL; 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.                                      --

--                                                                          --

-- GNARL was developed by the GNARL team at Florida State University.       --

-- Extensive contributions were provided by Ada Core Technologies, Inc.     --

--                                                                          --

------------------------------------------------------------------------------

with Ada.Exceptions;

--  Used for Exception_ID

--           Null_Id

--           Transfer_Occurrence

--           Raise_Exception

with System.Task_Primitives.Operations;

--  used for Get_Priority

--           Set_Priority

--           Write_Lock

--           Unlock

--           Sleep

--           Wakeup

--           Timed_Sleep

with System.Tasking.Entry_Calls;

--  Used for Wait_For_Completion

--           Wait_For_Completion_With_Timeout

--           Wait_Until_Abortable

with System.Tasking.Initialization;

--  used for Defer_Abort

--           Undefer_Abort

--           Poll_Base_Priority_Change

--           Do_Pending_Action

with System.Tasking.Queuing;

--  used for Enqueue

--           Dequeue_Head

--           Select_Task_Entry_Call

--           Count_Waiting

with System.Tasking.Utilities;

--  used for Check_Exception

--           Make_Passive

--           Wakeup_Entry_Caller

--           Exit_One_ATC_Level

with System.Tasking.Protected_Objects.Operations;

--  used for PO_Do_Or_Queue

--           PO_Service_Entries

--           Lock_Entries

with System.Tasking.Debug;

--  used for Trace

with System.Parameters;

--  used for Single_Lock

--           Runtime_Traces

with System.Traces.Tasking;

--  used for Send_Trace_Info

package body System.Tasking.Rendezvous is

   package STPO renames System.Task_Primitives.Operations;

   package POO renames Protected_Objects.Operations;

   package POE renames Protected_Objects.Entries;

   use Parameters;

   use Task_Primitives.Operations;

   use System.Traces;

   use System.Traces.Tasking;

   type Select_Treatment is (

     Accept_Alternative_Selected,   --  alternative with non-null body

     Accept_Alternative_Completed,  --  alternative with null body

     Else_Selected,

     Terminate_Selected,

     Accept_Alternative_Open,

     No_Alternative_Open);

   ----------------

   -- Local Data --

   ----------------

   Default_Treatment : constant array (Select_Modes) of Select_Treatment :=

     (Simple_Mode         => No_Alternative_Open,

      Else_Mode           => Else_Selected,

      Terminate_Mode      => Terminate_Selected,

      Delay_Mode          => No_Alternative_Open);

   New_State : constant array (Boolean, Entry_Call_State)

     of Entry_Call_State :=

       (True =>

         (Never_Abortable   => Never_Abortable,

          Not_Yet_Abortable => Now_Abortable,

          Was_Abortable     => Now_Abortable,

          Now_Abortable     => Now_Abortable,

          Done              => Done,

          Cancelled         => Cancelled),

        False =>

         (Never_Abortable   => Never_Abortable,

          Not_Yet_Abortable => Not_Yet_Abortable,

          Was_Abortable     => Was_Abortable,

          Now_Abortable     => Now_Abortable,

          Done              => Done,

          Cancelled         => Cancelled)

       );

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Local_Defer_Abort (Self_Id : Task_Id) renames

     System.Tasking.Initialization.Defer_Abort_Nestable;

   procedure Local_Undefer_Abort (Self_Id : Task_Id) renames

     System.Tasking.Initialization.Undefer_Abort_Nestable;

   --  Florist defers abort around critical sections that

   --  make entry calls to the Interrupt_Manager task, which

   --  violates the general rule about top-level runtime system

   --  calls from abort-deferred regions.  It is not that this is

   --  unsafe, but when it occurs in "normal" programs it usually

   --  means either the user is trying to do a potentially blocking

   --  operation from within a protected object, or there is a

   --  runtime system/compiler error that has failed to undefer

   --  an earlier abort deferral. Thus, for debugging it may be

   --  wise to modify the above renamings to the non-nestable forms.

   procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);

   pragma Inline (Boost_Priority);

   --  Call this only with abort deferred and holding lock of Acceptor

   procedure Call_Synchronous

     (Acceptor              : Task_Id;

      E                     : Task_Entry_Index;

      Uninterpreted_Data    : System.Address;

      Mode                  : Call_Modes;

      Rendezvous_Successful : out Boolean);

   pragma Inline (Call_Synchronous);

   --  This call is used to make a simple or conditional entry call.

   --  Called from Call_Simple and Task_Entry_Call.

   procedure Setup_For_Rendezvous_With_Body

     (Entry_Call : Entry_Call_Link;

      Acceptor   : Task_Id);

   pragma Inline (Setup_For_Rendezvous_With_Body);

   --  Call this only with abort deferred and holding lock of Acceptor.

   --  When a rendezvous selected (ready for rendezvous) we need to save

   --  previous caller and adjust the priority. Also we need to make

   --  this call not Abortable (Cancellable) since the rendezvous has

   --  already been started.

   procedure Wait_For_Call (Self_Id : Task_Id);

   pragma Inline (Wait_For_Call);

   --  Call this only with abort deferred and holding lock of Self_Id.

   --  An accepting task goes into Sleep by calling this routine

   --  waiting for a call from the caller or waiting for an abort.

   --  Make sure Self_Id is locked before calling this routine.

   -----------------

   -- Accept_Call --

   -----------------

   procedure Accept_Call

     (E                  : Task_Entry_Index;

      Uninterpreted_Data : out System.Address)

   is

      Self_Id      : constant Task_Id := STPO.Self;

      Caller       : Task_Id := null;

      Open_Accepts : aliased Accept_List (1 .. 1);

      Entry_Call   : Entry_Call_Link;

   begin

      Initialization.Defer_Abort (Self_Id);

      if Single_Lock then

         Lock_RTS;

      end if;

      STPO.Write_Lock (Self_Id);

      if not Self_Id.Callable then

         pragma Assert (Self_Id.Pending_ATC_Level = 0);

         pragma Assert (Self_Id.Pending_Action);

         STPO.Unlock (Self_Id);

         if Single_Lock then

            Unlock_RTS;

         end if;

         Initialization.Undefer_Abort (Self_Id);

         --  Should never get here ???

         pragma Assert (False);

         raise Standard'Abort_Signal;

      end if;

      Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);

      if Entry_Call /= null then

         Caller := Entry_Call.Self;

         Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);

         Uninterpreted_Data := Entry_Call.Uninterpreted_Data;

      else

         --  Wait for a caller

         Open_Accepts (1).Null_Body := False;

         Open_Accepts (1).S := E;

         Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;

         --  Wait for normal call

         if Parameters.Runtime_Traces then

            Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));

         end if;

         pragma Debug

           (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));

         Wait_For_Call (Self_Id);

         pragma Assert (Self_Id.Open_Accepts = null);

         if Self_Id.Common.Call /= null then

            Caller := Self_Id.Common.Call.Self;

            Uninterpreted_Data :=

              Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;

         else

            --  Case of an aborted task

            Uninterpreted_Data := System.Null_Address;

         end if;

      end if;

      --  Self_Id.Common.Call should already be updated by the Caller

      --  On return, we will start the rendezvous.

      STPO.Unlock (Self_Id);

      if Single_Lock then

         Unlock_RTS;

      end if;

      Initialization.Undefer_Abort (Self_Id);

      if Parameters.Runtime_Traces then

         Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));

      end if;

   end Accept_Call;

   --------------------

   -- Accept_Trivial --

   --------------------

   procedure Accept_Trivial (E : Task_Entry_Index) is

      Self_Id      : constant Task_Id := STPO.Self;

      Caller       : Task_Id := null;

      Open_Accepts : aliased Accept_List (1 .. 1);

      Entry_Call   : Entry_Call_Link;

   begin

      Initialization.Defer_Abort_Nestable (Self_Id);

      if Single_Lock then

         Lock_RTS;

      end if;

      STPO.Write_Lock (Self_Id);

      if not Self_Id.Callable then

         pragma Assert (Self_Id.Pending_ATC_Level = 0);

         pragma Assert (Self_Id.Pending_Action);

         STPO.Unlock (Self_Id);

         if Single_Lock then

            Unlock_RTS;

         end if;

         Initialization.Undefer_Abort_Nestable (Self_Id);

         --  Should never get here ???

         pragma Assert (False);

         raise Standard'Abort_Signal;

      end if;

      Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);

      if Entry_Call = null then

         --  Need to wait for entry call

         Open_Accepts (1).Null_Body := True;

         Open_Accepts (1).S := E;

         Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;

         if Parameters.Runtime_Traces then

            Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));

         end if;

         pragma Debug

          (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));

         Wait_For_Call (Self_Id);

         pragma Assert (Self_Id.Open_Accepts = null);

         --  No need to do anything special here for pending abort.

         --  Abort_Signal will be raised by Undefer on exit.

         STPO.Unlock (Self_Id);

      else  --  found caller already waiting

         pragma Assert (Entry_Call.State < Done);

         STPO.Unlock (Self_Id);

         Caller := Entry_Call.Self;

         STPO.Write_Lock (Caller);

         Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);

         STPO.Unlock (Caller);

      end if;

      if Parameters.Runtime_Traces then

         Send_Trace_Info (M_Accept_Complete);

         --  Fake one, since there is (???) no way

         --  to know that the rendezvous is over

         Send_Trace_Info (M_RDV_Complete);

      end if;

      if Single_Lock then

         Unlock_RTS;

      end if;

      Initialization.Undefer_Abort_Nestable (Self_Id);

   end Accept_Trivial;

   --------------------

   -- Boost_Priority --

   --------------------

   procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is

      Caller        : constant Task_Id := Call.Self;

      Caller_Prio   : constant System.Any_Priority := Get_Priority (Caller);

      Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);

   begin

      if Caller_Prio > Acceptor_Prio then

         Call.Acceptor_Prev_Priority := Acceptor_Prio;

         Set_Priority (Acceptor, Caller_Prio);

      else

         Call.Acceptor_Prev_Priority := Priority_Not_Boosted;

      end if;

   end Boost_Priority;

   -----------------

   -- Call_Simple --

   -----------------

   procedure Call_Simple

     (Acceptor           : Task_Id;

      E                  : Task_Entry_Index;

      Uninterpreted_Data : System.Address)

   is

      Rendezvous_Successful : Boolean;

   begin

      --  If pragma Detect_Blocking is active then Program_Error must be

      --  raised if this potentially blocking operation is called from a

      --  protected action.

      if System.Tasking.Detect_Blocking

        and then STPO.Self.Common.Protected_Action_Nesting > 0

      then

         Ada.Exceptions.Raise_Exception

           (Program_Error'Identity, "potentially blocking operation");

      end if;

      Call_Synchronous

        (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);

   end Call_Simple;

   ----------------------

   -- Call_Synchronous --

   ----------------------

   procedure Call_Synchronous

     (Acceptor              : Task_Id;

      E                     : Task_Entry_Index;

      Uninterpreted_Data    : System.Address;

      Mode                  : Call_Modes;

      Rendezvous_Successful : out Boolean)

   is

      Self_Id    : constant Task_Id := STPO.Self;

      Level      : ATC_Level;

      Entry_Call : Entry_Call_Link;

   begin

      pragma Assert (Mode /= Asynchronous_Call);

      Local_Defer_Abort (Self_Id);

      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;

      pragma Debug

        (Debug.Trace (Self_Id, "CS: entered ATC level: " &

         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));

      Level := Self_Id.ATC_Nesting_Level;

      Entry_Call := Self_Id.Entry_Calls (Level)'Access;

      Entry_Call.Next := null;

      Entry_Call.Mode := Mode;

      Entry_Call.Cancellation_Attempted := False;

      if Parameters.Runtime_Traces then

         Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));

      end if;

      --  If this is a call made inside of an abort deferred region,

      --  the call should be never abortable.

      if Self_Id.Deferral_Level > 1 then

         Entry_Call.State := Never_Abortable;

      else

         Entry_Call.State := Now_Abortable;

      end if;

      Entry_Call.E := Entry_Index (E);

      Entry_Call.Prio := Get_Priority (Self_Id);

      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;

      Entry_Call.Called_Task := Acceptor;

      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;

      --  Note: the caller will undefer abort on return (see WARNING above)

      if Single_Lock then

         Lock_RTS;

      end if;

      if not Task_Do_Or_Queue

        (Self_Id, Entry_Call, With_Abort => True)

      then

         STPO.Write_Lock (Self_Id);

         Utilities.Exit_One_ATC_Level (Self_Id);

         STPO.Unlock (Self_Id);

         if Single_Lock then

            Unlock_RTS;

         end if;

         if Parameters.Runtime_Traces then

            Send_Trace_Info (E_Missed, Acceptor);

         end if;

         Initialization.Undefer_Abort (Self_Id);

         raise Tasking_Error;

      end if;

      STPO.Write_Lock (Self_Id);

      pragma Debug

        (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));

      Entry_Calls.Wait_For_Completion (Entry_Call);

      pragma Debug

        (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));

      Rendezvous_Successful := Entry_Call.State = Done;

      STPO.Unlock (Self_Id);

      if Single_Lock then

         Unlock_RTS;

      end if;

      Local_Undefer_Abort (Self_Id);

      Entry_Calls.Check_Exception (Self_Id, Entry_Call);

   end Call_Synchronous;

   --------------

   -- Callable --

   --------------

   function Callable (T : Task_Id) return Boolean is

      Result  : Boolean;

      Self_Id : constant Task_Id := STPO.Self;

   begin

      Initialization.Defer_Abort (Self_Id);

      if Single_Lock then

         Lock_RTS;

      end if;

      STPO.Write_Lock (T);

      Result := T.Callable;

      STPO.Unlock (T);

      if Single_Lock then

         Unlock_RTS;

      end if;

      Initialization.Undefer_Abort (Self_Id);

      return Result;

   end Callable;

   ----------------------------

   -- Cancel_Task_Entry_Call --

   ----------------------------

   procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is

   begin

      Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);

   end Cancel_Task_Entry_Call;

   -------------------------

   -- Complete_Rendezvous --

   -------------------------

   procedure Complete_Rendezvous is

   begin

      Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);

   end Complete_Rendezvous;

   -------------------------------------

   -- Exceptional_Complete_Rendezvous --

   -------------------------------------

   procedure Exceptional_Complete_Rendezvous

     (Ex : Ada.Exceptions.Exception_Id)

   is

      Self_Id                : constant Task_Id := STPO.Self;

      Entry_Call             : Entry_Call_Link := Self_Id.Common.Call;

      Caller                 : Task_Id;

      Called_PO              : STPE.Protection_Entries_Access;

      Acceptor_Prev_Priority : Integer;

      Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;

      Ceiling_Violation  : Boolean;

      use type Ada.Exceptions.Exception_Id;

      procedure Internal_Reraise;

      pragma Import (C, Internal_Reraise, "__gnat_reraise");

      procedure Transfer_Occurrence

        (Target : Ada.Exceptions.Exception_Occurrence_Access;

         Source : Ada.Exceptions.Exception_Occurrence);

      pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");

      use type STPE.Protection_Entries_Access;

   begin

      --  Consider phasing out Complete_Rendezvous in favor

      --  of direct call to this with Ada.Exceptions.Null_ID.

      --  See code expansion examples for Accept_Call and Selective_Wait.

      --  Also consider putting an explicit re-raise after this call, in

      --  the generated code. That way we could eliminate the

      --  code here that reraises the exception.

      --  The deferral level is critical here,

      --  since we want to raise an exception or allow abort to take

      --  place, if there is an exception or abort pending.

      pragma Debug

       (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));

      if Ex = Ada.Exceptions.Null_Id then

         --  The call came from normal end-of-rendezvous,

         --  so abort is not yet deferred.

         if Parameters.Runtime_Traces then

            Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);

         end if;

         Initialization.Defer_Abort_Nestable (Self_Id);

      end if;

      --  We need to clean up any accepts which Self may have

      --  been serving when it was aborted.

      if Ex = Standard'Abort_Signal'Identity then

         if Single_Lock then

            Lock_RTS;

         end if;

         while Entry_Call /= null loop

            Entry_Call.Exception_To_Raise := Tasking_Error'Identity;

            --  All forms of accept make sure that the acceptor is not

            --  completed, before accepting further calls, so that we

            --  can be sure that no further calls are made after the

            --  current calls are purged.

            Caller := Entry_Call.Self;

            --  Take write lock. This follows the lock precedence rule that

            --  Caller may be locked while holding lock of Acceptor.

            --  Complete the call abnormally, with exception.

            STPO.Write_Lock (Caller);

            Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);

            STPO.Unlock (Caller);

            Entry_Call := Entry_Call.Acceptor_Prev_Call;

         end loop;

         if Single_Lock then

            Unlock_RTS;

         end if;

      else

         Caller := Entry_Call.Self;

         if Entry_Call.Needs_Requeue then

            --  We dare not lock Self_Id at the same time as Caller,

            --  for fear of deadlock.

            Entry_Call.Needs_Requeue := False;

            Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;

            if Entry_Call.Called_Task /= null then

               --  Requeue to another task entry

               if Single_Lock then

                  Lock_RTS;

               end if;

               if not Task_Do_Or_Queue

                 (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)

               then

                  if Single_Lock then

                     Unlock_RTS;

                  end if;

                  Initialization.Undefer_Abort (Self_Id);

                  raise Tasking_Error;

               end if;

               if Single_Lock then

                  Unlock_RTS;

               end if;

            else

               --  Requeue to a protected entry

               Called_PO := POE.To_Protection (Entry_Call.Called_PO);

               STPE.Lock_Entries (Called_PO, Ceiling_Violation);

               if Ceiling_Violation then

                  pragma Assert (Ex = Ada.Exceptions.Null_Id);

                  Exception_To_Raise := Program_Error'Identity;

                  Entry_Call.Exception_To_Raise := Exception_To_Raise;

                  if Single_Lock then

                     Lock_RTS;

                  end if;

                  STPO.Write_Lock (Caller);

                  Initialization.Wakeup_Entry_Caller

                    (Self_Id, Entry_Call, Done);

                  STPO.Unlock (Caller);

                  if Single_Lock then

                     Unlock_RTS;

                  end if;

               else

                  POO.PO_Do_Or_Queue

                    (Self_Id, Called_PO, Entry_Call,

                     Entry_Call.Requeue_With_Abort);

                  POO.PO_Service_Entries (Self_Id, Called_PO);

               end if;

            end if;

            Entry_Calls.Reset_Priority

              (Self_Id, Entry_Call.Acceptor_Prev_Priority);

         else

            --  The call does not need to be requeued

            Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;

            Entry_Call.Exception_To_Raise := Ex;

            if Single_Lock then

               Lock_RTS;

            end if;

            STPO.Write_Lock (Caller);

            --  Done with Caller locked to make sure that Wakeup is not lost

            if Ex /= Ada.Exceptions.Null_Id then

               Transfer_Occurrence

                 (Caller.Common.Compiler_Data.Current_Excep'Access,

                  Self_Id.Common.Compiler_Data.Current_Excep);

            end if;

            Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;

            Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);

            STPO.Unlock (Caller);

            if Single_Lock then

               Unlock_RTS;

            end if;

            Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);

         end if;

      end if;

      Initialization.Undefer_Abort (Self_Id);

      if Exception_To_Raise /= Ada.Exceptions.Null_Id then

         Internal_Reraise;

      end if;

      --  ??? Do we need to give precedence to Program_Error that might be

      --  raised due to failure of finalization, over Tasking_Error from

      --  failure of requeue?

   end Exceptional_Complete_Rendezvous;

   -------------------------------------

   -- Requeue_Protected_To_Task_Entry --

   -------------------------------------

   procedure Requeue_Protected_To_Task_Entry

     (Object     : STPE.Protection_Entries_Access;

      Acceptor   : Task_Id;

      E          : Task_Entry_Index;

      With_Abort : Boolean)

   is

      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;

   begin

      pragma Assert (STPO.Self.Deferral_Level > 0);

      Entry_Call.E := Entry_Index (E);

      Entry_Call.Called_Task := Acceptor;

      Entry_Call.Called_PO := Null_Address;

      Entry_Call.Requeue_With_Abort := With_Abort;

      Object.Call_In_Progress := null;

   end Requeue_Protected_To_Task_Entry;

   ------------------------

   -- Requeue_Task_Entry --

   ------------------------

   procedure Requeue_Task_Entry

     (Acceptor   : Task_Id;

      E          : Task_Entry_Index;

      With_Abort : Boolean)

   is

      Self_Id    : constant Task_Id := STPO.Self;

      Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;

   begin

      Initialization.Defer_Abort (Self_Id);

      Entry_Call.Needs_Requeue := True;

      Entry_Call.Requeue_With_Abort := With_Abort;

      Entry_Call.E := Entry_Index (E);

      Entry_Call.Called_Task := Acceptor;

      Initialization.Undefer_Abort (Self_Id);