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