1pragma Source_Reference (1, "libsrc/posix-implementation.gpb"); 2------------------------------------------------------------------------------ 3-- -- 4-- FLORIST (FSU Implementation of POSIX.5) COMPONENTS -- 5-- -- 6-- P O S I X . I M P L E M E N T A T I O N -- 7-- -- 8-- B o d y -- 9-- -- 10-- -- 11-- Copyright (C) 1996-1997 Florida State University -- 12-- Copyright (C) 1998-2014, AdaCore -- 13-- -- 14-- This file is a component of FLORIST, an implementation of an Ada API -- 15-- for the POSIX OS services, for use with the GNAT Ada compiler and -- 16-- the FSU Gnu Ada Runtime Library (GNARL). The interface is intended -- 17-- to be close to that specified in IEEE STD 1003.5: 1990 and IEEE STD -- 18-- 1003.5b: 1996. -- 19-- -- 20-- FLORIST is free software; you can redistribute it and/or modify it -- 21-- under terms of the GNU General Public License as published by the -- 22-- Free Software Foundation; either version 2, or (at your option) any -- 23-- later version. FLORIST is distributed in the hope that it will be -- 24-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty -- 25-- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- 26-- General Public License for more details. You should have received a -- 27-- copy of the GNU General Public License distributed with GNARL; see -- 28-- file COPYING. If not, write to the Free Software Foundation, 59 -- 29-- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- 30-- -- 31-- -- 32-- -- 33-- -- 34-- -- 35-- -- 36-- -- 37-- -- 38------------------------------------------------------------------------------ 39 40with Ada.Exceptions, 41--! # if HAVE_Safe_Errno then 42--! # else 43--! POSIX.Error_Codes, 44--! # end if; 45 System.Interrupt_Management.Operations, 46 GNAT.Task_Lock, 47 System.Soft_Links; 48 49package body POSIX.Implementation is 50 51 use POSIX.C; 52 53 package SIM renames System.Interrupt_Management; 54 package SIMO renames System.Interrupt_Management.Operations; 55 56--! # if HAVE_Safe_Errno then 57 58 procedure Set_Ada_Error_Code (Error : Error_Code) is 59 begin 60 Store_Errno (Error); 61 end Set_Ada_Error_Code; 62 63 function Get_Ada_Error_Code return Error_Code is 64 begin 65 return Fetch_Errno; 66 end Get_Ada_Error_Code; 67 68--! # else 69--! 70--! procedure Set_Ada_Error_Code (Error : Error_Code) is 71--! begin 72--! POSIX.Error_Codes.Set_Value (Error); 73--! end Set_Ada_Error_Code; 74--! 75--! function Get_Ada_Error_Code return Error_Code is 76--! begin 77--! return POSIX.Error_Codes.Value; 78--! end Get_Ada_Error_Code; 79--! 80--! # end if; 81 82 -- .... It would be nice if we had a way to check whether we 83 -- are in a critical section, at the points (below) where we are 84 -- about to raise an exception. These routines should never be 85 -- called from inside a critical section, but that is an easy 86 -- mistake to make. 87 88 ------------------------------ 89 -- Begin_Critical_Section -- 90 ------------------------------ 91 92 procedure Begin_Critical_Section is 93 begin 94 GNAT.Task_Lock.Lock; 95 end Begin_Critical_Section; 96 97 ---------------------------- 98 -- End_Critical_Section -- 99 ---------------------------- 100 101 procedure End_Critical_Section is 102 begin 103 GNAT.Task_Lock.Unlock; 104 end End_Critical_Section; 105 106 ---------------------- 107 -- Defer_Abortion -- 108 ---------------------- 109 110 procedure Defer_Abortion is 111 begin 112 System.Soft_Links.Abort_Defer.all; 113 end Defer_Abortion; 114 115 ------------------------ 116 -- Undefer_Abortion -- 117 ------------------------ 118 119 procedure Undefer_Abortion is 120 begin 121 System.Soft_Links.Abort_Undefer.all; 122 end Undefer_Abortion; 123 124 ------------------------- 125 -- Raise_POSIX_Error -- 126 ------------------------- 127 128 procedure Raise_POSIX_Error (Error : Error_Code := No_Error) is 129 Tmp : Error_Code := Error; 130 begin 131 -- .... see note on critical sections above 132 if Error = No_Error then 133 Tmp := Fetch_Errno; 134 end if; 135 Set_Ada_Error_Code (Tmp); 136 Ada.Exceptions.Raise_Exception 137 (POSIX_Error'Identity, Image (Tmp)); 138 end Raise_POSIX_Error; 139 140 ------------- 141 -- Check -- 142 ------------- 143 144 procedure Check (Condition : Boolean; 145 Error : Error_Code; 146 Old_Mask : Signal_Mask_Access := null) is 147 begin 148 -- .... see note on critical sections above 149 if not Condition then 150 if Old_Mask /= null then 151 Restore_Signals (Old_Mask); 152 end if; 153 Raise_POSIX_Error (Error); 154 end if; 155 end Check; 156 157 procedure Check (Result : int; Old_Mask : Signal_Mask_Access := null) is 158 begin 159 -- .... see note on critical sections above 160 if Result = -1 then 161 if Old_Mask /= null then 162 Restore_Signals (Old_Mask); 163 end if; 164 Raise_POSIX_Error (Fetch_Errno); 165 end if; 166 end Check; 167 168 function Check (Result : int; Old_Mask : Signal_Mask_Access := null) 169 return int is 170 begin 171 -- .... see note on critical sections above 172 if Result = -1 then 173 if Old_Mask /= null then 174 Restore_Signals (Old_Mask); 175 end if; 176 Raise_POSIX_Error (Fetch_Errno); 177 end if; 178 return Result; 179 end Check; 180 181 -- ....is there a better work-around???? 182 -- Provenzano's threads seem to 183 -- return nonstandard negative values for some calls, 184 -- like "close". 185 186 procedure Check_NNeg (Result : int) is 187 begin 188 -- .... see note on critical sections above 189 if Result < 0 then 190 Raise_POSIX_Error (Fetch_Errno); 191 end if; 192 end Check_NNeg; 193 194 -- ....is there a better work-around???? 195 -- Provenzano's threads seem to 196 -- return nonstandard negative values for some calls, 197 -- like "close". 198 199 function Check_NNeg (Result : int) return int is 200 begin 201 -- .... see note on critical sections above. 202 if Result < 0 then 203 Raise_POSIX_Error (Fetch_Errno); 204 end if; 205 return Result; 206 end Check_NNeg; 207 208 procedure Check_NZ (Result : int) is 209 begin 210 -- .... see note on critical sections above. 211 if Result /= 0 then 212 Raise_POSIX_Error (Error_Code (Result)); 213 end if; 214 end Check_NZ; 215 216 ------------------- 217 -- Form_String -- 218 ------------------- 219 220 function strlen (str : char_ptr) return size_t; 221 pragma Import (C, strlen, "strlen"); 222 223 function Form_String (Str : char_ptr) return String is 224 begin 225 if Str = null then 226 return ""; 227 end if; 228 declare 229 subtype Substring is String (1 .. Integer (strlen (Str))); 230 type Substring_Ptr is access Substring; 231 pragma Warnings (Off); 232 function char_ptr_to_pssptr is new Unchecked_Conversion 233 (char_ptr, Substring_Ptr); 234 pragma Warnings (On); 235 begin 236 return char_ptr_to_pssptr (Str).all; 237 end; 238 end Form_String; 239 240 --------------------------- 241 -- Trim_Leading_Blanks -- 242 --------------------------- 243 244 function Trim_Leading_Blank (S : String) return String is 245 begin 246 if S (S'First) /= ' ' then 247 return S; 248 end if; 249 return S (S'First + 1 .. S'Last); 250 end Trim_Leading_Blank; 251 252 -------------------- 253 -- Nulterminate -- 254 -------------------- 255 256 type Big_POSIX_String_Ptr is access all POSIX_String (Positive'Range); 257 258 function From_Address is new Unchecked_Conversion 259 (System.Address, Big_POSIX_String_Ptr); 260 261 procedure Nulterminate 262 (To : out POSIX_String; 263 From : String) is 264 L : constant Positive := From'Length; 265 begin 266 if To'Length <= L then 267 raise Constraint_Error; 268 end if; 269 To (1 .. L) := From_Address (From'Address) (1 .. L); 270 To (L + 1) := NUL; 271 end Nulterminate; 272 273 ----------------------- 274 -- Not_Implemented -- 275 ----------------------- 276 277 function Not_Implemented_Neg_One return int is 278 begin 279 Store_Errno (ENOSYS); 280 return -1; 281 end Not_Implemented_Neg_One; 282 283 function Not_Implemented_Direct return int is 284 begin 285 return ENOSYS; 286 end Not_Implemented_Direct; 287 288 function Not_Supported_Neg_One return int is 289 begin 290 Store_Errno (ENOTSUP); 291 return -1; 292 end Not_Supported_Neg_One; 293 294 function Not_Supported_Direct return int is 295 begin 296 return ENOTSUP; 297 end Not_Supported_Direct; 298 299 ---------------------- 300 -- Signal Masking -- 301 ---------------------- 302 303 -- For RTS_Signals we mask all the signals identified as reserved 304 -- by the tasking RTS. However, we leave SIGABRT alone since it is being 305 -- used as the signal for abortion which needs to be invoked for 306 -- POSIX.Signals.Interrupt_Task. Do not mask SIGTRAP either because 307 -- this signal is used by the debugger. 308 -- ...Fix POSIX.5b???? 309 -- It seems we are deviating here from what the standard says, but for 310 -- very good reasons. 311 312 procedure Mask_Signals 313 (Masking : Signal_Masking; 314 Old_Mask : Signal_Mask_Access) 315 is 316 use type SIM.Interrupt_ID; 317 begin 318 if Masking /= No_Signals then 319 declare 320 New_Mask : aliased Signal_Mask; 321 begin 322 Begin_Critical_Section; 323 324 SIMO.Get_Interrupt_Mask (New_Mask'Unchecked_Access); 325 SIMO.Copy_Interrupt_Mask (Old_Mask.all, New_Mask); 326 if Masking = RTS_Signals then 327 for J in 1 .. SIM.Interrupt_ID'Last loop 328 if SIM.Reserve (J) and J /= SIGABRT and J /= SIGTRAP then 329 SIMO.Add_To_Interrupt_Mask (New_Mask'Unchecked_Access, J); 330 end if; 331 end loop; 332 else -- All_Signals 333 SIMO.Fill_Interrupt_Mask (New_Mask'Unchecked_Access); 334 end if; 335 SIMO.Set_Interrupt_Mask (New_Mask'Unchecked_Access); 336 End_Critical_Section; 337 end; 338 end if; 339 end Mask_Signals; 340 341 procedure Restore_Signals 342 (Masking : Signal_Masking; 343 Old_Mask : Signal_Mask_Access) is 344 begin 345 if Masking /= No_Signals then 346 Begin_Critical_Section; 347 SIMO.Set_Interrupt_Mask (Old_Mask); 348 End_Critical_Section; 349 end if; 350 end Restore_Signals; 351 352 procedure Restore_Signals 353 (Old_Mask : Signal_Mask_Access) is 354 begin 355 Begin_Critical_Section; 356 SIMO.Set_Interrupt_Mask (Old_Mask); 357 End_Critical_Section; 358 end Restore_Signals; 359 360 ------------------------------------- 361 -- Check_..._And_Restore_Signals -- 362 ------------------------------------- 363 364 procedure Restore_Signals_And_Raise_POSIX_Error 365 (Masked_Signals : Signal_Masking; 366 Old_Mask : Signal_Mask_Access) is 367 Error : constant Error_Code := Fetch_Errno; 368 begin 369 Restore_Signals (Masked_Signals, Old_Mask); 370 Raise_POSIX_Error (Error); 371 end Restore_Signals_And_Raise_POSIX_Error; 372 373 procedure Check_NNeg_And_Restore_Signals 374 (Result : int; 375 Masked_Signals : Signal_Masking; 376 Old_Mask : Signal_Mask_Access) is 377 begin 378 if Result < 0 then 379 Restore_Signals_And_Raise_POSIX_Error 380 (Masked_Signals, Old_Mask); 381 else 382 Restore_Signals (Masked_Signals, Old_Mask); 383 end if; 384 end Check_NNeg_And_Restore_Signals; 385 386 -------------------------- 387 -- To_Struct_Timespec -- 388 -------------------------- 389 390 function To_Struct_Timespec (D : Duration) return struct_timespec is 391 S : time_t; 392 F : Duration; 393 begin 394 S := time_t (Long_Long_Integer (D)); 395 F := D - Duration (S); 396 -- If F has negative value due to a round-up, adjust for positive F 397 -- value. 398 if F < 0.0 then 399 S := S - 1; 400 F := F + 1.0; 401 end if; 402 return struct_timespec'(tv_sec => S, 403 tv_nsec => long (Long_Long_Integer (F * NS_per_S))); 404 end To_Struct_Timespec; 405 406 function To_Struct_Timespec (T : Timespec) return struct_timespec is 407 begin 408 return To_Struct_Timespec (To_Duration (T)); 409 end To_Struct_Timespec; 410 411 ------------------- 412 -- To_Duration -- 413 ------------------- 414 415 function To_Duration (TS : struct_timespec) return Duration is 416 begin 417 return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / NS_per_S; 418 end To_Duration; 419 420 ------------------- 421 -- To_Timespec -- 422 ------------------- 423 424 function To_Timespec (TS : struct_timespec) return Timespec is 425 begin 426 return Timespec' 427 (Val => Duration (TS.tv_sec) + Duration (TS.tv_nsec) / NS_per_S); 428 end To_Timespec; 429 430 ------------------- 431 -- To_Duration -- 432 ------------------- 433 434 function To_Duration (TV : struct_timeval) return Duration is 435 begin 436 return Duration (TV.tv_sec) + Duration (TV.tv_usec) / MS_per_S; 437 end To_Duration; 438 439 ------------------------- 440 -- To_Struct_Timeval -- 441 ------------------------- 442 443 function To_Struct_Timeval (D : Duration) return struct_timeval is 444 S : time_t; 445 F : Duration; 446 begin 447 S := time_t (Long_Long_Integer (D)); 448 F := D - Duration (S); 449 -- If F has negative value due to a round-up, adjust for positive F 450 -- value. 451 if F < 0.0 then 452 S := S - 1; 453 F := F + 1.0; 454 end if; 455 return struct_timeval'(tv_sec => S, 456 tv_usec => suseconds_t (Long_Long_Integer (F * MS_per_S))); 457 end To_Struct_Timeval; 458 459end POSIX.Implementation; 460