home *** CD-ROM | disk | FTP | other *** search
- ------------------------------------------------------------------------------
- -- --
- -- 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;
-