File : posix-mutexes.adb


------------------------------------------------------------------------------
--                                                                          --
--            FLORIST (FSU Implementation of POSIX.5) COMPONENTS            --
--                                                                          --
--                         P O S I X . M U T E X E S                        --
--                                                                          --
--                                  B o d y                                 --
--                                                                          --
--                                                                          --
--  Copyright (c) 1996, 1997            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.2 $]

with POSIX.C,
     POSIX.Implementation,
     POSIX.Mutexes;
package body POSIX.Mutexes is

   use POSIX.C;
   use POSIX.Implementation;

   type Mutexattr_Descriptor is access constant pthread_mutexattr_t;

   ------------------
   --  Initialize  --
   ------------------

   function pthread_mutexattr_init
     (attr : access pthread_mutexattr_t) return int;
   pragma Import (C, pthread_mutexattr_init,
     pthread_mutexattr_init_LINKNAME);

   procedure Initialize (Attr : in out Attributes) is
   begin
      Check_NZ (pthread_mutexattr_init (Attr.Attr'Unchecked_Access));
   end Initialize;

   ----------------
   --  Finalize  --
   ----------------

   function pthread_mutexattr_destroy
     (attr : access pthread_mutexattr_t) return int;
   pragma Import (C, pthread_mutexattr_destroy,
     pthread_mutexattr_destroy_LINKNAME);

   procedure Finalize (Attr : in out Attributes) is
   begin
      Check_NZ (pthread_mutexattr_destroy (Attr.Attr'Unchecked_Access));
   end Finalize;

   --------------------------
   --  Get_Process_Shared  --
   --------------------------

   function pthread_mutexattr_getpshared
     (attr : Mutexattr_Descriptor;
      pshared : access int) return int;
   pragma Import (C, pthread_mutexattr_getpshared,
     pthread_mutexattr_getpshared_LINKNAME);

   function Get_Process_Shared (Attr : Attributes)
      return Boolean is
      Result : aliased int;
   begin
      Check_NZ (pthread_mutexattr_getpshared
        (Attr.Attr'Unchecked_Access, Result'Unchecked_Access));
      return Result = PTHREAD_PROCESS_SHARED;
   end Get_Process_Shared;

   --------------------------
   --  Set_Process_Shared  --
   --------------------------

   function pthread_mutexattr_setpshared
     (attr : access pthread_mutexattr_t;
      pshared : int) return int;
   pragma Import (C, pthread_mutexattr_setpshared,
     pthread_mutexattr_setpshared_LINKNAME);

   To_pshared : constant array (Boolean) of int :=
     (True => PTHREAD_PROCESS_SHARED,
      False => PTHREAD_PROCESS_PRIVATE);

   procedure Set_Process_Shared
     (Attr : in out Attributes;
      Is_Shared : in Boolean := False) is
   begin
      Check_NZ (pthread_mutexattr_setpshared
        (Attr.Attr'Unchecked_Access, To_pshared (Is_Shared)));
   end Set_Process_Shared;

   --------------------------
   --  Set_Locking_Policy  --
   --------------------------

   function pthread_mutexattr_setprotocol
     (attr : access pthread_mutexattr_t;
      protocol : int) return int;
   pragma Import (C, pthread_mutexattr_setprotocol,
     pthread_mutexattr_setprotocol_LINKNAME);

   To_C_Policy : constant array (Locking_Policy) of int :=
     (No_Priority_Inheritance => PTHREAD_PRIO_NONE,
      Highest_Blocked_Task => PTHREAD_PRIO_INHERIT,
      Highest_Ceiling_Priority => PTHREAD_PRIO_PROTECT);

   procedure Set_Locking_Policy
      (Attr : in out Attributes;
       Locking : in Locking_Policy) is
   begin
      Check_NZ (pthread_mutexattr_setprotocol
        (Attr.Attr'Unchecked_Access, To_C_Policy (Locking)));
   end Set_Locking_Policy;

   --------------------------
   --  Get_Locking_Policy  --
   --------------------------

   function pthread_mutexattr_getprotocol
     (attr : Mutexattr_Descriptor;
      value_ptr : access int) return int;
   pragma Import (C, pthread_mutexattr_getprotocol,
     pthread_mutexattr_getprotocol_LINKNAME);

   function Get_Locking_Policy (Attr : Attributes) return Locking_Policy is
      Result : aliased int;
   begin
      Check_NZ (pthread_mutexattr_getprotocol
       (Attr.Attr'Unchecked_Access, Result'Unchecked_Access));
      if Result = PTHREAD_PRIO_NONE then return No_Priority_Inheritance;
      elsif Result = PTHREAD_PRIO_INHERIT then return Highest_Blocked_Task;
      elsif Result = PTHREAD_PRIO_PROTECT then return Highest_Ceiling_Priority;
      else Raise_POSIX_Error (Operation_Not_Supported);
         --  to suppress compiler warning
         return No_Priority_Inheritance;
      end if;
   end Get_Locking_Policy;

   ----------------------------
   --  Set_Ceiling_Priority  --
   ----------------------------

   function pthread_mutexattr_setprioceiling
     (attr : access pthread_mutexattr_t;
      prioceiling : int) return int;
   pragma Import (C, pthread_mutexattr_setprioceiling,
     pthread_mutexattr_setprioceiling_LINKNAME);

   procedure Set_Ceiling_Priority
      (Attr : in out Attributes;
       New_Ceiling : in Ceiling_Priority) is
   begin
      Check_NZ (pthread_mutexattr_setprioceiling
        (Attr.Attr'Unchecked_Access, int (New_Ceiling)));
   end Set_Ceiling_Priority;

   ----------------------------
   --  Get_Ceiling_Priority  --
   ----------------------------

   function pthread_mutexattr_getprioceiling
     (attr : Mutexattr_Descriptor;
      prioceiling : access int) return int;
      pragma Import (C, pthread_mutexattr_getprioceiling,
        pthread_mutexattr_getprioceiling_LINKNAME);

   function Get_Ceiling_Priority (Attr : Attributes) return Ceiling_Priority is
      Result : aliased int;
   begin
      Check_NZ (pthread_mutexattr_getprioceiling
        (Attr.Attr'Unchecked_Access, Result'Unchecked_Access));
      return (Ceiling_Priority (Result));
   end Get_Ceiling_Priority;

   ------------------
   --  Initialize  --
   ------------------

   function pthread_mutex_init
     (mutex : access pthread_mutex_t;
      attr  : Mutexattr_Descriptor) return int;
   pragma Import (C, pthread_mutex_init, pthread_mutex_init_LINKNAME);

   procedure Initialize
     (M : in out Mutex;
      Attr : in Attributes) is
   begin
      Check_NZ (pthread_mutex_init
        (M.Mutex'Unchecked_Access, Attr.Attr'Unchecked_Access));
   end Initialize;

   procedure Initialize (M : in out Mutex) is
   begin
      Check_NZ (pthread_mutex_init (M.Mutex'Unchecked_Access, null));
   end Initialize;

   ---------------------
   --  Descriptor_Of  --
   ---------------------

   function Descriptor_Of (M : Mutex) return Mutex_Descriptor is
   begin
      return M.Mutex'Unchecked_Access;
   end Descriptor_Of;

   ----------------
   --  Finalize  --
   ----------------

   function pthread_mutex_destroy
     (mutex : access pthread_mutex_t) return int;
   pragma Import (C, pthread_mutex_destroy,
     pthread_mutex_destroy_LINKNAME);

   procedure Finalize (M : in out Mutex) is
   begin
      Check_NZ (pthread_mutex_destroy (M.Mutex'Unchecked_Access));
   end Finalize;

   ----------------------------
   --  Set_Ceiling_Priority  --
   ----------------------------

   type int_ptr is access all int;
   function pthread_mutex_setprioceiling
     (mutex : Mutex_Descriptor;
      prioceiling : int;
      old_ceiling : int_ptr) return int;
   pragma Import (C, pthread_mutex_setprioceiling,
     pthread_mutex_setprioceiling_LINKNAME);

   procedure Set_Ceiling_Priority
     (M           : in Mutex_Descriptor;
      New_Ceiling : in Ceiling_Priority;
      Old_Ceiling : out Ceiling_Priority) is
      Result : aliased int;
   begin
      Check_NZ (pthread_mutex_setprioceiling
        (M, int (New_Ceiling), Result'Unchecked_Access));
      Old_Ceiling := Ceiling_Priority (Result);
   end Set_Ceiling_Priority;

   ----------------------------
   --  Get_Ceiling_Priority  --
   ----------------------------

   function pthread_mutex_getprioceiling
     (mutex : Mutex_Descriptor;
      prioceiling : access int) return int;
   pragma Import (C, pthread_mutex_getprioceiling,
     pthread_mutex_getprioceiling_LINKNAME);

   function Get_Ceiling_Priority (M : Mutex_Descriptor)
      return Ceiling_Priority is
      Result : aliased int;
   begin
      Check_NZ (pthread_mutex_getprioceiling (M, Result'Unchecked_Access));
      return Ceiling_Priority (Result);
   end Get_Ceiling_Priority;

   ------------
   --  Lock  --
   ------------

   function pthread_mutex_lock
     (mutex : Mutex_Descriptor) return int;
   pragma Import (C, pthread_mutex_lock, pthread_mutex_lock_LINKNAME);

   procedure Lock (M : in Mutex_Descriptor) is
   begin
      Check_NZ (pthread_mutex_lock (M));
   end Lock;

   ----------------
   --  Try_Lock  --
   ----------------

   function pthread_mutex_trylock
     (mutex : Mutex_Descriptor) return int;
   pragma Import (C, pthread_mutex_trylock, pthread_mutex_trylock_LINKNAME);

   function Try_Lock (M : Mutex_Descriptor) return Boolean is
      Result : int;
   begin
      Result := pthread_mutex_trylock (M);
      if Result = 0 then return True;
      elsif Fetch_Errno = EBUSY then return False;
      else Raise_POSIX_Error;
         --  return statement to suppress compiler warning message
         return False;
      end if;
   end Try_Lock;

   --------------
   --  Unlock  --
   --------------

   function pthread_mutex_unlock
     (mutex : Mutex_Descriptor) return int;
   pragma Import (C, pthread_mutex_unlock,
     pthread_mutex_unlock_LINKNAME);

   procedure Unlock (M : in Mutex_Descriptor) is
   begin
      Check_NZ (pthread_mutex_unlock (M));
   end Unlock;

end POSIX.Mutexes;