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-tasque.adb < prev next >

Wrap

Text File | 1995-10-17 | 10.0 KB | 349 lines

------------------------------------------------------------------------------ -- -- -- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- -- -- -- S Y S T E M . T A S K I N G . Q U E U I N G -- -- -- -- B o d y -- -- -- -- $Revision: 1.14 $ -- -- -- -- 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. -- -- -- ------------------------------------------------------------------------------ with System.Task_Primitives; use System.Task_Primitives; with System.Tasking.Utilities; -- Used for Abort_To_Level package body System.Tasking.Queuing is -- Entry Queues implemented as doubly linked list, priority ordered procedure Send_Program_Error (Entry_Call : Entry_Call_Link); -- Raise Program_Error in the caller of the specified entry -- call. ------------------------ -- Send_Program_Error -- ------------------------ procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is Current_Task : Task_ID; Error : Boolean; begin Current_Task := Entry_Call.Self; Entry_Call.Exception_To_Raise := System.Compiler_Exceptions.Program_Error_ID; Write_Lock (Current_Task.L, Error); Entry_Call.Done := True; Unlock (Current_Task.L); Utilities.Abort_To_Level (Current_Task, Entry_Call.Level - 1); end Send_Program_Error; ----------------------------- -- Broadcast_Program_Error -- ----------------------------- procedure Broadcast_Program_Error (Object : access Protection; Pending_Call : Entry_Call_Link) is Entry_Call : Entry_Call_Link; begin if Pending_Call /= null then Send_Program_Error (Pending_Call); end if; for E in Object.Entry_Queues'Range loop Dequeue_Head (Object.Entry_Queues (E), Entry_Call); while Entry_Call /= null loop pragma Assert (Entry_Call.Mode /= Conditional_Call or else Utilities.Runtime_Assert_Shutdown ( "Conditional call found on entry queue.")); Send_Program_Error (Entry_Call); Dequeue_Head (Object.Entry_Queues (E), Entry_Call); end loop; end loop; end Broadcast_Program_Error; ------------- -- Enqueue -- ------------- -- Enqueue call priority ordered, FIFO at same priority level procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is Temp : Entry_Call_Link := E.Head; begin if Temp = null then Call.Prev := Call; Call.Next := Call; E.Head := Call; E.Tail := Call; else loop -- find the entry that the new guy should precede exit when Call.Prio > Temp.Prio; Temp := Temp.Next; if Temp = E.Head then Temp := null; exit; end if; end loop; if Temp = null then -- insert at tail Call.Prev := E.Tail; Call.Next := E.Head; E.Tail := Call; else Call.Prev := Temp.Prev; Call.Next := Temp; if Temp = E.Head then -- insert at head E.Head := Call; end if; end if; Call.Prev.Next := Call; Call.Next.Prev := Call; end if; end Enqueue; ------------- -- Dequeue -- ------------- -- Dequeue call from entry_queue E procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is Prev : Entry_Call_Link; begin -- If empty queue, simply return if E.Head = null then return; end if; Call.Prev.Next := Call.Next; Call.Next.Prev := Call.Prev; if E.Head = Call then if E.Tail = Call then E.Head := null; -- case of one element E.Tail := null; else E.Head := Call.Next; end if; elsif E.Tail = Call then E.Tail := Call.Prev; end if; -- Successfully dequeued Call.Prev := null; Call.Next := null; end Dequeue; ---------- -- Head -- ---------- -- Return the head of entry_queue E function Head (E : in Entry_Queue) return Entry_Call_Link is begin return E.Head; end Head; ------------------ -- Dequeue_Head -- ------------------ -- Remove and return the head of entry_queue E procedure Dequeue_Head (E : in out Entry_Queue; Call : out Entry_Call_Link) is Temp : Entry_Call_Link; begin -- If empty queue, return null pointer if E.Head = null then Call := null; return; end if; Temp := E.Head; if E.Head = E.Tail then E.Head := null; -- case of one element E.Tail := null; else E.Head := Temp.Next; Temp.Prev.Next := Temp.Next; Temp.Next.Prev := Temp.Prev; end if; -- Successfully dequeued Temp.Prev := null; Temp.Next := null; Call := Temp; end Dequeue_Head; ------------- -- Onqueue -- ------------- -- Return True if Call is on any entry_queue at all function Onqueue (Call : Entry_Call_Link) return Boolean is begin -- Utilize the fact that every queue is circular, so if Call -- is on any queue at all, Call.Next must NOT be null. return Call.Next /= null; end Onqueue; ------------------- -- Count_Waiting -- ------------------- -- Return number of calls on the waiting queue of E function Count_Waiting (E : in Entry_Queue) return Natural is Count : Natural; Temp : Entry_Call_Link; begin Count := 0; if E.Head /= null then Temp := E.Head; loop Count := Count + 1; exit when E.Tail = Temp; Temp := Temp.Next; end loop; end if; return Count; end Count_Waiting; ---------------------------- -- Select_Task_Entry_Call -- ---------------------------- -- Select an entry for rendezvous procedure Select_Task_Entry_Call (Acceptor : Task_ID; Open_Accepts : Accept_List_Access; Call : out Entry_Call_Link; Selection : out Select_Index; Open_Alternative : out Boolean) is Entry_Call : Entry_Call_Link; Temp_Call : Entry_Call_Link; Entry_Index : Task_Entry_Index; Temp_Entry : Task_Entry_Index; TAS_Result : Boolean; begin Open_Alternative := False; Entry_Call := null; for J in Open_Accepts'Range loop Temp_Entry := Open_Accepts (J).S; if Temp_Entry /= Null_Task_Entry then Open_Alternative := True; Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); if Temp_Call /= null and then (Entry_Call = null or else Entry_Call.Prio < Temp_Call.Prio) then Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); Entry_Index := Temp_Entry; Selection := J; end if; end if; end loop; if Entry_Call = null then Selection := No_Rendezvous; else Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); -- Guard is open end if; Call := Entry_Call; end Select_Task_Entry_Call; --------------------------------- -- Select_Protected_Entry_Call -- --------------------------------- -- Select an entry of a protected object procedure Select_Protected_Entry_Call (Object : access Protection; Call : out Entry_Call_Link) is Entry_Call : Entry_Call_Link; Temp_Call : Entry_Call_Link; Entry_Index : Protected_Entry_Index; TAS_Result : Boolean; begin Entry_Call := null; begin for J in Object.Entry_Queues'Range loop Temp_Call := Head (Object.Entry_Queues (J)); if Temp_Call /= null and then Object.Entry_Bodies (J).Barrier (Object.Compiler_Info, J) then if (Entry_Call = null or else Entry_Call.Prio < Temp_Call.Prio) then Entry_Call := Temp_Call; Entry_Index := J; end if; end if; end loop; exception when others => Broadcast_Program_Error (Object, null); end; -- If a call was selected, dequeue it and return it for service. if Entry_Call /= null then Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call); end if; Call := Entry_Call; end Select_Protected_Entry_Call; end System.Tasking.Queuing;