gcc/ada/s-taenca.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --             S Y S T E M . T A S K I N G . E N T R Y _ C A L L S          --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                                                                          --
  10 --         Copyright (C) 1992-2001, Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with System.Task_Primitives.Operations;
  36 --  used for STPO.Write_Lock
  37 --           Unlock
  38 --           STPO.Get_Priority
  39 --           Sleep
  40 --           Timed_Sleep
  41
  42 with System.Tasking.Initialization;
  43 --  used for Change_Base_Priority
  44 --           Poll_Base_Priority_Change_At_Entry_Call
  45 --           Dynamic_Priority_Support
  46 --           Defer_Abort/Undefer_Abort
  47
  48 with System.Tasking.Protected_Objects.Entries;
  49 --  used for To_Protection
  50
  51 with System.Tasking.Protected_Objects.Operations;
  52 --  used for PO_Service_Entries
  53
  54 with System.Tasking.Queuing;
  55 --  used for Requeue_Call_With_New_Prio
  56 --           Onqueue
  57 --           Dequeue_Call
  58
  59 with System.Tasking.Utilities;
  60 --  used for Exit_One_ATC_Level
  61
  62 with System.Parameters;
  63 --  used for Single_Lock
  64 --           Runtime_Traces
  65
  66 with System.Traces;
  67 --  used for Send_Trace_Info
  68
  69 package body System.Tasking.Entry_Calls is
  70
  71    package STPO renames System.Task_Primitives.Operations;
  72
  73    use Parameters;
  74    use Task_Primitives;
  75    use Protected_Objects.Entries;
  76    use Protected_Objects.Operations;
  77    use System.Traces;
  78
  79    --  DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
  80    --  internally. Those operations will raise Program_Error, which
  81    --  we are not prepared to handle inside the RTS. Instead, use
  82    --  System.Task_Primitives lock operations directly on Protection.L.
  83
  84    -----------------------
  85    -- Local Subprograms --
  86    -----------------------
  87
  88    procedure Lock_Server (Entry_Call : Entry_Call_Link);
  89    --  This locks the server targeted by Entry_Call.
  90    --
  91    --  This may be a task or a protected object,
  92    --  depending on the target of the original call or any subsequent
  93    --  requeues.
  94    --
  95    --  This routine is needed because the field specifying the server
  96    --  for this call must be protected by the server's mutex. If it were
  97    --  protected by the caller's mutex, accessing the server's queues would
  98    --  require locking the caller to get the server, locking the server,
  99    --  and then accessing the queues. This involves holding two ATCB
 100    --  locks at once, something which we can guarantee that it will always
 101    --  be done in the same order, or locking a protected object while we
 102    --  hold an ATCB lock, something which is not permitted. Since
 103    --  the server cannot be obtained reliably, it must be obtained unreliably
 104    --  and then checked again once it has been locked.
 105    --
 106    --  If Single_Lock and server is a PO, release RTS_Lock.
 107
 108    procedure Unlock_Server (Entry_Call : Entry_Call_Link);
 109    --  STPO.Unlock the server targeted by Entry_Call. The server must
 110    --  be locked before calling this.
 111    --
 112    --  If Single_Lock and server is a PO, take RTS_Lock on exit.
 113
 114    procedure Unlock_And_Update_Server
 115      (Self_ID    : Task_ID;
 116       Entry_Call : Entry_Call_Link);
 117    --  Similar to Unlock_Server, but services entry calls if the
 118    --  server is a protected object.
 119    --
 120    --  If Single_Lock and server is a PO, take RTS_Lock on exit.
 121
 122    procedure Check_Pending_Actions_For_Entry_Call
 123      (Self_ID    : Task_ID;
 124       Entry_Call : Entry_Call_Link);
 125    --  This procedure performs priority change of a queued call and
 126    --  dequeuing of an entry call when the call is cancelled.
 127    --  If the call is dequeued the state should be set to Cancelled.
 128
 129    procedure Poll_Base_Priority_Change_At_Entry_Call
 130      (Self_ID    : Task_ID;
 131       Entry_Call : Entry_Call_Link);
 132    pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
 133    --  Has to be called with the Self_ID's ATCB write-locked.
 134    --  May temporariliy release the lock.
 135
 136    ---------------------
 137    -- Check_Exception --
 138    ---------------------
 139
 140    --  Raise any pending exception from the Entry_Call.
 141
 142    --  This should be called at the end of every compiler interface
 143    --  procedure that implements an entry call.
 144
 145    --  In principle, the caller should not be abort-deferred (unless
 146    --  the application program violates the Ada language rules by doing
 147    --  entry calls from within protected operations -- an erroneous practice
 148    --  apparently followed with success by some adventurous GNAT users).
 149    --  Absolutely, the caller should not be holding any locks, or there
 150    --  will be deadlock.
 151
 152    procedure Check_Exception
 153      (Self_ID    : Task_ID;
 154       Entry_Call : Entry_Call_Link)
 155    is
 156       pragma Warnings (Off, Self_ID);
 157
 158       use type Ada.Exceptions.Exception_Id;
 159
 160       procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
 161       pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
 162
 163       E : constant Ada.Exceptions.Exception_Id :=
 164             Entry_Call.Exception_To_Raise;
 165    begin
 166       --  pragma Assert (Self_ID.Deferral_Level = 0);
 167       --  The above may be useful for debugging, but the Florist packages
 168       --  contain critical sections that defer abort and then do entry calls,
 169       --  which causes the above Assert to trip.
 170
 171       if E /= Ada.Exceptions.Null_Id then
 172          Internal_Raise (E);
 173       end if;
 174    end Check_Exception;
 175
 176    -----------------------------------------
 177    -- Check_Pending_Actions_For_Entry_Call --
 178    -----------------------------------------
 179
 180    --  Call only with abort deferred and holding lock of Self_ID. This
 181    --  is a bit of common code for all entry calls. The effect is to do
 182    --  any deferred base priority change operation, in case some other
 183    --  task called STPO.Set_Priority while the current task had abort deferred,
 184    --  and to dequeue the call if the call has been aborted.
 185
 186    procedure Check_Pending_Actions_For_Entry_Call
 187      (Self_ID    : Task_ID;
 188       Entry_Call : Entry_Call_Link) is
 189    begin
 190       pragma Assert (Self_ID = Entry_Call.Self);
 191
 192       Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call);
 193
 194       if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 195         and then Entry_Call.State = Now_Abortable
 196       then
 197          STPO.Unlock (Self_ID);
 198          Lock_Server (Entry_Call);
 199
 200          if Queuing.Onqueue (Entry_Call)
 201            and then Entry_Call.State = Now_Abortable
 202          then
 203             Queuing.Dequeue_Call (Entry_Call);
 204
 205             if Entry_Call.Cancellation_Attempted then
 206                Entry_Call.State := Cancelled;
 207             else
 208                Entry_Call.State := Done;
 209             end if;
 210
 211             Unlock_And_Update_Server (Self_ID, Entry_Call);
 212
 213          else
 214             Unlock_Server (Entry_Call);
 215          end if;
 216
 217          STPO.Write_Lock (Self_ID);
 218       end if;
 219    end Check_Pending_Actions_For_Entry_Call;
 220
 221    -----------------
 222    -- Lock_Server --
 223    -----------------
 224
 225    --  This should only be called by the Entry_Call.Self.
 226    --  It should be holding no other ATCB locks at the time.
 227
 228    procedure Lock_Server (Entry_Call : Entry_Call_Link) is
 229       Test_Task         : Task_ID;
 230       Test_PO           : Protection_Entries_Access;
 231       Ceiling_Violation : Boolean;
 232       Failures          : Integer := 0;
 233
 234    begin
 235       Test_Task := Entry_Call.Called_Task;
 236
 237       loop
 238          if Test_Task = null then
 239
 240             --  Entry_Call was queued on a protected object,
 241             --  or in transition, when we last fetched Test_Task.
 242
 243             Test_PO := To_Protection (Entry_Call.Called_PO);
 244
 245             if Test_PO = null then
 246
 247                --  We had very bad luck, interleaving with TWO different
 248                --  requeue operations. Go around the loop and try again.
 249
 250                if Single_Lock then
 251                   STPO.Unlock_RTS;
 252                   STPO.Yield;
 253                   STPO.Lock_RTS;
 254                else
 255                   STPO.Yield;
 256                end if;
 257
 258             else
 259                if Single_Lock then
 260                   STPO.Unlock_RTS;
 261                end if;
 262
 263                Lock_Entries (Test_PO, Ceiling_Violation);
 264
 265                --  ????
 266                --  The following code allows Lock_Server to be called
 267                --  when cancelling a call, to allow for the possibility
 268                --  that the priority of the caller has been raised
 269                --  beyond that of the protected entry call by
 270                --  Ada.Dynamic_Priorities.Set_Priority.
 271
 272                --  If the current task has a higher priority than the ceiling
 273                --  of the protected object, temporarily lower it. It will
 274                --  be reset in Unlock.
 275
 276                if Ceiling_Violation then
 277                   declare
 278                      Current_Task      : Task_ID := STPO.Self;
 279                      Old_Base_Priority : System.Any_Priority;
 280
 281                   begin
 282                      if Single_Lock then
 283                         STPO.Lock_RTS;
 284                      end if;
 285
 286                      STPO.Write_Lock (Current_Task);
 287                      Old_Base_Priority := Current_Task.Common.Base_Priority;
 288                      Current_Task.New_Base_Priority := Test_PO.Ceiling;
 289                      System.Tasking.Initialization.Change_Base_Priority
 290                        (Current_Task);
 291                      STPO.Unlock (Current_Task);
 292
 293                      if Single_Lock then
 294                         STPO.Unlock_RTS;
 295                      end if;
 296
 297                      --  Following lock should not fail
 298
 299                      Lock_Entries (Test_PO);
 300
 301                      Test_PO.Old_Base_Priority := Old_Base_Priority;
 302                      Test_PO.Pending_Action := True;
 303                   end;
 304                end if;
 305
 306                exit when To_Address (Test_PO) = Entry_Call.Called_PO;
 307                Unlock_Entries (Test_PO);
 308
 309                if Single_Lock then
 310                   STPO.Lock_RTS;
 311                end if;
 312             end if;
 313
 314          else
 315             STPO.Write_Lock (Test_Task);
 316             exit when Test_Task = Entry_Call.Called_Task;
 317             STPO.Unlock (Test_Task);
 318          end if;
 319
 320          Test_Task := Entry_Call.Called_Task;
 321          Failures := Failures + 1;
 322          pragma Assert (Failures <= 5);
 323       end loop;
 324    end Lock_Server;
 325
 326    ---------------------------------------------
 327    -- Poll_Base_Priority_Change_At_Entry_Call --
 328    ---------------------------------------------
 329
 330    --  A specialized version of Poll_Base_Priority_Change,
 331    --  that does the optional entry queue reordering.
 332
 333    procedure Poll_Base_Priority_Change_At_Entry_Call
 334      (Self_ID    : Task_ID;
 335       Entry_Call : Entry_Call_Link) is
 336    begin
 337       if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
 338          --  Check for ceiling violations ???
 339
 340          Self_ID.Pending_Priority_Change := False;
 341
 342          if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then
 343             if Single_Lock then
 344                STPO.Unlock_RTS;
 345                STPO.Yield;
 346                STPO.Lock_RTS;
 347             else
 348                STPO.Unlock (Self_ID);
 349                STPO.Yield;
 350                STPO.Write_Lock (Self_ID);
 351             end if;
 352
 353          else
 354             if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then
 355                --  Raising priority
 356
 357                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 358                STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 359
 360             else
 361                --  Lowering priority
 362
 363                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 364                STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 365
 366                if Single_Lock then
 367                   STPO.Unlock_RTS;
 368                   STPO.Yield;
 369                   STPO.Lock_RTS;
 370                else
 371                   STPO.Unlock (Self_ID);
 372                   STPO.Yield;
 373                   STPO.Write_Lock (Self_ID);
 374                end if;
 375             end if;
 376          end if;
 377
 378          --  Requeue the entry call at the new priority.
 379          --  We need to requeue even if the new priority is the same than
 380          --  the previous (see ACVC cxd4006).
 381
 382          STPO.Unlock (Self_ID);
 383          Lock_Server (Entry_Call);
 384          Queuing.Requeue_Call_With_New_Prio
 385            (Entry_Call, STPO.Get_Priority (Self_ID));
 386          Unlock_And_Update_Server (Self_ID, Entry_Call);
 387          STPO.Write_Lock (Self_ID);
 388       end if;
 389    end Poll_Base_Priority_Change_At_Entry_Call;
 390
 391    --------------------
 392    -- Reset_Priority --
 393    --------------------
 394
 395    procedure Reset_Priority
 396      (Acceptor               : Task_ID;
 397       Acceptor_Prev_Priority : Rendezvous_Priority) is
 398    begin
 399       pragma Assert (Acceptor = STPO.Self);
 400
 401       --  Since we limit this kind of "active" priority change to be done
 402       --  by the task for itself, we don't need to lock Acceptor.
 403
 404       if Acceptor_Prev_Priority /= Priority_Not_Boosted then
 405          STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority,
 406            Loss_Of_Inheritance => True);
 407       end if;
 408    end Reset_Priority;
 409
 410    ------------------------------
 411    -- Try_To_Cancel_Entry_Call --
 412    ------------------------------
 413
 414    procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is
 415       Entry_Call : Entry_Call_Link;
 416       Self_ID    : constant Task_ID := STPO.Self;
 417
 418       use type Ada.Exceptions.Exception_Id;
 419
 420    begin
 421       Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
 422
 423       --  Experimentation has shown that abort is sometimes (but not
 424       --  always) already deferred when Cancel_xxx_Entry_Call is called.
 425       --  That may indicate an error. Find out what is going on. ???
 426
 427       pragma Assert (Entry_Call.Mode = Asynchronous_Call);
 428       Initialization.Defer_Abort_Nestable (Self_ID);
 429
 430       if Single_Lock then
 431          STPO.Lock_RTS;
 432       end if;
 433
 434       STPO.Write_Lock (Self_ID);
 435       Entry_Call.Cancellation_Attempted := True;
 436
 437       if Self_ID.Pending_ATC_Level >= Entry_Call.Level then
 438          Self_ID.Pending_ATC_Level := Entry_Call.Level - 1;
 439       end if;
 440
 441       Entry_Calls.Wait_For_Completion (Entry_Call);
 442       STPO.Unlock (Self_ID);
 443
 444       if Single_Lock then
 445          STPO.Unlock_RTS;
 446       end if;
 447
 448       Succeeded := Entry_Call.State = Cancelled;
 449
 450       if Succeeded then
 451          Initialization.Undefer_Abort_Nestable (Self_ID);
 452       else
 453          --  ???
 454
 455          Initialization.Undefer_Abort_Nestable (Self_ID);
 456
 457          --  Ideally, abort should no longer be deferred at this
 458          --  point, so we should be able to call Check_Exception.
 459          --  The loop below should be considered temporary,
 460          --  to work around the possiblility that abort may be deferred
 461          --  more than one level deep.
 462
 463          if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
 464             while Self_ID.Deferral_Level > 0 loop
 465                System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID);
 466             end loop;
 467
 468             Entry_Calls.Check_Exception (Self_ID, Entry_Call);
 469          end if;
 470       end if;
 471    end Try_To_Cancel_Entry_Call;
 472
 473    ------------------------------
 474    -- Unlock_And_Update_Server --
 475    ------------------------------
 476
 477    procedure Unlock_And_Update_Server
 478      (Self_ID    : Task_ID;
 479       Entry_Call : Entry_Call_Link)
 480    is
 481       Called_PO : Protection_Entries_Access;
 482       Caller    : Task_ID;
 483
 484    begin
 485       if Entry_Call.Called_Task /= null then
 486          STPO.Unlock (Entry_Call.Called_Task);
 487       else
 488          Called_PO := To_Protection (Entry_Call.Called_PO);
 489          PO_Service_Entries (Self_ID, Called_PO);
 490
 491          if Called_PO.Pending_Action then
 492             Called_PO.Pending_Action := False;
 493             Caller := STPO.Self;
 494
 495             if Single_Lock then
 496                STPO.Lock_RTS;
 497             end if;
 498
 499             STPO.Write_Lock (Caller);
 500             Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
 501             Initialization.Change_Base_Priority (Caller);
 502             STPO.Unlock (Caller);
 503
 504             if Single_Lock then
 505                STPO.Unlock_RTS;
 506             end if;
 507          end if;
 508
 509          Unlock_Entries (Called_PO);
 510
 511          if Single_Lock then
 512             STPO.Lock_RTS;
 513          end if;
 514       end if;
 515    end Unlock_And_Update_Server;
 516
 517    -------------------
 518    -- Unlock_Server --
 519    -------------------
 520
 521    procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
 522       Caller    : Task_ID;
 523       Called_PO : Protection_Entries_Access;
 524
 525    begin
 526       if Entry_Call.Called_Task /= null then
 527          STPO.Unlock (Entry_Call.Called_Task);
 528       else
 529          Called_PO := To_Protection (Entry_Call.Called_PO);
 530
 531          if Called_PO.Pending_Action then
 532             Called_PO.Pending_Action := False;
 533             Caller := STPO.Self;
 534
 535             if Single_Lock then
 536                STPO.Lock_RTS;
 537             end if;
 538
 539             STPO.Write_Lock (Caller);
 540             Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
 541             Initialization.Change_Base_Priority (Caller);
 542             STPO.Unlock (Caller);
 543
 544             if Single_Lock then
 545                STPO.Unlock_RTS;
 546             end if;
 547          end if;
 548
 549          Unlock_Entries (Called_PO);
 550
 551          if Single_Lock then
 552             STPO.Lock_RTS;
 553          end if;
 554       end if;
 555    end Unlock_Server;
 556
 557    -------------------------
 558    -- Wait_For_Completion --
 559    -------------------------
 560
 561    procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
 562       Self_Id : constant Task_ID := Entry_Call.Self;
 563    begin
 564       --  If this is a conditional call, it should be cancelled when it
 565       --  becomes abortable. This is checked in the loop below.
 566
 567       if Parameters.Runtime_Traces then
 568          Send_Trace_Info (W_Completion);
 569       end if;
 570
 571       Self_Id.Common.State := Entry_Caller_Sleep;
 572
 573       loop
 574          Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
 575          exit when Entry_Call.State >= Done;
 576          STPO.Sleep (Self_Id, Entry_Caller_Sleep);
 577       end loop;
 578
 579       Self_Id.Common.State := Runnable;
 580       Utilities.Exit_One_ATC_Level (Self_Id);
 581
 582       if Parameters.Runtime_Traces then
 583          Send_Trace_Info (M_Call_Complete);
 584       end if;
 585    end Wait_For_Completion;
 586
 587    --------------------------------------
 588    -- Wait_For_Completion_With_Timeout --
 589    --------------------------------------
 590
 591    procedure Wait_For_Completion_With_Timeout
 592      (Entry_Call  : Entry_Call_Link;
 593       Wakeup_Time : Duration;
 594       Mode        : Delay_Modes;
 595       Yielded     : out Boolean)
 596    is
 597       Self_Id  : constant Task_ID := Entry_Call.Self;
 598       Timedout : Boolean := False;
 599
 600       use type Ada.Exceptions.Exception_Id;
 601
 602    begin
 603       --  This procedure waits for the entry call to be served, with a timeout.
 604       --  It tries to cancel the call if the timeout expires before the call is
 605       --  served.
 606
 607       --  If we wake up from the timed sleep operation here, it may be for
 608       --  several possible reasons:
 609
 610       --  1) The entry call is done being served.
 611       --  2) There is an abort or priority change to be served.
 612       --  3) The timeout has expired (Timedout = True)
 613       --  4) There has been a spurious wakeup.
 614
 615       --  Once the timeout has expired we may need to continue to wait if the
 616       --  call is already being serviced. In that case, we want to go back to
 617       --  sleep, but without any timeout. The variable Timedout is used to
 618       --  control this. If the Timedout flag is set, we do not need to
 619       --  STPO.Sleep with a timeout. We just sleep until we get a wakeup for
 620       --  some status change.
 621
 622       --  The original call may have become abortable after waking up. We want
 623       --  to check Check_Pending_Actions_For_Entry_Call again in any case.
 624
 625       pragma Assert (Entry_Call.Mode = Timed_Call);
 626
 627       Yielded := False;
 628       Self_Id.Common.State := Entry_Caller_Sleep;
 629
 630       --  Looping is necessary in case the task wakes up early from the
 631       --  timed sleep, due to a "spurious wakeup". Spurious wakeups are
 632       --  a weakness of POSIX condition variables. A thread waiting for
 633       --  a condition variable is allowed to wake up at any time, not just
 634       --  when the condition is signaled. See the same loop in the
 635       --  ordinary Wait_For_Completion, above.
 636
 637       if Parameters.Runtime_Traces then
 638          Send_Trace_Info (WT_Completion, Wakeup_Time);
 639       end if;
 640
 641       loop
 642          Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
 643          exit when Entry_Call.State >= Done;
 644
 645          STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode,
 646            Entry_Caller_Sleep, Timedout, Yielded);
 647
 648          if Timedout then
 649             if Parameters.Runtime_Traces then
 650                Send_Trace_Info (E_Timeout);
 651             end if;
 652
 653             --  Try to cancel the call (see Try_To_Cancel_Entry_Call for
 654             --  corresponding code in the ATC case).
 655
 656             Entry_Call.Cancellation_Attempted := True;
 657
 658             if Self_Id.Pending_ATC_Level >= Entry_Call.Level then
 659                Self_Id.Pending_ATC_Level := Entry_Call.Level - 1;
 660             end if;
 661
 662             --  The following loop is the same as the loop and exit code
 663             --  from the ordinary Wait_For_Completion. If we get here, we
 664             --  have timed out but we need to keep waiting until the call
 665             --  has actually completed or been cancelled successfully.
 666
 667             loop
 668                Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
 669                exit when Entry_Call.State >= Done;
 670                STPO.Sleep (Self_Id, Entry_Caller_Sleep);
 671             end loop;
 672
 673             Self_Id.Common.State := Runnable;
 674             Utilities.Exit_One_ATC_Level (Self_Id);
 675
 676             return;
 677          end if;
 678       end loop;
 679
 680       --  This last part is the same as ordinary Wait_For_Completion,
 681       --  and is only executed if the call completed without timing out.
 682
 683       if Parameters.Runtime_Traces then
 684          Send_Trace_Info (M_Call_Complete);
 685       end if;
 686
 687       Self_Id.Common.State := Runnable;
 688       Utilities.Exit_One_ATC_Level (Self_Id);
 689    end Wait_For_Completion_With_Timeout;
 690
 691    --------------------------
 692    -- Wait_Until_Abortable --
 693    --------------------------
 694
 695    procedure Wait_Until_Abortable
 696      (Self_ID : Task_ID;
 697       Call    : Entry_Call_Link) is
 698    begin
 699       pragma Assert (Self_ID.ATC_Nesting_Level > 0);
 700       pragma Assert (Call.Mode = Asynchronous_Call);
 701
 702       if Parameters.Runtime_Traces then
 703          Send_Trace_Info (W_Completion);
 704       end if;
 705
 706       STPO.Write_Lock (Self_ID);
 707       Self_ID.Common.State := Entry_Caller_Sleep;
 708
 709       loop
 710          Check_Pending_Actions_For_Entry_Call (Self_ID, Call);
 711          exit when Call.State >= Was_Abortable;
 712          STPO.Sleep (Self_ID, Async_Select_Sleep);
 713       end loop;
 714
 715       Self_ID.Common.State := Runnable;
 716       STPO.Unlock (Self_ID);
 717
 718       if Parameters.Runtime_Traces then
 719          Send_Trace_Info (M_Call_Complete);
 720       end if;
 721    end Wait_Until_Abortable;
 722
 723 end System.Tasking.Entry_Calls;