File : posix-implementation.adb


pragma Source_Reference (1, "posix-implementation.gpb");
------------------------------------------------------------------------------
--                                                                          --
--            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.6 $]

with Ada.Exceptions,
     POSIX.C,


     POSIX.Error_Codes,


     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;






   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;



   --  .... 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);
            case Masking is
            when No_Signals => null;
            when RTS_Signals =>
               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;
               SIMO.Delete_From_Interrupt_Mask
                 (New_Mask'Unchecked_Access, SIM.Abort_Task_Interrupt);
            when All_Signals =>
               SIMO.Fill_Interrupt_Mask (New_Mask'Unchecked_Access);
            end case;
            SIMO.Get_Interrupt_Mask (Old_Mask);
            SIMO.Set_Interrupt_Mask (New_Mask'Unchecked_Access);
--            SIMO.Set_Interrupt_Mask
--              (New_Mask'Unchecked_Access, Old_Mask);
            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;


   function getpid return pid_t;
   pragma Import (C, getpid, getpid_LINKNAME);

begin
   This_Process := getpid;

end POSIX.Implementation;