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