URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasque.adb] - Blame information for rev 747

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                  GNAT RUN-TIME 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                                 --
--                                                                          --
--         Copyright (C) 1992-2009, 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 version of the body implements queueing policy according to the policy
--  specified by the pragma Queuing_Policy. When no such pragma is specified
--  FIFO policy is used as default.
 
with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
with System.Parameters;
 
package body System.Tasking.Queuing is
 
   use Parameters;
   use Task_Primitives.Operations;
   use Protected_Objects;
   use Protected_Objects.Entries;
 
   --  Entry Queues implemented as doubly linked list
 
   Queuing_Policy : Character;
   pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
 
   Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
 
   procedure Send_Program_Error
     (Self_ID    : Task_Id;
      Entry_Call : Entry_Call_Link);
   --  Raise Program_Error in the caller of the specified entry call
 
   function Check_Queue (E : Entry_Queue) return Boolean;
   --  Check the validity of E.
   --  Return True if E is valid, raise Assert_Failure if assertions are
   --  enabled and False otherwise.
 
   -----------------------------
   -- Broadcast_Program_Error --
   -----------------------------
 
   procedure Broadcast_Program_Error
     (Self_ID      : Task_Id;
      Object       : Protection_Entries_Access;
      Pending_Call : Entry_Call_Link;
      RTS_Locked   : Boolean := False)
   is
      Entry_Call : Entry_Call_Link;
   begin
      if Single_Lock and then not RTS_Locked then
         Lock_RTS;
      end if;
 
      if Pending_Call /= null then
         Send_Program_Error (Self_ID, 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);
 
            Send_Program_Error (Self_ID, Entry_Call);
            Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
         end loop;
      end loop;
 
      if Single_Lock and then not RTS_Locked then
         Unlock_RTS;
      end if;
   end Broadcast_Program_Error;
 
   -----------------
   -- Check_Queue --
   -----------------
 
   function Check_Queue (E : Entry_Queue) return Boolean is
      Valid   : Boolean := True;
      C, Prev : Entry_Call_Link;
 
   begin
      if E.Head = null then
         if E.Tail /= null then
            Valid := False;
            pragma Assert (Valid);
         end if;
      else
         if E.Tail = null
           or else E.Tail.Next /= E.Head
         then
            Valid := False;
            pragma Assert (Valid);
 
         else
            C := E.Head;
 
            loop
               Prev := C;
               C := C.Next;
 
               if C = null then
                  Valid := False;
                  pragma Assert (Valid);
                  exit;
               end if;
 
               if Prev /= C.Prev then
                  Valid := False;
                  pragma Assert (Valid);
                  exit;
               end if;
 
               exit when C = E.Head;
            end loop;
 
            if Prev /= E.Tail then
               Valid := False;
               pragma Assert (Valid);
            end if;
         end if;
      end if;
 
      return Valid;
   end Check_Queue;
 
   -------------------
   -- Count_Waiting --
   -------------------
 
   --  Return number of calls on the waiting queue of E
 
   function Count_Waiting (E : Entry_Queue) return Natural is
      Count   : Natural;
      Temp    : Entry_Call_Link;
 
   begin
      pragma Assert (Check_Queue (E));
 
      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;
 
   -------------
   -- Dequeue --
   -------------
 
   --  Dequeue call from entry_queue E
 
   procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
   begin
      pragma Assert (Check_Queue (E));
      pragma Assert (Call /= null);
 
      --  If empty queue, simply return
 
      if E.Head = null then
         return;
      end if;
 
      pragma Assert (Call.Prev /= null);
      pragma Assert (Call.Next /= null);
 
      Call.Prev.Next := Call.Next;
      Call.Next.Prev := Call.Prev;
 
      if E.Head = Call then
 
         --  Case of one element
 
         if E.Tail = Call then
            E.Head := null;
            E.Tail := null;
 
         --  More than one element
 
         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;
      pragma Assert (Check_Queue (E));
   end Dequeue;
 
   ------------------
   -- Dequeue_Call --
   ------------------
 
   procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
      Called_PO : Protection_Entries_Access;
 
   begin
      pragma Assert (Entry_Call /= null);
 
      if Entry_Call.Called_Task /= null then
         Dequeue
           (Entry_Call.Called_Task.Entry_Queues
             (Task_Entry_Index (Entry_Call.E)),
           Entry_Call);
 
      else
         Called_PO := To_Protection (Entry_Call.Called_PO);
         Dequeue (Called_PO.Entry_Queues
             (Protected_Entry_Index (Entry_Call.E)),
           Entry_Call);
      end if;
   end Dequeue_Call;
 
   ------------------
   -- 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
      pragma Assert (Check_Queue (E));
      --  If empty queue, return null pointer
 
      if E.Head = null then
         Call := null;
         return;
      end if;
 
      Temp := E.Head;
 
      --  Case of one element
 
      if E.Head = E.Tail then
         E.Head := null;
         E.Tail := null;
 
      --  More than one element
 
      else
         pragma Assert (Temp /= null);
         pragma Assert (Temp.Next /= null);
         pragma Assert (Temp.Prev /= null);
 
         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;
      pragma Assert (Check_Queue (E));
   end Dequeue_Head;
 
   -------------
   -- Enqueue --
   -------------
 
   --  Enqueue call at the end of entry_queue E, for FIFO queuing policy.
   --  Enqueue call priority ordered, FIFO at same priority level, for
   --  Priority queuing policy.
 
   procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
      Temp : Entry_Call_Link := E.Head;
 
   begin
      pragma Assert (Check_Queue (E));
      pragma Assert (Call /= null);
 
      --  Priority Queuing
 
      if Priority_Queuing then
         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;
 
               --  Insert at head
 
               if Temp = E.Head then
                  E.Head := Call;
               end if;
            end if;
 
            pragma Assert (Call.Prev /= null);
            pragma Assert (Call.Next /= null);
 
            Call.Prev.Next := Call;
            Call.Next.Prev := Call;
         end if;
 
         pragma Assert (Check_Queue (E));
         return;
      end if;
 
      --  FIFO Queuing
 
      if E.Head = null then
         E.Head := Call;
      else
         E.Tail.Next := Call;
         Call.Prev   := E.Tail;
      end if;
 
      E.Head.Prev := Call;
      E.Tail      := Call;
      Call.Next   := E.Head;
      pragma Assert (Check_Queue (E));
   end Enqueue;
 
   ------------------
   -- Enqueue_Call --
   ------------------
 
   procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
      Called_PO : Protection_Entries_Access;
 
   begin
      pragma Assert (Entry_Call /= null);
 
      if Entry_Call.Called_Task /= null then
         Enqueue
           (Entry_Call.Called_Task.Entry_Queues
              (Task_Entry_Index (Entry_Call.E)),
           Entry_Call);
 
      else
         Called_PO := To_Protection (Entry_Call.Called_PO);
         Enqueue (Called_PO.Entry_Queues
             (Protected_Entry_Index (Entry_Call.E)),
           Entry_Call);
      end if;
   end Enqueue_Call;
 
   ----------
   -- Head --
   ----------
 
   --  Return the head of entry_queue E
 
   function Head (E : Entry_Queue) return Entry_Call_Link is
   begin
      pragma Assert (Check_Queue (E));
      return E.Head;
   end Head;
 
   -------------
   -- Onqueue --
   -------------
 
   --  Return True if Call is on any entry_queue at all
 
   function Onqueue (Call : Entry_Call_Link) return Boolean is
   begin
      pragma Assert (Call /= null);
 
      --  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;
 
   --------------------------------
   -- Requeue_Call_With_New_Prio --
   --------------------------------
 
   procedure Requeue_Call_With_New_Prio
     (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
   begin
      pragma Assert (Entry_Call /= null);
 
      --  Perform a queue reordering only when the policy being used is the
      --  Priority Queuing.
 
      if Priority_Queuing then
         if Onqueue (Entry_Call) then
            Dequeue_Call (Entry_Call);
            Entry_Call.Prio := Prio;
            Enqueue_Call (Entry_Call);
         end if;
      end if;
   end Requeue_Call_With_New_Prio;
 
   ---------------------------------
   -- Select_Protected_Entry_Call --
   ---------------------------------
 
   --  Select an entry of a protected object. Selection depends on the
   --  queuing policy being used.
 
   procedure Select_Protected_Entry_Call
     (Self_ID : Task_Id;
      Object  : Protection_Entries_Access;
      Call    : out Entry_Call_Link)
   is
      Entry_Call  : Entry_Call_Link;
      Temp_Call   : Entry_Call_Link;
      Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
 
   begin
      Entry_Call := null;
 
      begin
         --  Priority queuing case
 
         if Priority_Queuing then
            for J in Object.Entry_Queues'Range loop
               Temp_Call := Head (Object.Entry_Queues (J));
 
               if Temp_Call /= null
                 and then
                   Object.Entry_Bodies
                     (Object.Find_Body_Index
                       (Object.Compiler_Info, 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;
 
         --  FIFO queueing case
 
         else
            for J in Object.Entry_Queues'Range loop
               Temp_Call := Head (Object.Entry_Queues (J));
 
               if Temp_Call /= null
                 and then
                   Object.Entry_Bodies
                     (Object.Find_Body_Index
                       (Object.Compiler_Info, J)).
                          Barrier (Object.Compiler_Info, J)
               then
                  Entry_Call := Temp_Call;
                  Entry_Index := J;
                  exit;
               end if;
            end loop;
         end if;
 
      exception
         when others =>
            Broadcast_Program_Error (Self_ID, Object, null);
      end;
 
      --  If a call was selected, dequeue it and return it for service
 
      if Entry_Call /= null then
         Temp_Call := Entry_Call;
         Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
         pragma Assert (Temp_Call = Entry_Call);
      end if;
 
      Call := Entry_Call;
   end Select_Protected_Entry_Call;
 
   ----------------------------
   -- Select_Task_Entry_Call --
   ----------------------------
 
   --  Select an entry for rendezvous. Selection depends on the queuing policy
   --  being used.
 
   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 := Task_Entry_Index'First;
      Temp_Entry  : Task_Entry_Index;
 
   begin
      Open_Alternative := False;
      Entry_Call       := null;
      Selection        := No_Rendezvous;
 
      if Priority_Queuing then
         --  Priority queueing case
 
         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;
 
      else
         --  FIFO Queuing case
 
         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 then
                  Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
                  Entry_Index := Temp_Entry;
                  Selection := J;
                  exit;
               end if;
            end if;
         end loop;
      end if;
 
      if Entry_Call /= null then
         Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
 
         --  Guard is open
      end if;
 
      Call := Entry_Call;
   end Select_Task_Entry_Call;
 
   ------------------------
   -- Send_Program_Error --
   ------------------------
 
   procedure Send_Program_Error
     (Self_ID    : Task_Id;
      Entry_Call : Entry_Call_Link)
   is
      Caller : Task_Id;
   begin
      Caller := Entry_Call.Self;
      Entry_Call.Exception_To_Raise := Program_Error'Identity;
      Write_Lock (Caller);
      Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
      Unlock (Caller);
   end Send_Program_Error;
 
end System.Tasking.Queuing;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-tasque.adb] - Blame information for rev 747

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --`
4			`-- --`
5			`-- S Y S T E M . T A S K I N G . Q U E U I N G --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNARL is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- GNARL was developed by the GNARL team at Florida State University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies, Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`-- This version of the body implements queueing policy according to the policy`
33			`-- specified by the pragma Queuing_Policy. When no such pragma is specified`
34			`-- FIFO policy is used as default.`
35
36			`with System.Task_Primitives.Operations;`
37			`with System.Tasking.Initialization;`
38			`with System.Parameters;`
39
40			`package body System.Tasking.Queuing is`
41
42			`use Parameters;`
43			`use Task_Primitives.Operations;`
44			`use Protected_Objects;`
45			`use Protected_Objects.Entries;`
46
47			`-- Entry Queues implemented as doubly linked list`
48
49			`Queuing_Policy : Character;`
50			`pragma Import (C, Queuing_Policy, "__gl_queuing_policy");`
51
52			`Priority_Queuing : constant Boolean := Queuing_Policy = 'P';`
53
54			`procedure Send_Program_Error`
55			`(Self_ID : Task_Id;`
56			`Entry_Call : Entry_Call_Link);`
57			`-- Raise Program_Error in the caller of the specified entry call`
58
59			`function Check_Queue (E : Entry_Queue) return Boolean;`
60			`-- Check the validity of E.`
61			`-- Return True if E is valid, raise Assert_Failure if assertions are`
62			`-- enabled and False otherwise.`
63
64			`-----------------------------`
65			`-- Broadcast_Program_Error --`
66			`-----------------------------`
67
68			`procedure Broadcast_Program_Error`
69			`(Self_ID : Task_Id;`
70			`Object : Protection_Entries_Access;`
71			`Pending_Call : Entry_Call_Link;`
72			`RTS_Locked : Boolean := False)`
73			`is`
74			`Entry_Call : Entry_Call_Link;`
75			`begin`
76			`if Single_Lock and then not RTS_Locked then`
77			`Lock_RTS;`
78			`end if;`
79
80			`if Pending_Call /= null then`
81			`Send_Program_Error (Self_ID, Pending_Call);`
82			`end if;`
83
84			`for E in Object.Entry_Queues'Range loop`
85			`Dequeue_Head (Object.Entry_Queues (E), Entry_Call);`
86
87			`while Entry_Call /= null loop`
88			`pragma Assert (Entry_Call.Mode /= Conditional_Call);`
89
90			`Send_Program_Error (Self_ID, Entry_Call);`
91			`Dequeue_Head (Object.Entry_Queues (E), Entry_Call);`
92			`end loop;`
93			`end loop;`
94
95			`if Single_Lock and then not RTS_Locked then`
96			`Unlock_RTS;`
97			`end if;`
98			`end Broadcast_Program_Error;`
99
100			`-----------------`
101			`-- Check_Queue --`
102			`-----------------`
103
104			`function Check_Queue (E : Entry_Queue) return Boolean is`
105			`Valid : Boolean := True;`
106			`C, Prev : Entry_Call_Link;`
107
108			`begin`
109			`if E.Head = null then`
110			`if E.Tail /= null then`
111			`Valid := False;`
112			`pragma Assert (Valid);`
113			`end if;`
114			`else`
115			`if E.Tail = null`
116			`or else E.Tail.Next /= E.Head`
117			`then`
118			`Valid := False;`
119			`pragma Assert (Valid);`
120
121			`else`
122			`C := E.Head;`
123
124			`loop`
125			`Prev := C;`
126			`C := C.Next;`
127
128			`if C = null then`
129			`Valid := False;`
130			`pragma Assert (Valid);`
131			`exit;`
132			`end if;`
133
134			`if Prev /= C.Prev then`
135			`Valid := False;`
136			`pragma Assert (Valid);`
137			`exit;`
138			`end if;`
139
140			`exit when C = E.Head;`
141			`end loop;`
142
143			`if Prev /= E.Tail then`
144			`Valid := False;`
145			`pragma Assert (Valid);`
146			`end if;`
147			`end if;`
148			`end if;`
149
150			`return Valid;`
151			`end Check_Queue;`
152
153			`-------------------`
154			`-- Count_Waiting --`
155			`-------------------`
156
157			`-- Return number of calls on the waiting queue of E`
158
159			`function Count_Waiting (E : Entry_Queue) return Natural is`
160			`Count : Natural;`
161			`Temp : Entry_Call_Link;`
162
163			`begin`
164			`pragma Assert (Check_Queue (E));`
165
166			`Count := 0;`
167
168			`if E.Head /= null then`
169			`Temp := E.Head;`
170
171			`loop`
172			`Count := Count + 1;`
173			`exit when E.Tail = Temp;`
174			`Temp := Temp.Next;`
175			`end loop;`
176			`end if;`
177
178			`return Count;`
179			`end Count_Waiting;`
180
181			`-------------`
182			`-- Dequeue --`
183			`-------------`
184
185			`-- Dequeue call from entry_queue E`
186
187			`procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is`
188			`begin`
189			`pragma Assert (Check_Queue (E));`
190			`pragma Assert (Call /= null);`
191
192			`-- If empty queue, simply return`
193
194			`if E.Head = null then`
195			`return;`
196			`end if;`
197
198			`pragma Assert (Call.Prev /= null);`
199			`pragma Assert (Call.Next /= null);`
200
201			`Call.Prev.Next := Call.Next;`
202			`Call.Next.Prev := Call.Prev;`
203
204			`if E.Head = Call then`
205
206			`-- Case of one element`
207
208			`if E.Tail = Call then`
209			`E.Head := null;`
210			`E.Tail := null;`
211
212			`-- More than one element`
213
214			`else`
215			`E.Head := Call.Next;`
216			`end if;`
217
218			`elsif E.Tail = Call then`
219			`E.Tail := Call.Prev;`
220			`end if;`
221
222			`-- Successfully dequeued`
223
224			`Call.Prev := null;`
225			`Call.Next := null;`
226			`pragma Assert (Check_Queue (E));`
227			`end Dequeue;`
228
229			`------------------`
230			`-- Dequeue_Call --`
231			`------------------`
232
233			`procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is`
234			`Called_PO : Protection_Entries_Access;`
235
236			`begin`
237			`pragma Assert (Entry_Call /= null);`
238
239			`if Entry_Call.Called_Task /= null then`
240			`Dequeue`
241			`(Entry_Call.Called_Task.Entry_Queues`
242			`(Task_Entry_Index (Entry_Call.E)),`
243			`Entry_Call);`
244
245			`else`
246			`Called_PO := To_Protection (Entry_Call.Called_PO);`
247			`Dequeue (Called_PO.Entry_Queues`
248			`(Protected_Entry_Index (Entry_Call.E)),`
249			`Entry_Call);`
250			`end if;`
251			`end Dequeue_Call;`
252
253			`------------------`
254			`-- Dequeue_Head --`
255			`------------------`
256
257			`-- Remove and return the head of entry_queue E`
258
259			`procedure Dequeue_Head`
260			`(E : in out Entry_Queue;`
261			`Call : out Entry_Call_Link)`
262			`is`
263			`Temp : Entry_Call_Link;`
264
265			`begin`
266			`pragma Assert (Check_Queue (E));`
267			`-- If empty queue, return null pointer`
268
269			`if E.Head = null then`
270			`Call := null;`
271			`return;`
272			`end if;`
273
274			`Temp := E.Head;`
275
276			`-- Case of one element`
277
278			`if E.Head = E.Tail then`
279			`E.Head := null;`
280			`E.Tail := null;`
281
282			`-- More than one element`
283
284			`else`
285			`pragma Assert (Temp /= null);`
286			`pragma Assert (Temp.Next /= null);`
287			`pragma Assert (Temp.Prev /= null);`
288
289			`E.Head := Temp.Next;`
290			`Temp.Prev.Next := Temp.Next;`
291			`Temp.Next.Prev := Temp.Prev;`
292			`end if;`
293
294			`-- Successfully dequeued`
295
296			`Temp.Prev := null;`
297			`Temp.Next := null;`
298			`Call := Temp;`
299			`pragma Assert (Check_Queue (E));`
300			`end Dequeue_Head;`
301
302			`-------------`
303			`-- Enqueue --`
304			`-------------`
305
306			`-- Enqueue call at the end of entry_queue E, for FIFO queuing policy.`
307			`-- Enqueue call priority ordered, FIFO at same priority level, for`
308			`-- Priority queuing policy.`
309
310			`procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is`
311			`Temp : Entry_Call_Link := E.Head;`
312
313			`begin`
314			`pragma Assert (Check_Queue (E));`
315			`pragma Assert (Call /= null);`
316
317			`-- Priority Queuing`
318
319			`if Priority_Queuing then`
320			`if Temp = null then`
321			`Call.Prev := Call;`
322			`Call.Next := Call;`
323			`E.Head := Call;`
324			`E.Tail := Call;`
325
326			`else`
327			`loop`
328			`-- Find the entry that the new guy should precede`
329
330			`exit when Call.Prio > Temp.Prio;`
331			`Temp := Temp.Next;`
332
333			`if Temp = E.Head then`
334			`Temp := null;`
335			`exit;`
336			`end if;`
337			`end loop;`
338
339			`if Temp = null then`
340			`-- Insert at tail`
341
342			`Call.Prev := E.Tail;`
343			`Call.Next := E.Head;`
344			`E.Tail := Call;`
345
346			`else`
347			`Call.Prev := Temp.Prev;`
348			`Call.Next := Temp;`
349
350			`-- Insert at head`
351
352			`if Temp = E.Head then`
353			`E.Head := Call;`
354			`end if;`
355			`end if;`
356
357			`pragma Assert (Call.Prev /= null);`
358			`pragma Assert (Call.Next /= null);`
359
360			`Call.Prev.Next := Call;`
361			`Call.Next.Prev := Call;`
362			`end if;`
363
364			`pragma Assert (Check_Queue (E));`
365			`return;`
366			`end if;`
367
368			`-- FIFO Queuing`
369
370			`if E.Head = null then`
371			`E.Head := Call;`
372			`else`
373			`E.Tail.Next := Call;`
374			`Call.Prev := E.Tail;`
375			`end if;`
376
377			`E.Head.Prev := Call;`
378			`E.Tail := Call;`
379			`Call.Next := E.Head;`
380			`pragma Assert (Check_Queue (E));`
381			`end Enqueue;`
382
383			`------------------`
384			`-- Enqueue_Call --`
385			`------------------`
386
387			`procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is`
388			`Called_PO : Protection_Entries_Access;`
389
390			`begin`
391			`pragma Assert (Entry_Call /= null);`
392
393			`if Entry_Call.Called_Task /= null then`
394			`Enqueue`
395			`(Entry_Call.Called_Task.Entry_Queues`
396			`(Task_Entry_Index (Entry_Call.E)),`
397			`Entry_Call);`
398
399			`else`
400			`Called_PO := To_Protection (Entry_Call.Called_PO);`
401			`Enqueue (Called_PO.Entry_Queues`
402			`(Protected_Entry_Index (Entry_Call.E)),`
403			`Entry_Call);`
404			`end if;`
405			`end Enqueue_Call;`
406
407			`----------`
408			`-- Head --`
409			`----------`
410
411			`-- Return the head of entry_queue E`
412
413			`function Head (E : Entry_Queue) return Entry_Call_Link is`
414			`begin`
415			`pragma Assert (Check_Queue (E));`
416			`return E.Head;`
417			`end Head;`
418
419			`-------------`
420			`-- Onqueue --`
421			`-------------`
422
423			`-- Return True if Call is on any entry_queue at all`
424
425			`function Onqueue (Call : Entry_Call_Link) return Boolean is`
426			`begin`
427			`pragma Assert (Call /= null);`
428
429			`-- Utilize the fact that every queue is circular, so if Call`
430			`-- is on any queue at all, Call.Next must NOT be null.`
431
432			`return Call.Next /= null;`
433			`end Onqueue;`
434
435			`--------------------------------`
436			`-- Requeue_Call_With_New_Prio --`
437			`--------------------------------`
438
439			`procedure Requeue_Call_With_New_Prio`
440			`(Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is`
441			`begin`
442			`pragma Assert (Entry_Call /= null);`
443
444			`-- Perform a queue reordering only when the policy being used is the`
445			`-- Priority Queuing.`
446
447			`if Priority_Queuing then`
448			`if Onqueue (Entry_Call) then`
449			`Dequeue_Call (Entry_Call);`
450			`Entry_Call.Prio := Prio;`
451			`Enqueue_Call (Entry_Call);`
452			`end if;`
453			`end if;`
454			`end Requeue_Call_With_New_Prio;`
455
456			`---------------------------------`
457			`-- Select_Protected_Entry_Call --`
458			`---------------------------------`
459
460			`-- Select an entry of a protected object. Selection depends on the`
461			`-- queuing policy being used.`
462
463			`procedure Select_Protected_Entry_Call`
464			`(Self_ID : Task_Id;`
465			`Object : Protection_Entries_Access;`
466			`Call : out Entry_Call_Link)`
467			`is`
468			`Entry_Call : Entry_Call_Link;`
469			`Temp_Call : Entry_Call_Link;`
470			`Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning`
471
472			`begin`
473			`Entry_Call := null;`
474
475			`begin`
476			`-- Priority queuing case`
477
478			`if Priority_Queuing then`
479			`for J in Object.Entry_Queues'Range loop`
480			`Temp_Call := Head (Object.Entry_Queues (J));`
481
482			`if Temp_Call /= null`
483			`and then`
484			`Object.Entry_Bodies`
485			`(Object.Find_Body_Index`
486			`(Object.Compiler_Info, J)).`
487			`Barrier (Object.Compiler_Info, J)`
488			`then`
489			`if Entry_Call = null`
490			`or else Entry_Call.Prio < Temp_Call.Prio`
491			`then`
492			`Entry_Call := Temp_Call;`
493			`Entry_Index := J;`
494			`end if;`
495			`end if;`
496			`end loop;`
497
498			`-- FIFO queueing case`
499
500			`else`
501			`for J in Object.Entry_Queues'Range loop`
502			`Temp_Call := Head (Object.Entry_Queues (J));`
503
504			`if Temp_Call /= null`
505			`and then`
506			`Object.Entry_Bodies`
507			`(Object.Find_Body_Index`
508			`(Object.Compiler_Info, J)).`
509			`Barrier (Object.Compiler_Info, J)`
510			`then`
511			`Entry_Call := Temp_Call;`
512			`Entry_Index := J;`
513			`exit;`
514			`end if;`
515			`end loop;`
516			`end if;`
517
518			`exception`
519			`when others =>`
520			`Broadcast_Program_Error (Self_ID, Object, null);`
521			`end;`
522
523			`-- If a call was selected, dequeue it and return it for service`
524
525			`if Entry_Call /= null then`
526			`Temp_Call := Entry_Call;`
527			`Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);`
528			`pragma Assert (Temp_Call = Entry_Call);`
529			`end if;`
530
531			`Call := Entry_Call;`
532			`end Select_Protected_Entry_Call;`
533
534			`----------------------------`
535			`-- Select_Task_Entry_Call --`
536			`----------------------------`
537
538			`-- Select an entry for rendezvous. Selection depends on the queuing policy`
539			`-- being used.`
540
541			`procedure Select_Task_Entry_Call`
542			`(Acceptor : Task_Id;`
543			`Open_Accepts : Accept_List_Access;`
544			`Call : out Entry_Call_Link;`
545			`Selection : out Select_Index;`
546			`Open_Alternative : out Boolean)`
547			`is`
548			`Entry_Call : Entry_Call_Link;`
549			`Temp_Call : Entry_Call_Link;`
550			`Entry_Index : Task_Entry_Index := Task_Entry_Index'First;`
551			`Temp_Entry : Task_Entry_Index;`
552
553			`begin`
554			`Open_Alternative := False;`
555			`Entry_Call := null;`
556			`Selection := No_Rendezvous;`
557
558			`if Priority_Queuing then`
559			`-- Priority queueing case`
560
561			`for J in Open_Accepts'Range loop`
562			`Temp_Entry := Open_Accepts (J).S;`
563
564			`if Temp_Entry /= Null_Task_Entry then`
565			`Open_Alternative := True;`
566			`Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));`
567
568			`if Temp_Call /= null`
569			`and then (Entry_Call = null`
570			`or else Entry_Call.Prio < Temp_Call.Prio)`
571			`then`
572			`Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));`
573			`Entry_Index := Temp_Entry;`
574			`Selection := J;`
575			`end if;`
576			`end if;`
577			`end loop;`
578
579			`else`
580			`-- FIFO Queuing case`
581
582			`for J in Open_Accepts'Range loop`
583			`Temp_Entry := Open_Accepts (J).S;`
584
585			`if Temp_Entry /= Null_Task_Entry then`
586			`Open_Alternative := True;`
587			`Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));`
588
589			`if Temp_Call /= null then`
590			`Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));`
591			`Entry_Index := Temp_Entry;`
592			`Selection := J;`
593			`exit;`
594			`end if;`
595			`end if;`
596			`end loop;`
597			`end if;`
598
599			`if Entry_Call /= null then`
600			`Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);`
601
602			`-- Guard is open`
603			`end if;`
604
605			`Call := Entry_Call;`
606			`end Select_Task_Entry_Call;`
607
608			`------------------------`
609			`-- Send_Program_Error --`
610			`------------------------`
611
612			`procedure Send_Program_Error`
613			`(Self_ID : Task_Id;`
614			`Entry_Call : Entry_Call_Link)`
615			`is`
616			`Caller : Task_Id;`
617			`begin`
618			`Caller := Entry_Call.Self;`
619			`Entry_Call.Exception_To_Raise := Program_Error'Identity;`
620			`Write_Lock (Caller);`
621			`Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);`
622			`Unlock (Caller);`
623			`end Send_Program_Error;`
624
625			`end System.Tasking.Queuing;`