-----------------------------------------------------------------------------
--                                                                         --
--                GNU ADA RUNTIME 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                                 --
--                                                                         --
--                            $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.Task_Primitives; use System.Task_Primitives;

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

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

with System.Tasking.Utilities;
--  Used for, Utilities.Null_PO;
--            Utilities.Vulnerable_Complete_Activation
--            Utilities.Abort_To_Level
--            Utilities.Reset_Priority
--            Utilities.Terminate_Alternative
--            Utilities.Runtime_Assert_Shutdown

with System.Compiler_Exceptions;
--  Used for, Compiler_Exceptions."="
--            Exception_ID
--            Null_Exception
--            Tasking_Error_ID

with Unchecked_Conversion;

package body System.Tasking.Rendezvous is

   procedure Defer_Abortion
     renames Abortion.Defer_Abortion;

   procedure Undefer_Abortion renames
     Abortion.Undefer_Abortion;

   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);

   type Select_Treatment is (
     Accept_Alternative_Selected,
     Accept_Alternative_Completed,
     Else_Selected,
     Terminate_Selected,
     Accept_Alternative_Open,
     No_Alternative_Open);

   Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
     (Simple_Mode         => No_Alternative_Open,
      Else_Mode           => Else_Selected,
      Terminate_Mode      => Terminate_Selected);

   procedure Vulnerable_Cancel_Task_Entry_Call
     (Call                  : Entry_Call_Link;
      Cancel_Was_Successful : out Boolean);
   --  This procedure is used to cancel a task entry call from
   --  within the runtime (including from the interface procedure
   --  Cancel_Protected_Entry_Call).  It assumes that abortion is
   --  deferred, and stores rather than raises any required exceptions.

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Boost_Priority
     (Call     : Entry_Call_Link;
      Acceptor : Task_ID);
   pragma Inline (Boost_Priority);

   procedure Test_Call
     (Entry_Call           : in out Entry_Call_Link;
      Rendezvous_Completed : out Boolean);
   --  Test if a rendezvous can be made right away. Returns True if the
   --  rendezvous has occurred (and finished).
   --  Problem: Try not to call this when the acceptor is not accepting.
   --  What does problem mean??? advice??? why??? absolute rule???

   function Test_Selective_Wait
     (Acceptor     : Task_ID;
      Open_Accepts : Accept_List_Access;
      Select_Mode  : Select_Modes)
      return         Select_Treatment;
   pragma Inline (Test_Selective_Wait);
   --  Test if there is a call waiting on any entry, and whether any selects
   --  are open. Set Acceptor.Chosen_Index to selected alternative if an
   --  accept alternative can be selected.

   procedure Adjust_For_Terminate_Alternative_Call (Acceptor : Task_ID);
   --  Called by caller to wake up the acceptor if it is waiting on
   --  terminate_alternative.

   --------------------
   -- Boost_Priority --
   --------------------

   procedure Boost_Priority
     (Call     : Entry_Call_Link;
      Acceptor : Task_ID)
   is
      Caller : Task_ID := Call.Self;

   begin
      if Get_Priority (Caller.LL_TCB'Access) >
         Get_Priority (Acceptor.LL_TCB'Access)
      then
         Call.Acceptor_Prev_Priority := Acceptor.Current_Priority;
         Acceptor.Current_Priority := Caller.Current_Priority;
         Set_Priority (Acceptor.LL_TCB'Access, Acceptor.Current_Priority);
      else
         Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
      end if;
   end Boost_Priority;

   ---------------
   -- Test_Call --
   ---------------

   procedure Test_Call
     (Entry_Call           : in out Entry_Call_Link;
      Rendezvous_Completed : out Boolean)
   is
      Temp_Entry  : Entry_Index;
      TAS_Result  : Boolean;
      Acceptor_ID : Task_ID;
      Acceptor    : Task_ID;
      Current_Task      : Task_ID := Entry_Call.Self;
      Error       : Boolean;
   begin
      Acceptor := Entry_Call.Called_Task;

      if Acceptor.Accepting = Trivial_Accept then
         Temp_Entry := Entry_Index (Acceptor.Open_Accepts (1).S);

         --  Case of rendezvous accepted

         if Entry_Call.E = Temp_Entry then
            Acceptor.Accepting := Not_Accepting;
            Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
            Acceptor.Call := Entry_Call;
            Entry_Call.Done := True;
            Rendezvous_Completed := True;
            Cond_Signal (Acceptor.Cond); -- Inefficient ???

         --  Case of wait for acceptor

         else
            Rendezvous_Completed := False;
         end if;

      elsif Acceptor.Accepting = Not_Accepting then
         if Callable (Acceptor) then
            Rendezvous_Completed := False;
            --  Wait for acceptor
         else
            if Entry_Call.Mode /= Asynchronous_Call then
               Current_Task.ATC_Nesting_Level :=
                 Current_Task.ATC_Nesting_Level - 1;
            end if;

            Unlock (Acceptor.L);
            Undefer_Abortion;
            raise Tasking_Error;
         end if;

      else
         --  Try to do immediate rendezvous

         for J in Acceptor.Open_Accepts'Range loop
            Temp_Entry := Entry_Index (Acceptor.Open_Accepts (J).S);

            if Entry_Call.E = Temp_Entry then --  do rendezvous
               Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);

               if not TAS_Result then

                  --  This task has been aborted

                  Unlock (Acceptor.L);
                  Write_Lock (Current_Task.L, Error);
                  Current_Task.Suspended_Abortably := True;

                  loop
                     if Current_Task.Pending_Action then
                        if Current_Task.Pending_Priority_Change then
                           Abortion.Change_Base_Priority (Current_Task);
                        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;
                  Unlock (Current_Task.L);
                  Write_Lock (Acceptor.L, Error);

               end if;

               Acceptor.Accepting := Not_Accepting;

               if Acceptor.Open_Accepts (J).Null_Body then
                  Entry_Call.Done := True;
                  Acceptor.Chosen_Index := J;
                  Cond_Signal (Acceptor.Cond);
               else
                  Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
                  Acceptor.Call := Entry_Call;
                  Acceptor.Chosen_Index := J;
                  Boost_Priority (Entry_Call, Acceptor);
                  Cond_Signal (Acceptor.Cond);

                  --  This needs to be protected by the Current_Task's
                  --  mutex, not
                  --  the acceptor's.  Otherwise, there is a risk of loosing a
                  --  signal.  This is dumb code, and probably could be
                  --  fixed to some extent by getting rid of Test_Call. ???

                  Unlock (Acceptor.L);
                  Write_Lock (Current_Task.L, Error);

                  while not Entry_Call.Done loop
                     Cond_Wait (Current_Task.Cond, Current_Task.L);
                  end loop;

                  Unlock (Current_Task.L);
                  Write_Lock (Acceptor.L, Error);
               end if;

               Rendezvous_Completed := True;
               return;
            end if;
         end loop;

         Rendezvous_Completed := False;
      end if;
   end Test_Call;

   ---------------------------------------
   -- Vulnerable_Cancel_Task_Entry_Call --
   ---------------------------------------

   procedure Vulnerable_Cancel_Task_Entry_Call
     (Call                  : Entry_Call_Link;
      Cancel_Was_Successful : out Boolean)
   is
      TAS_Result : Boolean;
      Caller     : Task_ID := Call.Self;
      Acceptor   : Task_ID := Call.Called_Task;
      Error      : Boolean;

   begin
      Cancel_Was_Successful := False;
      Test_And_Set (Call.Call_Claimed'Address, TAS_Result);

      if TAS_Result then
         if not Call.Done then

         --  We should be able to check this flag at this point; we have
         --  claimed the call, so no one will be able to service this call,
         --  so no one else should be able to change the Call.Done flag.

            Write_Lock (Acceptor.L, Error);
            if Onqueue (Call) then
               Dequeue (
                  Acceptor.Entry_Queues (Task_Entry_Index (Call.E)),
                  Call);
            end if;
            Unlock (Acceptor.L);
            Cancel_Was_Successful := True;

            --  Note: this will indicate failure to cancel if the acceptor has
            --  canceled the call due to completion.  Of course, we are going
            --  to raise an exception in that case, so I think that this is
            --  OK; the flag retuned to the application code should never be
            --  used.
         end if;

      else
         Write_Lock (Caller.L, Error);

         while not Call.Done loop
            Cond_Wait (Caller.Cond, Caller.L);
         end loop;

         Unlock (Caller.L);
      end if;

      Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;

      Write_Lock (Caller.L, Error);

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

      Unlock (Caller.L);

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

      Caller.Exception_To_Raise := Call.Exception_To_Raise;

   end Vulnerable_Cancel_Task_Entry_Call;

   -------------------------------------------
   -- Adjust_For_Terminate_Alternative_Call --
   -------------------------------------------

   procedure Adjust_For_Terminate_Alternative_Call (Acceptor : Task_ID) is
      Acceptor_ATCB : Task_ID := Acceptor;
      P             : Task_ID;
      Error         : boolean;
   begin
      Write_Lock (Acceptor_ATCB.L, Error);

      if Acceptor_ATCB.Terminate_Alternative then
         Acceptor_ATCB.Stage := Active;
         Acceptor_ATCB.Awake_Count := Acceptor_ATCB.Awake_Count + 1;

         --  At this point, T.Awake_Count and P.Awaited_Dependent_Count could
         --  be out of synchronization.  However, we know that
         --  P.Awaited_Dependent_Count cannot be zero, and cannot go to zero,
         --  since some other dependent must have just called us.  There should
         --  therefore be no danger of the parent terminating before we
         --  increment P.Awaited_Dependent_Count below.

         if Acceptor_ATCB.Awake_Count = 1 then
            Unlock (Acceptor_ATCB.L);

            if Acceptor_ATCB.Pending_ATC_Level <
              Acceptor_ATCB.ATC_Nesting_Level then
               Abortion.Undefer_Abortion;
               pragma Assert (
                 Utilities.Runtime_Assert_Shutdown (
                   "Continuing after being aborted!"));
            end if;

            P := Acceptor_ATCB.Parent;
            Write_Lock (P.L, Error);

            if P.Awake_Count /= 0 then
               P.Awake_Count := P.Awake_Count + 1;

            else
               Unlock (P.L);
               Utilities.Abort_To_Level (Acceptor, 0);
               Abortion.Undefer_Abortion;
               pragma Assert (
                 Utilities.Runtime_Assert_Shutdown (
                   "Continuing after being aborted!"));
            end if;

            --  Conservative checks which should only matter when an interrupt
            --  entry was chosen. In this case, the current task completes if
            --  the parent has already been signaled that all children have
            --  terminated.

            if Acceptor_ATCB.Master_of_Task = P.Master_Within then
               if P.Awaited_Dependent_Count /= 0 then
                  P.Awaited_Dependent_Count := P.Awaited_Dependent_Count + 1;

               elsif P.Stage = Await_Dependents then
                  Unlock (P.L);
                  Utilities.Abort_To_Level (Acceptor, 0);
                  Abortion.Undefer_Abortion;
                  pragma Assert (
                    Utilities.Runtime_Assert_Shutdown (
                      "Continuing after being aborted!"));
               end if;
            end if;

            Unlock (P.L);

         else
            Unlock (Acceptor_ATCB.L);

            if Acceptor_ATCB.Pending_ATC_Level <
              Acceptor_ATCB.ATC_Nesting_Level then
               Abortion.Undefer_Abortion;
               pragma Assert (
                 Utilities.Runtime_Assert_Shutdown (
                   "Continuing after being aborted!"));
            end if;
         end if;

         Write_Lock (Acceptor_ATCB.L, Error);

         Acceptor_ATCB.Terminate_Alternative := false;
         --  Need to set this flag off in order not to make subsequent calls
         --  to be treated to calls to Select With Terminate Alternative.

      end if;
      Unlock (Acceptor_ATCB.L);

   end Adjust_For_Terminate_Alternative_Call;


   -----------------
   -- Call_Simple --
   -----------------

   procedure Call_Simple
     (Acceptor  : Task_ID;
      E         : Task_Entry_Index;
      Uninterpreted_Data : System.Address)
   is
      Caller : constant Task_ID := Self;

      Acceptor_ATCB         : Task_ID := Acceptor;
      Rendezvous_Completed  : Boolean;
      Level                 : ATC_Level;
      Entry_Call            : Entry_Call_Link;
      Cancel_Was_Successful : Boolean;
      Error                 : Boolean;
   begin
      Defer_Abortion;
      Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
      Level := Caller.ATC_Nesting_Level;

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

      Entry_Call.Next := null;
      Entry_Call.Call_Claimed := False;
      Entry_Call.Mode := Simple_Call;
      Entry_Call.Abortable := True;
      Entry_Call.Done := False;
      Entry_Call.E := Entry_Index (E);
      Entry_Call.Prio := Caller.Current_Priority;
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
      Entry_Call.Called_Task := Acceptor;
      Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;

--      if Acceptor_ATCB.Accepting = Not_Accepting and then
--        not Callable (Acceptor) then
--         --  Acceptor must have gone beyond the complete stage.
--         --  This situation may occur when the acceptor and caller are
--         --  declared in different context. (ex) Interrupt Handler.
--         --  This is the case where the acceptor is completed before
--         --  the entry call is made. In such a case, just cancel the
--         --  call.
--         Unlock (Acceptor_ATCB.L);
--         Vulnerable_Cancel_Task_Entry_Call
--           (Entry_Call, Cancel_Was_Successful);
--         Undefer_Abortion;
--         return;
--      end if;


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

      Adjust_For_Terminate_Alternative_Call (Acceptor);

      Write_Lock (Acceptor_ATCB.L, Error);

      Test_Call (Entry_Call, Rendezvous_Completed);

      if not Rendezvous_Completed then
         Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
         Unlock (Acceptor_ATCB.L);
         Write_Lock (Caller.L, Error);
         Caller.Suspended_Abortably := True;

         while not Entry_Call.Done loop
            if Caller.Pending_Action then
               if Caller.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Caller);
                  --  requeue call at new priority
                  Unlock (Caller.L);
                  Write_Lock (Acceptor_ATCB.L, Error);
                  if Onqueue (Entry_Call) then  --  Dequeued by acceptor?
                     Dequeue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
                     Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
                  end if;
                  Unlock (Acceptor_ATCB.L);
                  Write_Lock (Caller.L, Error);
               end if;

               exit when
                  Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level and then
                  not Entry_Call.Call_Claimed;
            end if;
            Cond_Wait (Caller.Cond, Caller.L);
         end loop;

         Caller.Suspended_Abortably := False;
         Unlock (Caller.L);

      else
         Unlock (Acceptor_ATCB.L);
      end if;

      --  NOTICE:
      --  There is a distinction made between asynchronous calls and the rest:
      --  The asynchronous calls are always cleaned up by
      --  Cancel_Task_Entry_Call, but the others get cleaned up by
      --  Task_Entry_Call or its equivalent.
      --  Complete no longer does a decrement, so who does if this task is
      --  aborted at this point?  The decrement should take
      --  place before undeferring abortion, and that this should include
      --  taking the call off any queue it might be on.
      --  Problem: What if it is claimed in the meantime by an acceptor?  The
      --  test for Call_Claimed in the wait loop is really vulnerable to race
      --  conditions on this point.  We can't get out of the loop until
      --  Call_Claimed is false, but there is nothing to keep it from
      --  staying false.  By the time we get here, rendezvous could be in
      --  progress.  The only solution is to claim the call here in order
      --  to cancel it.  However, what do we do if we loose?  Wait again?
      --  I think so.  I also think that that works: wait until done or
      --  aborted; if aborted, attempt to cancel the call; if that fails, wait
      --  until the call (now well and truly started) completes, without
      --  benefit of Suspended_Abortably.
      --  Problem: The acceptor might also claim the call on completion, to
      --  cancel it.  In that case, it has already awakened us, and won't do it
      --  again.
      --  I think this is OK.  Close_Entries already pretends that the
      --  call has been completed, and has already set the exception at that
      --  point.

      Vulnerable_Cancel_Task_Entry_Call (Entry_Call, Cancel_Was_Successful);
      Undefer_Abortion;

      pragma Assert (
        Caller.Pending_ATC_Level >= Caller.ATC_Nesting_Level or else
          Utilities.Runtime_Assert_Shutdown (
            "Continuing after aborting self!"));

      Utilities.Check_Exception;
   end Call_Simple;

   ----------------------------
   -- Cancel_Task_Entry_Call --
   ----------------------------

   procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
      Caller   : Task_ID := Self;
      Call     : Entry_Call_Link;
      Acceptor : Task_ID;

   begin
      pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First or else
        Utilities.Runtime_Assert_Shutdown (
          "Attempt to cancel nonexistent task entry call."));

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

      pragma Assert (Call.Mode = Asynchronous_Call or else
        Utilities.Runtime_Assert_Shutdown (
          "Attempt to perform ATC on a non-asynchronous task entry call"));

      pragma Assert (Address_To_Protection_Access (Call.Called_PO) =
        Utilities.Null_PO or else
        Utilities.Runtime_Assert_Shutdown (
          "Attempt to use Cancel_Task_Entry_Call on protected entry call."));

      Acceptor := Call.Called_Task;
      Defer_Abortion;
      Vulnerable_Cancel_Task_Entry_Call (Call, Cancelled);
      Undefer_Abortion;
      Utilities.Check_Exception;
   end Cancel_Task_Entry_Call;

   ------------------------
   -- Requeue_Task_Entry --
   ------------------------

   procedure Requeue_Task_Entry
     (Acceptor   : Task_ID;
      E          : Task_Entry_Index;
      With_Abort : Boolean)
   is
      Old_Acceptor  : Task_ID := Self;
      Entry_Call    : Entry_Call_Link;
      Acceptor_ATCB : Task_ID := Acceptor;
      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);

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

      Write_Lock (Acceptor_ATCB.L, Error);
      Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
      Unlock (Acceptor_ATCB.L);
   end Requeue_Task_Entry;

   -------------------------------------
   -- Requeue_Protected_To_Task_Entry --
   -------------------------------------

   procedure Requeue_Protected_To_Task_Entry
     (Object     : Protection_Access;
      Acceptor   : Task_ID;
      E          : Task_Entry_Index;
      With_Abort : Boolean)
   is
      Old_Acceptor  : Task_ID := Self;
      Entry_Call    : Entry_Call_Link;
      Acceptor_ATCB : Task_ID := Acceptor;
      Error         : Boolean;

   begin
      Object.Call_In_Progress.Abortable := With_Abort;
      Object.Call_In_Progress.E := Entry_Index (E);

      if With_Abort then
         Object.Call_In_Progress.Call_Claimed := False;
      end if;

      Write_Lock (Acceptor_ATCB.L, Error);
      Enqueue (Acceptor_ATCB.Entry_Queues (E), Object.Call_In_Progress);
      Unlock (Acceptor_ATCB.L);
   end Requeue_Protected_To_Task_Entry;

   ---------------------
   -- Task_Entry_Call --
   ---------------------

   procedure Task_Entry_Call
     (Acceptor              : Task_ID;
      E                     : Task_Entry_Index;
      Uninterpreted_Data             : System.Address;
      Mode                  : Call_Modes;
      Rendezvous_Successful : out Boolean)
   is
      Caller        : constant Task_ID := Self;
      Acceptor_ATCB : Task_ID := Acceptor;

      Rendezvous_Completed  : Boolean;
      Entry_Call            : Entry_Call_Link;
      Cancel_Was_Successful : Boolean;
      Error                 : Boolean;

   begin
      --  Simple call

      if Mode = Simple_Call then
         Call_Simple (Acceptor, E, Uninterpreted_Data);
         Rendezvous_Successful := True;
         return;

      --  Conditional call

      elsif Mode = Conditional_Call then
         Defer_Abortion;
         Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;

         Entry_Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;

         Entry_Call.Next := null;
         Entry_Call.Call_Claimed := False;
         Entry_Call.Mode := Mode;
         Entry_Call.Abortable := True;
         Entry_Call.Done := False;
         Entry_Call.E := Entry_Index (E);
         Entry_Call.Prio := Caller.Current_Priority;
         Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
         Entry_Call.Called_Task := Acceptor;
         Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;

         Adjust_For_Terminate_Alternative_Call (Acceptor);

         Write_Lock (Acceptor_ATCB.L, Error);
         Test_Call (Entry_Call, Rendezvous_Completed);
         Unlock (Acceptor_ATCB.L);

         Vulnerable_Cancel_Task_Entry_Call (Entry_Call, Cancel_Was_Successful);

         Undefer_Abortion;

         pragma Assert (Caller.Pending_ATC_Level >= Caller.ATC_Nesting_Level
           or else Utilities.Runtime_Assert_Shutdown (
             "Continuing after aborting self!"));

         Utilities.Check_Exception;
         Rendezvous_Successful := Entry_Call.Done;
         return;

      --  Asynchronous call

      else
         Defer_Abortion;
         Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;

         Entry_Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;

         Entry_Call.Next := null;
         Entry_Call.Call_Claimed := False;
         Entry_Call.Mode := Mode;
         Entry_Call.Abortable := True;
         Entry_Call.Done := False;
         Entry_Call.E := Entry_Index (E);
         Entry_Call.Prio := Caller.Current_Priority;
         Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
         Entry_Call.Called_Task := Acceptor;
         Entry_Call.Called_PO :=
             Protection_Access_To_Address (Utilities.Null_PO);
         Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;

         Adjust_For_Terminate_Alternative_Call (Acceptor);

         Write_Lock (Acceptor_ATCB.L, Error);
         Test_Call (Entry_Call, Rendezvous_Completed);

         if not Rendezvous_Completed then
            Enqueue (Acceptor_ATCB.Entry_Queues (E), Entry_Call);
         end if;

         Unlock (Acceptor_ATCB.L);
         Undefer_Abortion;
         Rendezvous_Successful := Entry_Call.Done;

         --  Amazingly, this seems to be all the work that is needed.

         --  Asynchronous calls are set up so that they are always explicitly
         --  canceled in in the compiled code. It might be worth considering
         --  unifying the various calls, and explicitely cancelling all of
         --  them. This is not very efficient, unfortunately.  Perhaps this
         --  call should unify them, with other calls for optimization?
         --  Then who would want to use this call???

      end if;
   end Task_Entry_Call;

   -----------------
   -- Accept_Call --
   -----------------

   procedure Accept_Call
     (E         : Task_Entry_Index;
      Uninterpreted_Data : out System.Address)
   is
      Acceptor     : constant Task_ID := Self;
      Caller       : Task_ID := null;
      TAS_Result   : Boolean;
      Open_Accepts : aliased Accept_List (1 .. 1);
      Entry_Call   : Entry_Call_Link;
      Error        : Boolean;

   begin
      Defer_Abortion;
      Write_Lock (Acceptor.L, Error);

      --  If someone is completing this task, it must be because they plan
      --  to abort it.  This task should not try to access its pending entry
      --  calls or queues in this case, as they are being emptied.  Wait for
      --  abortion to kill us.

      if Acceptor.Stage >= Completing then

         loop
            if Acceptor.Pending_Action then
               if Acceptor.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Acceptor);
               end if;

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

         Unlock (Acceptor.L);
         Undefer_Abortion;
         pragma Assert (
           Utilities.Runtime_Assert_Shutdown (
             "Continuing execution after being aborted."));
      end if;

      loop
         Dequeue_Head (Acceptor.Entry_Queues (E), Entry_Call);

         if Entry_Call /= null then
            Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);
            exit when TAS_Result;

            --  TAS_Result = False only when the caller is already aborted or
            --  timed out; in that case, go on to the next caller on the queue
         else
            exit;
         end if;
      end loop;

      if Entry_Call /= null then
         Caller := Entry_Call.Self;
         Boost_Priority (Entry_Call, Acceptor);
         Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
         Acceptor.Call := Entry_Call;
         Uninterpreted_Data := Entry_Call.Uninterpreted_Data;

      else
         --  Wait for a caller

         Open_Accepts (1).Null_Body := false;
         Open_Accepts (1).S := E;
         Acceptor.Open_Accepts := Open_Accepts'Access;

         Acceptor.Accepting := Simple_Accept;

         --  Wait for normal call

         Acceptor.Suspended_Abortably := True;

         while Acceptor.Accepting /= Not_Accepting loop
            if Acceptor.Pending_Action then
               if Acceptor.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Acceptor);
               end if;

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

         Acceptor.Suspended_Abortably := False;

         if Acceptor.Pending_ATC_Level >= Acceptor.ATC_Nesting_Level then
            Caller := Acceptor.Call.Self;
            Uninterpreted_Data :=
              Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
         end if;

         --  If this task has been aborted, skip the Uninterpreted_Data load
         --  (Caller will not be reliable) and fall through to
         --  Undefer_Abortion which will allow the task to be killed.
      end if;

      --  At this point, the call has been claimed, either by the acceptor
      --  or by the caller on behalf of the acceptor.

      --  Acceptor.Call should already be updated by the Caller

      Unlock (Acceptor.L);
      Undefer_Abortion;

      --  Start rendezvous
   end Accept_Call;

   --------------------
   -- Accept_Trivial --
   --------------------

   procedure Accept_Trivial (E : Task_Entry_Index) is
      Acceptor     : constant Task_ID := Self;
      Caller       : Task_ID := null;
      TAS_Result   : Boolean;
      Open_Accepts : aliased Accept_List (1 .. 1);
      Entry_Call   : Entry_Call_Link;
      Error        : Boolean;

   begin
      Defer_Abortion;
      Write_Lock (Acceptor.L, Error);

      --  If someone is completing this task, it must be because they plan
      --  to abort it.  This task should not try to access its pending entry
      --  calls or queues in this case, as they are being emptied.  Wait for
      --  abortion to kill us.

      if Acceptor.Stage >= Completing then

         loop
            if Acceptor.Pending_Action then
               if Acceptor.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Acceptor);
               end if;

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

         Unlock (Acceptor.L);
         Undefer_Abortion;
         pragma Assert (
           Utilities.Runtime_Assert_Shutdown (
             "Continuing execution after being aborted."));
      end if;

      loop
         Dequeue_Head (Acceptor.Entry_Queues (E), Entry_Call);

         if Entry_Call = null then

            --  Need to wait for call

            Open_Accepts (1).Null_Body := False;
            Open_Accepts (1).S := E;
            Acceptor.Open_Accepts := Open_Accepts'Access;

            Acceptor.Accepting := Trivial_Accept;

            --  Wait for normal entry call

            Acceptor.Suspended_Abortably := True;

            while Acceptor.Accepting /= Not_Accepting loop
               if Acceptor.Pending_Action then
                  if Acceptor.Pending_Priority_Change then
                     Abortion.Change_Base_Priority (Acceptor);
                  end if;

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


            if Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level then
               Unlock (Acceptor.L);
               Undefer_Abortion;
               pragma Assert (
                 Utilities.Runtime_Assert_Shutdown (
                   "Continuing after being aborted!"));
            else
               Acceptor.Suspended_Abortably := False;
               Entry_Call := Acceptor.Call;
               Acceptor.Call := Entry_Call.Acceptor_Prev_Call;
               Caller := Entry_Call.Self;

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

               Unlock (Acceptor.L);
            end if;

            exit;
         end if;

         Test_And_Set (Entry_Call.Call_Claimed'Address, TAS_Result);

         if TAS_Result then

            --  Caller is waiting; there is no accept body

            Caller := Entry_Call.Self;
            Unlock (Acceptor.L);
            Write_Lock (Caller.L, Error);
            Entry_Call.Done := True;

            --  Done with mutex locked to make sure that signal is not lost.

            Unlock (Caller.L);
            Entry_Call.Call_Claimed := False;

            if Entry_Call.Mode = Asynchronous_Call then
               Utilities.Abort_To_Level (Caller, Entry_Call.Level - 1);
            else
               Cond_Signal (Caller.Cond);
            end if;

            exit;
         end if;

         --  TAS_Result = False only when the caller is already aborted or has
         --  timed out; in that case, we go on to the next caller on the queue

      end loop;

      Undefer_Abortion;
   end Accept_Trivial;

   -------------------------------------
   -- Exceptional_Complete_Rendezvous --
   -------------------------------------

   procedure Exceptional_Complete_Rendezvous
     (Ex : Compiler_Exceptions.Exception_ID)
   is
      Acceptor      : constant Task_ID := Self;
      Caller        : Task_ID;
      Call          : Entry_Call_Link;
      Prev_Priority : Rendezvous_Priority;
      Error         : Boolean;

   begin
      Defer_Abortion;
      Call := Acceptor.Call;
      Acceptor.Call := Call.Acceptor_Prev_Call;
      Prev_Priority := Call.Acceptor_Prev_Priority;
      Call.Exception_To_Raise := Ex;
      Caller := Call.Self;
      Call.Call_Claimed := False;
      Write_Lock (Caller.L, Error);
      Call.Done := True;
      Unlock (Caller.L);

      if Call.Mode = Asynchronous_Call then
         Utilities.Abort_To_Level (Caller, Call.Level - 1);
      else
         Cond_Signal (Caller.Cond);
      end if;

      Utilities.Reset_Priority (Prev_Priority, Acceptor);

      Acceptor.Exception_To_Raise := Ex;

      --  Save the exception for Complete_Rendezvous.

      Undefer_Abortion;
      Utilities.Check_Exception;
   end Exceptional_Complete_Rendezvous;

   -------------------------
   -- Complete_Rendezvous --
   -------------------------

   procedure Complete_Rendezvous is
   begin
      Exceptional_Complete_Rendezvous (Compiler_Exceptions.Null_Exception);
   end Complete_Rendezvous;

   -------------------------
   -- Test_Selective_Wait --
   -------------------------


   function Test_Selective_Wait
     (Acceptor     : Task_ID;
      Open_Accepts : Accept_List_Access;
      Select_Mode  : Select_Modes) return Select_Treatment
   is
      Temp_Entry : Task_Entry_Index;
      TAS_Result : Boolean;
      Treatment  : Select_Treatment;
      Entry_Call : Entry_Call_Link;
      Caller     : Task_ID;
      Error      : Boolean;
      Selection  : Select_Index;
   begin
      Treatment := Default_Treatment (Select_Mode);
      Acceptor.Chosen_Index := No_Rendezvous;

      Select_Task_Entry_Call (Acceptor, Open_Accepts, Entry_Call, Selection);

      if Entry_Call /= null then
         if Open_Accepts (Selection).Null_Body then
            Caller := Entry_Call.Self;
            Entry_Call.Call_Claimed := False;
            Write_Lock (Caller.L, Error);
            Entry_Call.Done := True;
            Unlock (Caller.L);
            if Entry_Call.Mode = Asynchronous_Call then
               Utilities.Abort_To_Level (Caller, Entry_Call.Level - 1);
            else
               Cond_Signal (Caller.Cond);
            end if;
            Treatment := Accept_Alternative_Completed;
         else
            Boost_Priority (Entry_Call, Acceptor);
            Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
            Acceptor.Call := Entry_Call;
            Treatment := Accept_Alternative_Selected;
         end if;
         Acceptor.Chosen_Index := Selection;
      elsif Treatment = No_Alternative_Open then
         Treatment := Accept_Alternative_Open;
      end if;

      --  Do rendezvous

      return Treatment;

   end Test_Selective_Wait;

   --------------------
   -- Selective_Wait --
   --------------------

   procedure Selective_Wait
     (Open_Accepts : Accept_List_Access;
      Select_Mode  : Select_Modes;
      Uninterpreted_Data    : out System.Address;
      Index        : out Select_Index)
   is
      Acceptor  : constant Task_ID := Self;
      Treatment : Select_Treatment;
      I_Result  : Integer;
      Error     : Boolean;

   begin
      Defer_Abortion;
      Write_Lock (Acceptor.L, Error);

      --  If someone is completing this task, it must be because they plan
      --  to abort it.  This task should not try to access its pending entry
      --  calls or queues in this case, as they are being emptied.  Wait for
      --  abortion to kill us.

      if Acceptor.Stage >= Completing then

         loop
            if Acceptor.Pending_Action then
               if Acceptor.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Acceptor);
               end if;

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

         Undefer_Abortion;
         pragma Assert (
           Utilities.Runtime_Assert_Shutdown (
             "Continuing execution after being aborted."));
      end if;

      Treatment := Test_Selective_Wait (Acceptor, Open_Accepts, Select_Mode);

      case Treatment is

      when Accept_Alternative_Selected =>

         --  Ready to rendezvous already

         Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;

      when Accept_Alternative_Completed =>

         --  Rendezvous is over

         null;

      when Accept_Alternative_Open =>

         --  Wait for caller.

         Acceptor.Open_Accepts := Open_Accepts;

         Acceptor.Accepting := Select_Wait;
         Acceptor.Suspended_Abortably := True;

         while Acceptor.Accepting /= Not_Accepting
         loop
            if Acceptor.Pending_Action then
               if Acceptor.Pending_Priority_Change then
                  Abortion.Change_Base_Priority (Acceptor);
               end if;

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

         Acceptor.Suspended_Abortably := False;

         if Acceptor.Pending_ATC_Level >= Acceptor.ATC_Nesting_Level and then
          not Open_Accepts (Acceptor.Chosen_Index).Null_Body then
            Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
         end if;

         --  Acceptor.Call should already be updated by the Caller if
         --  not aborted.

      when Else_Selected =>
         Acceptor.Accepting := Not_Accepting;

      when Terminate_Selected =>

         --  Terminate alternative is open

         Acceptor.Open_Accepts := Open_Accepts;

         Acceptor.Accepting := Select_Wait;

         --  We need to check if a signal is pending on an open interrupt
         --  entry. Otherwise this task would become passive (since terminate
         --  alternative is open) and, if none of the siblings are active
         --  any more, the task could not wake up any more, even though a
         --  signal might be pending on an open interrupt entry.

         Unlock (Acceptor.L);
         Utilities.Terminate_Alternative;

         --  Wait for normal entry call or termination

         --  consider letting Terminate_Alternative assume mutex L
         --  is already locked, and return with it locked, so
         --  this code could be simplified???

         --  No return here if Acceptor completes, otherwise
         --  Acceptor.Call should already be updated by the Caller

         Index := Acceptor.Chosen_Index;
         if not Open_Accepts (Acceptor.Chosen_Index).Null_Body then
            Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
         end if;
         Undefer_Abortion;
         return;

      when No_Alternative_Open =>

         --  Acceptor.Chosen_Index := No_Rendezvous; => Program_Error ???

         null;

      end case;

      --  Caller has been chosen

      --  Acceptor.Call should already be updated by the Caller

      --  Acceptor.Chosen_Index should either be updated by the Caller
      --  or by Test_Selective_Wait

      Index := Acceptor.Chosen_Index;
      Unlock (Acceptor.L);
      Undefer_Abortion;

      --  Start rendezvous

   end Selective_Wait;

   ----------------
   -- Task_Count --
   ----------------

   function Task_Count (E : Task_Entry_Index) return Natural is
      T            : constant Task_ID := Self;
      Return_Count : Natural;
      Error        : Boolean;

   begin
      Write_Lock (T.L, Error);
      Return_Count := Count_Waiting (T.Entry_Queues (E));
      Unlock (T.L);
      return Return_Count;
   end Task_Count;

   --------------
   -- Callable --
   --------------

   function Callable (T : Task_ID) return Boolean is
   begin
      return     T.Stage < Complete
        and then T.Pending_ATC_Level > ATC_Level_Base'First;
   end Callable;

end System.Tasking.Rendezvous;
