Mark ChangeLog
[official-gcc.git] / gcc / ada / s-tpoben.adb
blobc1d7d3ccae4b72fcafd7317e449571e40cff326b
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2004, 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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 -- This package contains all the simple primitives related to
35 -- Protected_Objects with entries (i.e init, lock, unlock).
37 -- The handling of protected objects with no entries is done in
38 -- System.Tasking.Protected_Objects, the complex routines for protected
39 -- objects with entries in System.Tasking.Protected_Objects.Operations.
40 -- The split between Entries and Operations is needed to break circular
41 -- dependencies inside the run time.
43 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
45 with Ada.Exceptions;
46 -- used for Exception_Occurrence_Access
47 -- Raise_Exception
49 with System.Task_Primitives.Operations;
50 -- used for Initialize_Lock
51 -- Write_Lock
52 -- Unlock
53 -- Get_Priority
54 -- Wakeup
56 with System.Tasking.Initialization;
57 -- used for Defer_Abort,
58 -- Undefer_Abort,
59 -- Change_Base_Priority
61 pragma Elaborate_All (System.Tasking.Initialization);
62 -- this insures that tasking is initialized if any protected objects are
63 -- created.
65 with System.Parameters;
66 -- used for Single_Lock
68 package body System.Tasking.Protected_Objects.Entries is
70 package STPO renames System.Task_Primitives.Operations;
72 use Parameters;
73 use Task_Primitives.Operations;
74 use Ada.Exceptions;
76 ----------------
77 -- Local Data --
78 ----------------
80 Locking_Policy : Character;
81 pragma Import (C, Locking_Policy, "__gl_locking_policy");
83 --------------
84 -- Finalize --
85 --------------
87 procedure Finalize (Object : in out Protection_Entries) is
88 Entry_Call : Entry_Call_Link;
89 Caller : Task_Id;
90 Ceiling_Violation : Boolean;
91 Self_ID : constant Task_Id := STPO.Self;
92 Old_Base_Priority : System.Any_Priority;
94 begin
95 if Object.Finalized then
96 return;
97 end if;
99 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
101 if Single_Lock then
102 Lock_RTS;
103 end if;
105 if Ceiling_Violation then
106 -- Dip our own priority down to ceiling of lock.
107 -- See similar code in Tasking.Entry_Calls.Lock_Server.
109 STPO.Write_Lock (Self_ID);
110 Old_Base_Priority := Self_ID.Common.Base_Priority;
111 Self_ID.New_Base_Priority := Object.Ceiling;
112 Initialization.Change_Base_Priority (Self_ID);
113 STPO.Unlock (Self_ID);
115 if Single_Lock then
116 Unlock_RTS;
117 end if;
119 STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation);
121 if Ceiling_Violation then
122 Raise_Exception (Program_Error'Identity, "Ceiling Violation");
123 end if;
125 if Single_Lock then
126 Lock_RTS;
127 end if;
129 Object.Old_Base_Priority := Old_Base_Priority;
130 Object.Pending_Action := True;
131 end if;
133 -- Send program_error to all tasks still queued on this object.
135 for E in Object.Entry_Queues'Range loop
136 Entry_Call := Object.Entry_Queues (E).Head;
138 while Entry_Call /= null loop
139 Caller := Entry_Call.Self;
140 Entry_Call.Exception_To_Raise := Program_Error'Identity;
142 STPO.Write_Lock (Caller);
143 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
144 STPO.Unlock (Caller);
146 exit when Entry_Call = Object.Entry_Queues (E).Tail;
147 Entry_Call := Entry_Call.Next;
148 end loop;
149 end loop;
151 Object.Finalized := True;
153 if Single_Lock then
154 Unlock_RTS;
155 end if;
157 STPO.Unlock (Object.L'Unrestricted_Access);
159 STPO.Finalize_Lock (Object.L'Unrestricted_Access);
160 end Finalize;
162 -------------------------------------
163 -- Has_Interrupt_Or_Attach_Handler --
164 -------------------------------------
166 function Has_Interrupt_Or_Attach_Handler
167 (Object : Protection_Entries_Access)
168 return Boolean
170 pragma Warnings (Off, Object);
171 begin
172 return False;
173 end Has_Interrupt_Or_Attach_Handler;
175 -----------------------------------
176 -- Initialize_Protection_Entries --
177 -----------------------------------
179 procedure Initialize_Protection_Entries
180 (Object : Protection_Entries_Access;
181 Ceiling_Priority : Integer;
182 Compiler_Info : System.Address;
183 Entry_Bodies : Protected_Entry_Body_Access;
184 Find_Body_Index : Find_Body_Index_Access)
186 Init_Priority : Integer := Ceiling_Priority;
187 Self_ID : constant Task_Id := STPO.Self;
189 begin
190 if Init_Priority = Unspecified_Priority then
191 Init_Priority := System.Priority'Last;
192 end if;
194 if Locking_Policy = 'C'
195 and then Has_Interrupt_Or_Attach_Handler (Object)
196 and then Init_Priority not in System.Interrupt_Priority
197 then
198 -- Required by C.3.1(11)
200 raise Program_Error;
201 end if;
203 Initialization.Defer_Abort (Self_ID);
204 Initialize_Lock (Init_Priority, Object.L'Access);
205 Initialization.Undefer_Abort (Self_ID);
206 Object.Ceiling := System.Any_Priority (Init_Priority);
207 Object.Compiler_Info := Compiler_Info;
208 Object.Pending_Action := False;
209 Object.Call_In_Progress := null;
210 Object.Entry_Bodies := Entry_Bodies;
211 Object.Find_Body_Index := Find_Body_Index;
213 for E in Object.Entry_Queues'Range loop
214 Object.Entry_Queues (E).Head := null;
215 Object.Entry_Queues (E).Tail := null;
216 end loop;
217 end Initialize_Protection_Entries;
219 ------------------
220 -- Lock_Entries --
221 ------------------
223 procedure Lock_Entries
224 (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean)
226 begin
227 if Object.Finalized then
228 Raise_Exception
229 (Program_Error'Identity, "Protected Object is finalized");
230 end if;
232 -- If pragma Detect_Blocking is active then Program_Error must
233 -- be raised if this potentially blocking operation is called from
234 -- a protected action, and the protected object nesting level
235 -- must be increased.
237 if Detect_Blocking then
238 declare
239 Self_Id : constant Task_Id := STPO.Self;
240 begin
241 if Self_Id.Common.Protected_Action_Nesting > 0 then
242 Ada.Exceptions.Raise_Exception
243 (Program_Error'Identity, "potentially blocking operation");
244 else
245 -- We are entering in a protected action, so that we
246 -- increase the protected object nesting level.
248 Self_Id.Common.Protected_Action_Nesting :=
249 Self_Id.Common.Protected_Action_Nesting + 1;
250 end if;
251 end;
252 end if;
254 -- The lock is made without defering abortion.
256 -- Therefore the abortion has to be deferred before calling this
257 -- routine. This means that the compiler has to generate a Defer_Abort
258 -- call before the call to Lock.
260 -- The caller is responsible for undeferring abortion, and compiler
261 -- generated calls must be protected with cleanup handlers to ensure
262 -- that abortion is undeferred in all cases.
264 pragma Assert (STPO.Self.Deferral_Level > 0);
265 Write_Lock (Object.L'Access, Ceiling_Violation);
266 end Lock_Entries;
268 procedure Lock_Entries (Object : Protection_Entries_Access) is
269 Ceiling_Violation : Boolean;
271 begin
272 Lock_Entries (Object, Ceiling_Violation);
274 if Ceiling_Violation then
275 Raise_Exception (Program_Error'Identity, "Ceiling Violation");
276 end if;
277 end Lock_Entries;
279 ----------------------------
280 -- Lock_Read_Only_Entries --
281 ----------------------------
283 procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is
284 Ceiling_Violation : Boolean;
286 begin
287 if Object.Finalized then
288 Raise_Exception
289 (Program_Error'Identity, "Protected Object is finalized");
290 end if;
292 -- If pragma Detect_Blocking is active then Program_Error must be
293 -- raised if this potentially blocking operation is called from a
294 -- protected action, and the protected object nesting level must
295 -- be increased.
297 if Detect_Blocking then
298 declare
299 Self_Id : constant Task_Id := STPO.Self;
300 begin
301 if Self_Id.Common.Protected_Action_Nesting > 0 then
302 Ada.Exceptions.Raise_Exception
303 (Program_Error'Identity, "potentially blocking operation");
304 else
305 -- We are entering in a protected action, so that we
306 -- increase the protected object nesting level.
308 Self_Id.Common.Protected_Action_Nesting :=
309 Self_Id.Common.Protected_Action_Nesting + 1;
310 end if;
311 end;
312 end if;
314 Read_Lock (Object.L'Access, Ceiling_Violation);
316 if Ceiling_Violation then
317 Raise_Exception (Program_Error'Identity, "Ceiling Violation");
318 end if;
319 end Lock_Read_Only_Entries;
321 --------------------
322 -- Unlock_Entries --
323 --------------------
325 procedure Unlock_Entries (Object : Protection_Entries_Access) is
326 begin
327 -- We are exiting from a protected action, so that we decrease the
328 -- protected object nesting level (if pragma Detect_Blocking is
329 -- active).
331 if Detect_Blocking then
332 declare
333 Self_Id : constant Task_Id := Self;
334 begin
335 -- Cannot call this procedure without being within a protected
336 -- action.
338 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0);
340 Self_Id.Common.Protected_Action_Nesting :=
341 Self_Id.Common.Protected_Action_Nesting - 1;
342 end;
343 end if;
345 Unlock (Object.L'Access);
346 end Unlock_Entries;
348 end System.Tasking.Protected_Objects.Entries;