Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / gcc-lib / m68k-amigaos / 2.7.2.1 / adainclude / s-taenca.adb < prev next >

Wrap

Text File | 1995-10-17 | 12.0 KB | 353 lines

------------------------------------------------------------------------------ -- -- -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1991,1992,1993,1994,1995 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. -- -- -- ------------------------------------------------------------------------------ -- This package provides internal RTS calls implementing operations -- that apply to general entry calls, that is, calls to either -- protected or task entries. -- These declarations are not part of the GNARLI with System.Task_Primitives; use System.Task_Primitives; with System.Tasking.Queuing; use System.Tasking.Queuing; -- Used for, Queuing.Dequeue, -- Queuing.Enqueue with System.Tasking.Protected_Objects; -- Used for, Unlock, -- Service_Entries with System.Tasking.Utilities; -- Used for, Runtime_Assert_Shutdown with System.Tasking.Abortion; -- Used for, Change_Base_Priority package body System.Tasking.Entry_Calls is ------------------- -- Internal_Lock -- ------------------- procedure Internal_Lock (Object : access Protection; Ceiling_Violation : out Boolean) is begin Write_Lock (Object.L, Ceiling_Violation); end Internal_Lock; ----------------------------- -- Internal_Lock_Read_Only -- ----------------------------- procedure Internal_Lock_Read_Only (Object : access Protection; Ceiling_Violation : out Boolean) is begin Read_Lock (Object.L, Ceiling_Violation); end Internal_Lock_Read_Only; ----------------- -- Lock_Server -- ----------------- procedure Lock_Server (Entry_Call : Entry_Call_Link; No_Server : out Boolean) is Test_Task : Task_ID; Test_PO : Protection_Access; Ceiling_Violation : Boolean; begin Test_Task := Entry_Call.Called_Task; -- This must be atomic. loop if Test_Task = Null_Task then Test_PO := Entry_Call.Called_PO; -- This must be atomic. Test_Task := Entry_Call.Called_Task; -- Check the task again, just in case a transition between -- task and protected entry calls is taking place. if Test_PO = Null_PO and then Test_Task = Null_Task then No_Server := True; return; end if; Internal_Lock (Test_PO, Ceiling_Violation); -- ??? The following code allows Lock_Server to be called -- when cancelling a call, to allow for the possibility -- that the priority of the caller has been raised -- beyond that of the protected entry call by -- Ada.Dynamic_Priorities.Set_Priority. This test -- for other cases, resulting in slightly improved -- performance. -- If the current task has a higher priority than the ceiling -- of the protected object, temporarily lower it. It will -- be reset in Unlock. if Ceiling_Violation then declare Current_Task : Task_ID := Self; Old_Base_Priority : System.Priority; begin Write_Lock (Current_Task.L, Ceiling_Violation); Old_Base_Priority := Current_Task.Base_Priority; Current_Task.New_Base_Priority := Test_PO.Ceiling; System.Tasking.Abortion.Change_Base_Priority (Current_Task); Unlock (Current_Task.L); Internal_Lock (Test_PO, Ceiling_Violation); Test_PO.Old_Base_Priority := Old_Base_Priority; Test_PO.Pending_Action := True; end; end if; exit when Test_PO = Entry_Call.Called_PO; System.Tasking.Protected_Objects.Unlock (Test_PO); else Write_Lock (Test_Task.L, Ceiling_Violation); exit when Test_Task = Entry_Call.Called_Task; Unlock (Test_Task.L); end if; Test_Task := Entry_Call.Called_Task; -- This must be atomic. end loop; No_Server := False; end Lock_Server; ------------------- -- Unlock_Server -- ------------------- procedure Unlock_Server (Entry_Call : Entry_Call_Link) is begin if Entry_Call.Called_Task /= Null_Task then Unlock (Entry_Call.Called_Task.L); else System.Tasking.Protected_Objects.Unlock (Entry_Call.Called_PO); end if; end Unlock_Server; ------------------------------ -- Unlock_And_Update_Server -- ------------------------------ procedure Unlock_And_Update_Server (Entry_Call : Entry_Call_Link) is begin if Entry_Call.Called_Task /= Null_Task then Unlock (Entry_Call.Called_Task.L); else System.Tasking.Protected_Objects.Service_Entries (Entry_Call.Called_PO); System.Tasking.Protected_Objects.Unlock (Entry_Call.Called_PO); end if; end Unlock_And_Update_Server; ------------------ -- Enqueue_Call -- ------------------ procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is begin if Entry_Call.Called_Task /= Null_Task then Enqueue (Entry_Call.Called_Task.Entry_Queues (Task_Entry_Index (Entry_Call.E)), Entry_Call); else Enqueue (Entry_Call.Called_PO.Entry_Queues (Protected_Entry_Index (Entry_Call.E)), Entry_Call); end if; end Enqueue_Call; ------------------ -- Dequeue_Call -- ------------------ procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is begin if Entry_Call.Called_Task /= Null_Task then Dequeue (Entry_Call.Called_Task.Entry_Queues (Task_Entry_Index (Entry_Call.E)), Entry_Call); else Dequeue (Entry_Call.Called_PO.Entry_Queues (Protected_Entry_Index (Entry_Call.E)), Entry_Call); end if; end Dequeue_Call; ------------------------- -- Wait_For_Completion-- ------------------------- procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is Caller : Task_ID := Entry_Call.Self; Cancelled : Boolean := False; Error : Boolean; No_Server : Boolean; begin Write_Lock (Caller.L, Error); -- If this is a conditional call, it should be cancelled when it -- becomes abortable. This is checked in the loop below, but -- only when Caller.Pending_Action is True. For conditional -- calls, enable this check the first time through the loop. if Entry_Call.Mode = Conditional_Call then Caller.Pending_Action := True; end if; while not Entry_Call.Done and then not Cancelled loop if Caller.Pending_Action then Caller.Pending_Action := False; if Caller.Pending_Priority_Change then Abortion.Change_Base_Priority (Caller); -- Requeue the entry call at the new priority. This only -- needs to be done if the caller is blocked waiting -- for the call (D.5(16)). Unlock (Caller.L); Lock_Server (Entry_Call, No_Server); if Onqueue (Entry_Call) then Dequeue_Call (Entry_Call); Enqueue_Call (Entry_Call); end if; Unlock_Server (Entry_Call); Write_Lock (Caller.L, Error); end if; if Entry_Call.Mode = Conditional_Call or else Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level then Unlock (Caller.L); Lock_Server (Entry_Call, No_Server); if Entry_Call.Abortable then if Onqueue (Entry_Call) then Dequeue_Call (Entry_Call); end if; Cancelled := True; Unlock_And_Update_Server (Entry_Call); else Unlock_Server (Entry_Call); end if; Write_Lock (Caller.L, Error); end if; else Cond_Wait (Caller.Cond, Caller.L); end if; end loop; Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1; -- If we have reached the desired ATC nesting level, reset the -- requested level to effective infinity, to allow further calls. if Caller.Pending_ATC_Level = Caller.ATC_Nesting_Level then Caller.Pending_ATC_Level := ATC_Level_Infinity; Caller.Aborting := False; end if; -- If there is a pending abortion, the above loop may have -- reset the Pending_Action flag. This flag must be regenerated -- here so that Undefer_Abortion will complete the abortion. if Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level then Caller.Pending_Action := True; end if; Caller.Exception_To_Raise := Entry_Call.Exception_To_Raise; Unlock (Caller.L); end Wait_For_Completion; -------------------------- -- Wait_Until_Abortable -- -------------------------- procedure Wait_Until_Abortable (Caller : Task_ID; Call : Entry_Call_Link) is Abortable : Boolean := False; Error : Boolean; No_Server : Boolean; begin pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First or else System.Tasking.Utilities.Runtime_Assert_Shutdown ("Attempt to wait for a nonexistent call to be abortable.")); pragma Assert (Call.Mode = Asynchronous_Call or else System.Tasking.Utilities.Runtime_Assert_Shutdown ("Attempt to wait for a non-asynchronous call to be abortable")); Write_Lock (Caller.L, Error); if Call.Mode = Conditional_Call then Caller.Pending_Action := True; end if; while not Call.Done and then not Abortable loop if Caller.Pending_Action then Unlock (Caller.L); Lock_Server (Call, No_Server); pragma Assert (not No_Server or else System.Tasking.Utilities.Runtime_Assert_Shutdown ( "Entry call has no target")); if Call.Abortable then Abortable := True; end if; Unlock_Server (Call); Write_Lock (Caller.L, Error); else Cond_Wait (Caller.Cond, Caller.L); end if; end loop; Unlock (Caller.L); end Wait_Until_Abortable; end System.Tasking.Entry_Calls;