1------------------------------------------------------------------------------
2--                                                                          --
3--            FLORIST (FSU Implementation of POSIX.5) COMPONENTS            --
4--                                                                          --
5--                         P O S I X . M U T E X E S                        --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--                                                                          --
10--             Copyright (C) 1996-1997 Florida State University             --
11--                    Copyright (C) 1998-2007, AdaCore                      --
12--                                                                          --
13--  This file is a component of FLORIST, an  implementation of an  Ada API  --
14--  for the POSIX OS services, for use with  the  GNAT  Ada  compiler  and  --
15--  the FSU Gnu Ada Runtime Library (GNARL).   The  interface  is intended  --
16--  to be close to that specified in  IEEE STD  1003.5: 1990  and IEEE STD  --
17--  1003.5b: 1996.                                                          --
18--                                                                          --
19--  FLORIST is free software;  you can  redistribute  it and/or  modify it  --
20--  under terms of the  GNU  General  Public  License as  published by the  --
21--  Free Software Foundation;  either version  2, or (at  your option) any  --
22--  later version.  FLORIST is distributed  in  the hope  that  it will be  --
23--  useful, but WITHOUT ANY WARRANTY;  without  even the implied  warranty  --
24--  of MERCHANTABILITY or FITNESS FOR A PARTICULAR  PURPOSE.  See  the GNU  --
25--  General Public License for more details.  You  should have  received a  --
26--  copy of the GNU General Public License  distributed  with  GNARL;  see  --
27--  file  COPYING.  If not,  write to  the  Free  Software  Foundation, 59  --
28--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.                   --
29--                                                                          --
30--                                                                          --
31--                                                                          --
32--                                                                          --
33--                                                                          --
34--                                                                          --
35--                                                                          --
36--                                                                          --
37------------------------------------------------------------------------------
38
39with POSIX.Implementation;
40
41package body POSIX.Mutexes is
42
43   use POSIX.C;
44   use POSIX.Implementation;
45
46   type Mutexattr_Descriptor is access constant pthread_mutexattr_t;
47
48   ------------------
49   --  Initialize  --
50   ------------------
51
52   function pthread_mutexattr_init
53     (attr : access pthread_mutexattr_t) return int;
54   pragma Import (C, pthread_mutexattr_init,
55     pthread_mutexattr_init_LINKNAME);
56
57   procedure Initialize (Attr : in out Attributes) is
58   begin
59      Check_NZ (pthread_mutexattr_init (Attr.Attr'Unchecked_Access));
60   end Initialize;
61
62   ----------------
63   --  Finalize  --
64   ----------------
65
66   function pthread_mutexattr_destroy
67     (attr : access pthread_mutexattr_t) return int;
68   pragma Import (C, pthread_mutexattr_destroy,
69     pthread_mutexattr_destroy_LINKNAME);
70
71   procedure Finalize (Attr : in out Attributes) is
72   begin
73      Check_NZ (pthread_mutexattr_destroy (Attr.Attr'Unchecked_Access));
74   end Finalize;
75
76   --------------------------
77   --  Get_Process_Shared  --
78   --------------------------
79
80   function pthread_mutexattr_getpshared
81     (attr : Mutexattr_Descriptor;
82      pshared : access int) return int;
83   pragma Import (C, pthread_mutexattr_getpshared,
84     pthread_mutexattr_getpshared_LINKNAME);
85
86   function Get_Process_Shared (Attr : Attributes)
87      return Boolean is
88      Result : aliased int;
89   begin
90      Check_NZ (pthread_mutexattr_getpshared
91        (Attr.Attr'Unchecked_Access, Result'Unchecked_Access));
92      return Result = PTHREAD_PROCESS_SHARED;
93   end Get_Process_Shared;
94
95   --------------------------
96   --  Set_Process_Shared  --
97   --------------------------
98
99   function pthread_mutexattr_setpshared
100     (attr : access pthread_mutexattr_t;
101      pshared : int) return int;
102   pragma Import (C, pthread_mutexattr_setpshared,
103     pthread_mutexattr_setpshared_LINKNAME);
104
105   To_pshared : constant array (Boolean) of int :=
106     (True => PTHREAD_PROCESS_SHARED,
107      False => PTHREAD_PROCESS_PRIVATE);
108
109   procedure Set_Process_Shared
110     (Attr : in out Attributes;
111      Is_Shared : Boolean := False) is
112   begin
113      Check_NZ (pthread_mutexattr_setpshared
114        (Attr.Attr'Unchecked_Access, To_pshared (Is_Shared)));
115   end Set_Process_Shared;
116
117   --------------------------
118   --  Set_Locking_Policy  --
119   --------------------------
120
121   function pthread_mutexattr_setprotocol
122     (attr : access pthread_mutexattr_t;
123      protocol : int) return int;
124   pragma Import (C, pthread_mutexattr_setprotocol,
125     pthread_mutexattr_setprotocol_LINKNAME);
126
127   To_C_Policy : constant array (Locking_Policy) of int :=
128     (No_Priority_Inheritance => PTHREAD_PRIO_NONE,
129      Highest_Blocked_Task => PTHREAD_PRIO_INHERIT,
130      Highest_Ceiling_Priority => PTHREAD_PRIO_PROTECT);
131
132   procedure Set_Locking_Policy
133      (Attr : in out Attributes;
134       Locking : Locking_Policy) is
135   begin
136      Check_NZ (pthread_mutexattr_setprotocol
137        (Attr.Attr'Unchecked_Access, To_C_Policy (Locking)));
138   end Set_Locking_Policy;
139
140   --------------------------
141   --  Get_Locking_Policy  --
142   --------------------------
143
144   function pthread_mutexattr_getprotocol
145     (attr : Mutexattr_Descriptor;
146      value_ptr : access int) return int;
147   pragma Import (C, pthread_mutexattr_getprotocol,
148     pthread_mutexattr_getprotocol_LINKNAME);
149
150   function Get_Locking_Policy (Attr : Attributes) return Locking_Policy is
151      Result : aliased int;
152   begin
153      Check_NZ (pthread_mutexattr_getprotocol
154       (Attr.Attr'Unchecked_Access, Result'Unchecked_Access));
155      if Result = PTHREAD_PRIO_NONE then
156         return No_Priority_Inheritance;
157      elsif Result = PTHREAD_PRIO_INHERIT then
158         return Highest_Blocked_Task;
159      elsif Result = PTHREAD_PRIO_PROTECT then
160         return Highest_Ceiling_Priority;
161      else
162         Raise_POSIX_Error (Operation_Not_Supported);
163         --  to suppress compiler warning
164         return No_Priority_Inheritance;
165      end if;
166   end Get_Locking_Policy;
167
168   ----------------------------
169   --  Set_Ceiling_Priority  --
170   ----------------------------
171
172   function pthread_mutexattr_setprioceiling
173     (attr : access pthread_mutexattr_t;
174      prioceiling : int) return int;
175   pragma Import (C, pthread_mutexattr_setprioceiling,
176     pthread_mutexattr_setprioceiling_LINKNAME);
177
178   procedure Set_Ceiling_Priority
179      (Attr : in out Attributes;
180       New_Ceiling : Ceiling_Priority) is
181   begin
182      Check_NZ (pthread_mutexattr_setprioceiling
183        (Attr.Attr'Unchecked_Access, int (New_Ceiling)));
184   end Set_Ceiling_Priority;
185
186   ----------------------------
187   --  Get_Ceiling_Priority  --
188   ----------------------------
189
190   function pthread_mutexattr_getprioceiling
191     (attr : Mutexattr_Descriptor;
192      prioceiling : access int) return int;
193      pragma Import (C, pthread_mutexattr_getprioceiling,
194        pthread_mutexattr_getprioceiling_LINKNAME);
195
196   function Get_Ceiling_Priority (Attr : Attributes) return Ceiling_Priority is
197      Result : aliased int;
198   begin
199      Check_NZ (pthread_mutexattr_getprioceiling
200        (Attr.Attr'Unchecked_Access, Result'Unchecked_Access));
201      return (Ceiling_Priority (Result));
202   end Get_Ceiling_Priority;
203
204   ------------------
205   --  Initialize  --
206   ------------------
207
208   function pthread_mutex_init
209     (mutex : access pthread_mutex_t;
210      attr  : Mutexattr_Descriptor) return int;
211   pragma Import (C, pthread_mutex_init, pthread_mutex_init_LINKNAME);
212
213   procedure Initialize
214     (M : in out Mutex;
215      Attr : Attributes) is
216   begin
217      Check_NZ (pthread_mutex_init
218        (M.Mutex'Unchecked_Access, Attr.Attr'Unchecked_Access));
219   end Initialize;
220
221   procedure Initialize (M : in out Mutex) is
222   begin
223      Check_NZ (pthread_mutex_init (M.Mutex'Unchecked_Access, null));
224   end Initialize;
225
226   ---------------------
227   --  Descriptor_Of  --
228   ---------------------
229
230   function Descriptor_Of (M : Mutex) return Mutex_Descriptor is
231   begin
232      return M.Mutex'Unchecked_Access;
233   end Descriptor_Of;
234
235   ----------------
236   --  Finalize  --
237   ----------------
238
239   function pthread_mutex_destroy
240     (mutex : access pthread_mutex_t) return int;
241   pragma Import (C, pthread_mutex_destroy,
242     pthread_mutex_destroy_LINKNAME);
243
244   procedure Finalize (M : in out Mutex) is
245   begin
246      Check_NZ (pthread_mutex_destroy (M.Mutex'Unchecked_Access));
247   end Finalize;
248
249   ----------------------------
250   --  Set_Ceiling_Priority  --
251   ----------------------------
252
253   type int_ptr is access all int;
254   function pthread_mutex_setprioceiling
255     (mutex : Mutex_Descriptor;
256      prioceiling : int;
257      old_ceiling : int_ptr) return int;
258   pragma Import (C, pthread_mutex_setprioceiling,
259     pthread_mutex_setprioceiling_LINKNAME);
260
261   procedure Set_Ceiling_Priority
262     (M           : Mutex_Descriptor;
263      New_Ceiling : Ceiling_Priority;
264      Old_Ceiling : out Ceiling_Priority) is
265      Result : aliased int;
266   begin
267      Check_NZ (pthread_mutex_setprioceiling
268        (M, int (New_Ceiling), Result'Unchecked_Access));
269      Old_Ceiling := Ceiling_Priority (Result);
270   end Set_Ceiling_Priority;
271
272   ----------------------------
273   --  Get_Ceiling_Priority  --
274   ----------------------------
275
276   function pthread_mutex_getprioceiling
277     (mutex : Mutex_Descriptor;
278      prioceiling : access int) return int;
279   pragma Import (C, pthread_mutex_getprioceiling,
280     pthread_mutex_getprioceiling_LINKNAME);
281
282   function Get_Ceiling_Priority (M : Mutex_Descriptor)
283      return Ceiling_Priority is
284      Result : aliased int;
285   begin
286      Check_NZ (pthread_mutex_getprioceiling (M, Result'Unchecked_Access));
287      return Ceiling_Priority (Result);
288   end Get_Ceiling_Priority;
289
290   ------------
291   --  Lock  --
292   ------------
293
294   function pthread_mutex_lock
295     (mutex : Mutex_Descriptor) return int;
296   pragma Import (C, pthread_mutex_lock, pthread_mutex_lock_LINKNAME);
297
298   procedure Lock (M : Mutex_Descriptor) is
299   begin
300      Check_NZ (pthread_mutex_lock (M));
301   end Lock;
302
303   ----------------
304   --  Try_Lock  --
305   ----------------
306
307   function pthread_mutex_trylock
308     (mutex : Mutex_Descriptor) return int;
309   pragma Import (C, pthread_mutex_trylock, pthread_mutex_trylock_LINKNAME);
310
311   function Try_Lock (M : Mutex_Descriptor) return Boolean is
312      Result : constant int := pthread_mutex_trylock (M);
313      --  Note: pthread_mutex_trylock returns an error code in Result, and
314      --  does not set errno.
315
316   begin
317      case Result is
318         when 0 =>
319            return True;
320
321         when EBUSY =>
322            return False;
323
324         when others =>
325            Raise_POSIX_Error (Error_Code (Result));
326      end case;
327   end Try_Lock;
328
329   --------------
330   --  Unlock  --
331   --------------
332
333   function pthread_mutex_unlock
334     (mutex : Mutex_Descriptor) return int;
335   pragma Import (C, pthread_mutex_unlock,
336     pthread_mutex_unlock_LINKNAME);
337
338   procedure Unlock (M : Mutex_Descriptor) is
339   begin
340      Check_NZ (pthread_mutex_unlock (M));
341   end Unlock;
342
343end POSIX.Mutexes;
344