------------------------------------------------------------------------------ -- -- -- 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-1999 Florida State University (FSU). All Rights -- -- Reserved. -- -- -- -- 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. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ -- [$Revision: 1.9 $] with Ada.Exceptions, POSIX.C, # if HAVE_Safe_Errno then # else POSIX.Error_Codes, # end if; System.Interrupt_Management, System.Interrupt_Management.Operations, GNAT.Task_Lock, System.Soft_Links, Unchecked_Conversion; 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 # 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) is begin -- .... see note on critical sections above if not Condition then Raise_POSIX_Error (Error); end if; end Check; procedure Check (Result : int) is begin -- .... see note on critical sections above if Result = -1 then Raise_POSIX_Error (Fetch_Errno); end if; end Check; function Check (Result : int) return int is begin -- .... see note on critical sections above if Result = -1 then 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 : in char_ptr) return size_t; pragma Import (C, strlen, "strlen"); function Form_String (Str : in 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; function char_ptr_to_pssptr is new Unchecked_Conversion (char_ptr, Substring_Ptr); 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 String_Ptr is access all String; function sptr_to_psptr is new Unchecked_Conversion (String_Ptr, 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) := sptr_to_psptr (From'Unrestricted_Access).all; To (L + 1) := NUL; end Nulterminate; ----------------------- -- Not_Implemented -- ----------------------- procedure sys_exit (status : int); pragma Import (C, sys_exit, "_exit"); 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. -- ...Fix POSIX.5b???? -- It seems we are deviating here from what the standard says, but for -- very good reasons. procedure Mask_Signals (Masking : in Signal_Masking; Old_Mask : access Signal_Mask) 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 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 : in Signal_Masking; Old_Mask : access Signal_Mask) 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 : access Signal_Mask) 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 : access Signal_Mask) 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 : access Signal_Mask) 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; ------------------------- -- Current Process ID -- ------------------------- #if HAVE_Leroy_Threads then function getpid return pid_t; pragma Import (C, getpid, getpid_LINKNAME); begin This_Process := getpid; #end if; end POSIX.Implementation;