PR testsuite/79036 - gcc.dg/tree-ssa/builtin-sprintf.c fails starting with r244037

[official-gcc.git] / gcc / ada / s-tpobop.adb

------------------------------------------------------------------------------
--                                                                          --
--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
--                                                                          --
--               SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS                --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--         Copyright (C) 1998-2016, 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 3,  or (at your option) any later ver- --
-- sion.  GNAT 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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains all extended primitives related to Protected_Objects
--  with entries.

--  The handling of protected objects with no entries is done in
--  System.Tasking.Protected_Objects, the simple routines for protected
--  objects with entries in System.Tasking.Protected_Objects.Entries.

--  The split between Entries and Operations is needed to break circular
--  dependencies inside the run time.

--  This package contains all primitives related to Protected_Objects.
--  Note: the compiler generates direct calls to this interface, via Rtsfind.

with System.Task_Primitives.Operations;
with System.Tasking.Entry_Calls;
with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.Tasking.Utilities;
with System.Tasking.Debug;
with System.Parameters;
with System.Traces.Tasking;
with System.Restrictions;

with System.Tasking.Initialization;
pragma Elaborate_All (System.Tasking.Initialization);
--  Insures that tasking is initialized if any protected objects are created

package body System.Tasking.Protected_Objects.Operations is

   package STPO renames System.Task_Primitives.Operations;

   use Parameters;
   use Task_Primitives;
   use Ada.Exceptions;
   use Entries;

   use System.Restrictions;
   use System.Restrictions.Rident;
   use System.Traces;
   use System.Traces.Tasking;

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

   procedure Update_For_Queue_To_PO
     (Entry_Call : Entry_Call_Link;
      With_Abort : Boolean);
   pragma Inline (Update_For_Queue_To_PO);
   --  Update the state of an existing entry call to reflect the fact that it
   --  is being enqueued, based on whether the current queuing action is with
   --  or without abort. Call this only while holding the PO's lock. It returns
   --  with the PO's lock still held.

   procedure Requeue_Call
     (Self_Id    : Task_Id;
      Object     : Protection_Entries_Access;
      Entry_Call : Entry_Call_Link);
   --  Handle requeue of Entry_Call.
   --  In particular, queue the call if needed, or service it immediately
   --  if possible.

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

   --  Compiler interface only (do not call from within the RTS)

   --  This should have analogous effect to Cancel_Task_Entry_Call, setting
   --  the value of Block.Cancelled instead of returning the parameter value
   --  Cancelled.

   --  The effect should be idempotent, since the call may already have been
   --  dequeued.

   --  Source code:

   --      select r.e;
   --         ...A...
   --      then abort
   --         ...B...
   --      end select;

   --  Expanded code:

   --      declare
   --         X : protected_entry_index := 1;
   --         B80b : communication_block;
   --         communication_blockIP (B80b);

   --      begin
   --         begin
   --            A79b : label
   --            A79b : declare
   --               procedure _clean is
   --               begin
   --                  if enqueued (B80b) then
   --                     cancel_protected_entry_call (B80b);
   --                  end if;
   --                  return;
   --               end _clean;

   --            begin
   --               protected_entry_call (rTV!(r)._object'unchecked_access, X,
   --                 null_address, asynchronous_call, B80b, objectF => 0);
   --               if enqueued (B80b) then
   --                  ...B...
   --               end if;
   --            at end
   --               _clean;
   --            end A79b;

   --         exception
   --            when _abort_signal =>
   --               abort_undefer.all;
   --               null;
   --         end;

   --         if not cancelled (B80b) then
   --            x := ...A...
   --         end if;
   --      end;

   --  If the entry call completes after we get into the abortable part,
   --  Abort_Signal should be raised and ATC will take us to the at-end
   --  handler, which will call _clean.

   --  If the entry call returns with the call already completed, we can skip
   --  this, and use the "if enqueued()" to go past the at-end handler, but we
   --  will still call _clean.

   --  If the abortable part completes before the entry call is Done, it will
   --  call _clean.

   --  If the entry call or the abortable part raises an exception,
   --  we will still call _clean, but the value of Cancelled should not matter.

   --  Whoever calls _clean first gets to decide whether the call
   --  has been "cancelled".

   --  Enqueued should be true if there is any chance that the call is still on
   --  a queue. It seems to be safe to make it True if the call was Onqueue at
   --  some point before return from Protected_Entry_Call.

   --  Cancelled should be true iff the abortable part completed
   --  and succeeded in cancelling the entry call before it completed.

   --  ?????
   --  The need for Enqueued is less obvious. The "if enqueued ()" tests are
   --  not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
   --  must do the same test internally, with locking. The one that makes
   --  cancellation conditional may be a useful heuristic since at least 1/2
   --  the time the call should be off-queue by that point. The other one seems
   --  totally useless, since Protected_Entry_Call must do the same check and
   --  then possibly wait for the call to be abortable, internally.

   --  We can check Call.State here without locking the caller's mutex,
   --  since the call must be over after returning from Wait_For_Completion.
   --  No other task can access the call record at this point.

   procedure Cancel_Protected_Entry_Call
     (Block : in out Communication_Block) is
   begin
      Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
   end Cancel_Protected_Entry_Call;

   ---------------
   -- Cancelled --
   ---------------

   function Cancelled (Block : Communication_Block) return Boolean is
   begin
      return Block.Cancelled;
   end Cancelled;

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

   procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
   begin
      Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
   end Complete_Entry_Body;

   --------------
   -- Enqueued --
   --------------

   function Enqueued (Block : Communication_Block) return Boolean is
   begin
      return Block.Enqueued;
   end Enqueued;

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

   procedure Exceptional_Complete_Entry_Body
     (Object : Protection_Entries_Access;
      Ex     : Ada.Exceptions.Exception_Id)
   is
      procedure Transfer_Occurrence
        (Target : Ada.Exceptions.Exception_Occurrence_Access;
         Source : Ada.Exceptions.Exception_Occurrence);
      pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");

      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
      Self_Id    : Task_Id;

   begin
      pragma Debug
       (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));

      --  We must have abort deferred, since we are inside a protected
      --  operation.

      if Entry_Call /= null then

         --  The call was not requeued

         Entry_Call.Exception_To_Raise := Ex;

         if Ex /= Ada.Exceptions.Null_Id then

            --  An exception was raised and abort was deferred, so adjust
            --  before propagating, otherwise the task will stay with deferral
            --  enabled for its remaining life.

            Self_Id := STPO.Self;

            if not ZCX_By_Default then
               Initialization.Undefer_Abort_Nestable (Self_Id);
            end if;

            Transfer_Occurrence
              (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
               Self_Id.Common.Compiler_Data.Current_Excep);
         end if;

         --  Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
         --  PO_Service_Entries on return.

      end if;

      if Runtime_Traces then

         --  ??? Entry_Call can be null

         Send_Trace_Info (PO_Done, Entry_Call.Self);
      end if;
   end Exceptional_Complete_Entry_Body;

   --------------------
   -- PO_Do_Or_Queue --
   --------------------

   procedure PO_Do_Or_Queue
     (Self_ID    : Task_Id;
      Object     : Protection_Entries_Access;
      Entry_Call : Entry_Call_Link)
   is
      E             : constant Protected_Entry_Index :=
                        Protected_Entry_Index (Entry_Call.E);
      Index         : constant Protected_Entry_Index :=
                        Object.Find_Body_Index (Object.Compiler_Info, E);
      Barrier_Value : Boolean;
      Queue_Length  : Natural;
   begin
      --  When the Action procedure for an entry body returns, it is either
      --  completed (having called [Exceptional_]Complete_Entry_Body) or it
      --  is queued, having executed a requeue statement.

      Barrier_Value :=
        Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E);

      if Barrier_Value then

         --  Not abortable while service is in progress

         if Entry_Call.State = Now_Abortable then
            Entry_Call.State := Was_Abortable;
         end if;

         Object.Call_In_Progress := Entry_Call;

         pragma Debug
          (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
         Object.Entry_Bodies (Index).Action (
             Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);

         if Object.Call_In_Progress /= null then

            --  Body of current entry served call to completion

            Object.Call_In_Progress := null;

            if Single_Lock then
               STPO.Lock_RTS;
            end if;

            STPO.Write_Lock (Entry_Call.Self);
            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
            STPO.Unlock (Entry_Call.Self);

            if Single_Lock then
               STPO.Unlock_RTS;
            end if;

         else
            Requeue_Call (Self_ID, Object, Entry_Call);
         end if;

      elsif Entry_Call.Mode /= Conditional_Call
        or else not Entry_Call.With_Abort
      then
         if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
           or else Object.Entry_Queue_Maxes /= null
         then
            --  Need to check the queue length. Computing the length is an
            --  unusual case and is slow (need to walk the queue).

            Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E));

            if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
                 and then Queue_Length >=
                   Run_Time_Restrictions.Value (Max_Entry_Queue_Length))
              or else
                (Object.Entry_Queue_Maxes /= null
                  and then Object.Entry_Queue_Maxes (Index) /= 0
                  and then Queue_Length >= Object.Entry_Queue_Maxes (Index))
            then
               --  This violates the Max_Entry_Queue_Length restriction or the
               --  Max_Queue_Length bound, raise Program_Error.

               Entry_Call.Exception_To_Raise := Program_Error'Identity;

               if Single_Lock then
                  STPO.Lock_RTS;
               end if;

               STPO.Write_Lock (Entry_Call.Self);
               Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
               STPO.Unlock (Entry_Call.Self);

               if Single_Lock then
                  STPO.Unlock_RTS;
               end if;

               return;
            end if;
         end if;

         --  Do the work: queue the call

         Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
         Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);

         return;
      else
         --  Conditional_Call and With_Abort

         if Single_Lock then
            STPO.Lock_RTS;
         end if;

         STPO.Write_Lock (Entry_Call.Self);
         pragma Assert (Entry_Call.State /= Not_Yet_Abortable);
         Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
         STPO.Unlock (Entry_Call.Self);

         if Single_Lock then
            STPO.Unlock_RTS;
         end if;
      end if;

   exception
      when others =>
         Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
   end PO_Do_Or_Queue;

   ------------------------
   -- PO_Service_Entries --
   ------------------------

   procedure PO_Service_Entries
     (Self_ID       : Task_Id;
      Object        : Entries.Protection_Entries_Access;
      Unlock_Object : Boolean := True)
   is
      E          : Protected_Entry_Index;
      Caller     : Task_Id;
      Entry_Call : Entry_Call_Link;

   begin
      loop
         Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);

         exit when Entry_Call = null;

         E := Protected_Entry_Index (Entry_Call.E);

         --  Not abortable while service is in progress

         if Entry_Call.State = Now_Abortable then
            Entry_Call.State := Was_Abortable;
         end if;

         Object.Call_In_Progress := Entry_Call;

         begin
            if Runtime_Traces then
               Send_Trace_Info (PO_Run, Self_ID,
                                Entry_Call.Self, Entry_Index (E));
            end if;

            pragma Debug
              (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));

            Object.Entry_Bodies
              (Object.Find_Body_Index (Object.Compiler_Info, E)).Action
                (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);

         exception
            when others =>
               Queuing.Broadcast_Program_Error
                 (Self_ID, Object, Entry_Call);
         end;

         if Object.Call_In_Progress = null then
            Requeue_Call (Self_ID, Object, Entry_Call);
            exit when Entry_Call.State = Cancelled;

         else
            Object.Call_In_Progress := null;
            Caller := Entry_Call.Self;

            if Single_Lock then
               STPO.Lock_RTS;
            end if;

            STPO.Write_Lock (Caller);
            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
            STPO.Unlock (Caller);

            if Single_Lock then
               STPO.Unlock_RTS;
            end if;
         end if;
      end loop;

      if Unlock_Object then
         Unlock_Entries (Object);
      end if;
   end PO_Service_Entries;

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

   function Protected_Count
     (Object : Protection_Entries'Class;
      E      : Protected_Entry_Index) return Natural
   is
   begin
      return Queuing.Count_Waiting (Object.Entry_Queues (E));
   end Protected_Count;

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

   --  Compiler interface only (do not call from within the RTS)

   --  select r.e;
   --     ...A...
   --  else
   --     ...B...
   --  end select;

   --  declare
   --     X : protected_entry_index := 1;
   --     B85b : communication_block;
   --     communication_blockIP (B85b);

   --  begin
   --     protected_entry_call (rTV!(r)._object'unchecked_access, X,
   --       null_address, conditional_call, B85b, objectF => 0);

   --     if cancelled (B85b) then
   --        ...B...
   --     else
   --        ...A...
   --     end if;
   --  end;

   --  See also Cancel_Protected_Entry_Call for code expansion of asynchronous
   --  entry call.

   --  The initial part of this procedure does not need to lock the calling
   --  task's ATCB, up to the point where the call record first may be queued
   --  (PO_Do_Or_Queue), since before that no other task will have access to
   --  the record.

   --  If this is a call made inside of an abort deferred region, the call
   --  should be never abortable.

   --  If the call was not queued abortably, we need to wait until it is before
   --  proceeding with the abortable part.

   --  There are some heuristics here, just to save time for frequently
   --  occurring cases. For example, we check Initially_Abortable to try to
   --  avoid calling the procedure Wait_Until_Abortable, since the normal case
   --  for async. entry calls is to be queued abortably.

   --  Another heuristic uses the Block.Enqueued to try to avoid calling
   --  Cancel_Protected_Entry_Call if the call can be served immediately.

   procedure Protected_Entry_Call
     (Object              : Protection_Entries_Access;
      E                   : Protected_Entry_Index;
      Uninterpreted_Data  : System.Address;
      Mode                : Call_Modes;
      Block               : out Communication_Block)
   is
      Self_ID             : constant Task_Id := STPO.Self;
      Entry_Call          : Entry_Call_Link;
      Initially_Abortable : Boolean;
      Ceiling_Violation   : Boolean;

   begin
      pragma Debug
        (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));

      if Runtime_Traces then
         Send_Trace_Info (PO_Call, Entry_Index (E));
      end if;

      if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
         raise Storage_Error with "not enough ATC nesting levels";
      end if;

      --  If pragma Detect_Blocking is active then Program_Error must be
      --  raised if this potentially blocking operation is called from a
      --  protected action.

      if Detect_Blocking
        and then Self_ID.Common.Protected_Action_Nesting > 0
      then
         raise Program_Error with "potentially blocking operation";
      end if;

      --  Self_ID.Deferral_Level should be 0, except when called from Finalize,
      --  where abort is already deferred.

      Initialization.Defer_Abort_Nestable (Self_ID);
      Lock_Entries_With_Status (Object, Ceiling_Violation);

      if Ceiling_Violation then

         --  Failed ceiling check

         Initialization.Undefer_Abort_Nestable (Self_ID);
         raise Program_Error;
      end if;

      Block.Self := Self_ID;
      Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
      pragma Debug
        (Debug.Trace (Self_ID, "PEC: entered ATC level: " &
         ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
      Entry_Call :=
         Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
      Entry_Call.Next := null;
      Entry_Call.Mode := Mode;
      Entry_Call.Cancellation_Attempted := False;

      Entry_Call.State :=
        (if Self_ID.Deferral_Level > 1
         then Never_Abortable else Now_Abortable);

      Entry_Call.E := Entry_Index (E);
      Entry_Call.Prio := STPO.Get_Priority (Self_ID);
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
      Entry_Call.Called_PO := To_Address (Object);
      Entry_Call.Called_Task := null;
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
      Entry_Call.With_Abort := True;

      PO_Do_Or_Queue (Self_ID, Object, Entry_Call);
      Initially_Abortable := Entry_Call.State = Now_Abortable;
      PO_Service_Entries (Self_ID, Object);

      --  Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
      --  for completed or cancelled calls.  (This is a heuristic, only.)

      if Entry_Call.State >= Done then

         --  Once State >= Done it will not change any more

         if Single_Lock then
            STPO.Lock_RTS;
         end if;

         STPO.Write_Lock (Self_ID);
         Utilities.Exit_One_ATC_Level (Self_ID);
         STPO.Unlock (Self_ID);

         if Single_Lock then
            STPO.Unlock_RTS;
         end if;

         Block.Enqueued := False;
         Block.Cancelled := Entry_Call.State = Cancelled;
         Initialization.Undefer_Abort_Nestable (Self_ID);
         Entry_Calls.Check_Exception (Self_ID, Entry_Call);
         return;

      else
         --  In this case we cannot conclude anything, since State can change
         --  concurrently.

         null;
      end if;

      --  Now for the general case

      if Mode = Asynchronous_Call then

         --  Try to avoid an expensive call

         if not Initially_Abortable then
            if Single_Lock then
               STPO.Lock_RTS;
               Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
               STPO.Unlock_RTS;
            else
               Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
            end if;
         end if;

      else
         case Mode is
            when Simple_Call | Conditional_Call =>
               if Single_Lock then
                  STPO.Lock_RTS;
                  Entry_Calls.Wait_For_Completion (Entry_Call);
                  STPO.Unlock_RTS;

               else
                  STPO.Write_Lock (Self_ID);
                  Entry_Calls.Wait_For_Completion (Entry_Call);
                  STPO.Unlock (Self_ID);
               end if;

               Block.Cancelled := Entry_Call.State = Cancelled;

            when Asynchronous_Call | Timed_Call =>
               pragma Assert (False);
               null;
         end case;
      end if;

      Initialization.Undefer_Abort_Nestable (Self_ID);
      Entry_Calls.Check_Exception (Self_ID, Entry_Call);
   end Protected_Entry_Call;

   ------------------
   -- Requeue_Call --
   ------------------

   procedure Requeue_Call
     (Self_Id    : Task_Id;
      Object     : Protection_Entries_Access;
      Entry_Call : Entry_Call_Link)
   is
      New_Object        : Protection_Entries_Access;
      Ceiling_Violation : Boolean;
      Result            : Boolean;
      E                 : Protected_Entry_Index;

   begin
      New_Object := To_Protection (Entry_Call.Called_PO);

      if New_Object = null then

         --  Call is to be requeued to a task entry

         if Single_Lock then
            STPO.Lock_RTS;
         end if;

         Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);

         if not Result then
            Queuing.Broadcast_Program_Error
              (Self_Id, Object, Entry_Call, RTS_Locked => True);
         end if;

         if Single_Lock then
            STPO.Unlock_RTS;
         end if;

      else
         --  Call should be requeued to a PO

         if Object /= New_Object then

            --  Requeue is to different PO

            Lock_Entries_With_Status (New_Object, Ceiling_Violation);

            if Ceiling_Violation then
               Object.Call_In_Progress := null;
               Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);

            else
               PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
               PO_Service_Entries (Self_Id, New_Object);
            end if;

         else
            --  Requeue is to same protected object

            --  ??? Try to compensate apparent failure of the scheduler on some
            --  OS (e.g VxWorks) to give higher priority tasks a chance to run
            --  (see CXD6002).

            STPO.Yield (Do_Yield => False);

            if Entry_Call.With_Abort
              and then Entry_Call.Cancellation_Attempted
            then
               --  If this is a requeue with abort and someone tried to cancel
               --  this call, cancel it at this point.

               Entry_Call.State := Cancelled;
               return;
            end if;

            if not Entry_Call.With_Abort
              or else Entry_Call.Mode /= Conditional_Call
            then
               E := Protected_Entry_Index (Entry_Call.E);

               if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
                    and then
                  Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
                    Queuing.Count_Waiting (Object.Entry_Queues (E))
               then
                  --  This violates the Max_Entry_Queue_Length restriction,
                  --  raise Program_Error.

                  Entry_Call.Exception_To_Raise := Program_Error'Identity;

                  if Single_Lock then
                     STPO.Lock_RTS;
                  end if;

                  STPO.Write_Lock (Entry_Call.Self);
                  Initialization.Wakeup_Entry_Caller
                    (Self_Id, Entry_Call, Done);
                  STPO.Unlock (Entry_Call.Self);

                  if Single_Lock then
                     STPO.Unlock_RTS;
                  end if;

               else
                  Queuing.Enqueue
                    (New_Object.Entry_Queues (E), Entry_Call);
                  Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
               end if;

            else
               PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);
            end if;
         end if;
      end if;
   end Requeue_Call;

   ----------------------------
   -- Protected_Entry_Caller --
   ----------------------------

   function Protected_Entry_Caller
     (Object : Protection_Entries'Class) return Task_Id is
   begin
      return Object.Call_In_Progress.Self;
   end Protected_Entry_Caller;

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

   --  Compiler interface only (do not call from within the RTS)

   --  entry e when b is
   --  begin
   --     b := false;
   --     ...A...
   --     requeue e2;
   --  end e;

   --  procedure rPT__E10b (O : address; P : address; E :
   --    protected_entry_index) is
   --     type rTVP is access rTV;
   --     freeze rTVP []
   --     _object : rTVP := rTVP!(O);
   --  begin
   --     declare
   --        rR : protection renames _object._object;
   --        vP : integer renames _object.v;
   --        bP : boolean renames _object.b;
   --     begin
   --        b := false;
   --        ...A...
   --        requeue_protected_entry (rR'unchecked_access, rR'
   --          unchecked_access, 2, false, objectF => 0, new_objectF =>
   --          0);
   --        return;
   --     end;
   --     complete_entry_body (_object._object'unchecked_access, objectF =>
   --       0);
   --     return;
   --  exception
   --     when others =>
   --        abort_undefer.all;
   --        exceptional_complete_entry_body (_object._object'
   --          unchecked_access, current_exception, objectF => 0);
   --        return;
   --  end rPT__E10b;

   procedure Requeue_Protected_Entry
     (Object     : Protection_Entries_Access;
      New_Object : Protection_Entries_Access;
      E          : Protected_Entry_Index;
      With_Abort : Boolean)
   is
      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;

   begin
      pragma Debug
        (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
      pragma Assert (STPO.Self.Deferral_Level > 0);

      Entry_Call.E := Entry_Index (E);
      Entry_Call.Called_PO := To_Address (New_Object);
      Entry_Call.Called_Task := null;
      Entry_Call.With_Abort := With_Abort;
      Object.Call_In_Progress := null;
   end Requeue_Protected_Entry;

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

   --  Compiler interface only (do not call from within the RTS)

   --    accept e1 do
   --      ...A...
   --      requeue r.e2;
   --    end e1;

   --    A79b : address;
   --    L78b : label

   --    begin
   --       accept_call (1, A79b);
   --       ...A...
   --       requeue_task_to_protected_entry (rTV!(r)._object'
   --         unchecked_access, 2, false, new_objectF => 0);
   --       goto L78b;
   --       <<L78b>>
   --       complete_rendezvous;

   --    exception
   --       when all others =>
   --          exceptional_complete_rendezvous (get_gnat_exception);
   --    end;

   procedure Requeue_Task_To_Protected_Entry
     (New_Object : Protection_Entries_Access;
      E          : Protected_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);

      --  We do not need to lock Self_ID here since the call is not abortable
      --  at this point, and therefore, the caller cannot cancel the call.

      Entry_Call.Needs_Requeue := True;
      Entry_Call.With_Abort := With_Abort;
      Entry_Call.Called_PO := To_Address (New_Object);
      Entry_Call.Called_Task := null;
      Entry_Call.E := Entry_Index (E);
      Initialization.Undefer_Abort (Self_ID);
   end Requeue_Task_To_Protected_Entry;

   ---------------------
   -- Service_Entries --
   ---------------------

   procedure Service_Entries (Object : Protection_Entries_Access) is
      Self_ID : constant Task_Id := STPO.Self;
   begin
      PO_Service_Entries (Self_ID, Object);
   end Service_Entries;

   --------------------------------
   -- Timed_Protected_Entry_Call --
   --------------------------------

   --  Compiler interface only (do not call from within the RTS)

   procedure Timed_Protected_Entry_Call
     (Object                : Protection_Entries_Access;
      E                     : Protected_Entry_Index;
      Uninterpreted_Data    : System.Address;
      Timeout               : Duration;
      Mode                  : Delay_Modes;
      Entry_Call_Successful : out Boolean)
   is
      Self_Id           : constant Task_Id  := STPO.Self;
      Entry_Call        : Entry_Call_Link;
      Ceiling_Violation : Boolean;

      Yielded : Boolean;
      pragma Unreferenced (Yielded);

   begin
      if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
         raise Storage_Error with "not enough ATC nesting levels";
      end if;

      --  If pragma Detect_Blocking is active then Program_Error must be
      --  raised if this potentially blocking operation is called from a
      --  protected action.

      if Detect_Blocking
        and then Self_Id.Common.Protected_Action_Nesting > 0
      then
         raise Program_Error with "potentially blocking operation";
      end if;

      if Runtime_Traces then
         Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
      end if;

      Initialization.Defer_Abort_Nestable (Self_Id);
      Lock_Entries_With_Status (Object, Ceiling_Violation);

      if Ceiling_Violation then
         Initialization.Undefer_Abort (Self_Id);
         raise Program_Error;
      end if;

      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
      pragma Debug
        (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
      Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
      Entry_Call.Next := null;
      Entry_Call.Mode := Timed_Call;
      Entry_Call.Cancellation_Attempted := False;

      Entry_Call.State :=
        (if Self_Id.Deferral_Level > 1
         then Never_Abortable
         else Now_Abortable);

      Entry_Call.E := Entry_Index (E);
      Entry_Call.Prio := STPO.Get_Priority (Self_Id);
      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
      Entry_Call.Called_PO := To_Address (Object);
      Entry_Call.Called_Task := null;
      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
      Entry_Call.With_Abort := True;

      PO_Do_Or_Queue (Self_Id, Object, Entry_Call);
      PO_Service_Entries (Self_Id, Object);

      if Single_Lock then
         STPO.Lock_RTS;
      else
         STPO.Write_Lock (Self_Id);
      end if;

      --  Try to avoid waiting for completed or cancelled calls

      if Entry_Call.State >= Done then
         Utilities.Exit_One_ATC_Level (Self_Id);

         if Single_Lock then
            STPO.Unlock_RTS;
         else
            STPO.Unlock (Self_Id);
         end if;

         Entry_Call_Successful := Entry_Call.State = Done;
         Initialization.Undefer_Abort_Nestable (Self_Id);
         Entry_Calls.Check_Exception (Self_Id, Entry_Call);
         return;
      end if;

      Entry_Calls.Wait_For_Completion_With_Timeout
        (Entry_Call, Timeout, Mode, Yielded);

      if Single_Lock then
         STPO.Unlock_RTS;
      else
         STPO.Unlock (Self_Id);
      end if;

      --  ??? Do we need to yield in case Yielded is False

      Initialization.Undefer_Abort_Nestable (Self_Id);
      Entry_Call_Successful := Entry_Call.State = Done;
      Entry_Calls.Check_Exception (Self_Id, Entry_Call);
   end Timed_Protected_Entry_Call;

   ----------------------------
   -- Update_For_Queue_To_PO --
   ----------------------------

   --  Update the state of an existing entry call, based on
   --  whether the current queuing action is with or without abort.
   --  Call this only while holding the server's lock.
   --  It returns with the server's lock released.

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

   procedure Update_For_Queue_To_PO
     (Entry_Call : Entry_Call_Link;
      With_Abort : Boolean)
   is
      Old : constant Entry_Call_State := Entry_Call.State;

   begin
      pragma Assert (Old < Done);

      Entry_Call.State := New_State (With_Abort, Entry_Call.State);

      if Entry_Call.Mode = Asynchronous_Call then
         if Old < Was_Abortable and then
           Entry_Call.State = Now_Abortable
         then
            if Single_Lock then
               STPO.Lock_RTS;
            end if;

            STPO.Write_Lock (Entry_Call.Self);

            if Entry_Call.Self.Common.State = Async_Select_Sleep then
               STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
            end if;

            STPO.Unlock (Entry_Call.Self);

            if Single_Lock then
               STPO.Unlock_RTS;
            end if;

         end if;

      elsif Entry_Call.Mode = Conditional_Call then
         pragma Assert (Entry_Call.State < Was_Abortable);
         null;
      end if;
   end Update_For_Queue_To_PO;

end System.Tasking.Protected_Objects.Operations;