1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.ENTRIES --
10 -- Copyright (C) 1998-2001, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- This package contains all the simple primitives related to
36 -- Protected_Objects with entries (i.e init, lock, unlock).
38 -- The handling of protected objects with no entries is done in
39 -- System.Tasking.Protected_Objects, the complex routines for protected
40 -- objects with entries in System.Tasking.Protected_Objects.Operations.
41 -- The split between Entries and Operations is needed to break circular
42 -- dependencies inside the run time.
44 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
47 -- used for Exception_Occurrence_Access
49 with System
.Task_Primitives
.Operations
;
50 -- used for Initialize_Lock
56 with System
.Tasking
.Initialization
;
57 -- used for Defer_Abort,
59 -- Change_Base_Priority
61 pragma Elaborate_All
(System
.Tasking
.Initialization
);
62 -- this insures that tasking is initialized if any protected objects are
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
;
73 use Task_Primitives
.Operations
;
76 Locking_Policy
: Character;
77 pragma Import
(C
, Locking_Policy
, "__gl_locking_policy");
83 procedure Finalize
(Object
: in out Protection_Entries
) is
84 Entry_Call
: Entry_Call_Link
;
86 Ceiling_Violation
: Boolean;
87 Self_ID
: constant Task_ID
:= STPO
.Self
;
88 Old_Base_Priority
: System
.Any_Priority
;
91 if Object
.Finalized
then
95 STPO
.Write_Lock
(Object
.L
'Unrestricted_Access, Ceiling_Violation
);
101 if Ceiling_Violation
then
102 -- Dip our own priority down to ceiling of lock.
103 -- See similar code in Tasking.Entry_Calls.Lock_Server.
105 STPO
.Write_Lock
(Self_ID
);
106 Old_Base_Priority
:= Self_ID
.Common
.Base_Priority
;
107 Self_ID
.New_Base_Priority
:= Object
.Ceiling
;
108 Initialization
.Change_Base_Priority
(Self_ID
);
109 STPO
.Unlock
(Self_ID
);
115 STPO
.Write_Lock
(Object
.L
'Unrestricted_Access, Ceiling_Violation
);
117 if Ceiling_Violation
then
118 Raise_Exception
(Program_Error
'Identity, "Ceiling Violation");
125 Object
.Old_Base_Priority
:= Old_Base_Priority
;
126 Object
.Pending_Action
:= True;
129 -- Send program_error to all tasks still queued on this object.
131 for E
in Object
.Entry_Queues
'Range loop
132 Entry_Call
:= Object
.Entry_Queues
(E
).Head
;
134 while Entry_Call
/= null loop
135 Caller
:= Entry_Call
.Self
;
136 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
138 STPO
.Write_Lock
(Caller
);
139 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
140 STPO
.Unlock
(Caller
);
142 exit when Entry_Call
= Object
.Entry_Queues
(E
).Tail
;
143 Entry_Call
:= Entry_Call
.Next
;
147 Object
.Finalized
:= True;
153 STPO
.Unlock
(Object
.L
'Unrestricted_Access);
155 STPO
.Finalize_Lock
(Object
.L
'Unrestricted_Access);
158 -------------------------------------
159 -- Has_Interrupt_Or_Attach_Handler --
160 -------------------------------------
162 function Has_Interrupt_Or_Attach_Handler
163 (Object
: Protection_Entries_Access
)
166 pragma Warnings
(Off
, Object
);
169 end Has_Interrupt_Or_Attach_Handler
;
171 -----------------------------------
172 -- Initialize_Protection_Entries --
173 -----------------------------------
175 procedure Initialize_Protection_Entries
176 (Object
: Protection_Entries_Access
;
177 Ceiling_Priority
: Integer;
178 Compiler_Info
: System
.Address
;
179 Entry_Bodies
: Protected_Entry_Body_Access
;
180 Find_Body_Index
: Find_Body_Index_Access
)
182 Init_Priority
: Integer := Ceiling_Priority
;
183 Self_ID
: constant Task_ID
:= STPO
.Self
;
186 if Init_Priority
= Unspecified_Priority
then
187 Init_Priority
:= System
.Priority
'Last;
190 if Locking_Policy
= 'C'
191 and then Has_Interrupt_Or_Attach_Handler
(Object
)
192 and then Init_Priority
not in System
.Interrupt_Priority
194 -- Required by C.3.1(11)
199 Initialization
.Defer_Abort
(Self_ID
);
200 Initialize_Lock
(Init_Priority
, Object
.L
'Access);
201 Initialization
.Undefer_Abort
(Self_ID
);
202 Object
.Ceiling
:= System
.Any_Priority
(Init_Priority
);
203 Object
.Compiler_Info
:= Compiler_Info
;
204 Object
.Pending_Action
:= False;
205 Object
.Call_In_Progress
:= null;
206 Object
.Entry_Bodies
:= Entry_Bodies
;
207 Object
.Find_Body_Index
:= Find_Body_Index
;
209 for E
in Object
.Entry_Queues
'Range loop
210 Object
.Entry_Queues
(E
).Head
:= null;
211 Object
.Entry_Queues
(E
).Tail
:= null;
213 end Initialize_Protection_Entries
;
219 procedure Lock_Entries
220 (Object
: Protection_Entries_Access
; Ceiling_Violation
: out Boolean) is
222 if Object
.Finalized
then
224 (Program_Error
'Identity, "Protected Object is finalized");
227 -- The lock is made without defering abortion.
229 -- Therefore the abortion has to be deferred before calling this
230 -- routine. This means that the compiler has to generate a Defer_Abort
231 -- call before the call to Lock.
233 -- The caller is responsible for undeferring abortion, and compiler
234 -- generated calls must be protected with cleanup handlers to ensure
235 -- that abortion is undeferred in all cases.
237 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
238 Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
241 procedure Lock_Entries
(Object
: Protection_Entries_Access
) is
242 Ceiling_Violation
: Boolean;
244 if Object
.Finalized
then
246 (Program_Error
'Identity, "Protected Object is finalized");
249 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
250 Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
252 if Ceiling_Violation
then
253 Raise_Exception
(Program_Error
'Identity, "Ceiling Violation");
257 ----------------------------
258 -- Lock_Read_Only_Entries --
259 ----------------------------
261 procedure Lock_Read_Only_Entries
(Object
: Protection_Entries_Access
) is
262 Ceiling_Violation
: Boolean;
264 if Object
.Finalized
then
266 (Program_Error
'Identity, "Protected Object is finalized");
269 Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
271 if Ceiling_Violation
then
272 Raise_Exception
(Program_Error
'Identity, "Ceiling Violation");
274 end Lock_Read_Only_Entries
;
280 procedure Unlock_Entries
(Object
: Protection_Entries_Access
) is
282 Unlock
(Object
.L
'Access);
285 end System
.Tasking
.Protected_Objects
.Entries
;