gcc/ada/7sosinte.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --                   S Y S T E M . O S _ I N T E R F A C E                  --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                                                                          --
  10 --            Copyright (C) 1997-2001 Florida State University              --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  32 -- State University (http://www.gnat.com).                                  --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This is a FSU Threads version of this package
  37
  38 pragma Polling (Off);
  39 --  Turn off polling, we do not want ATC polling to take place during
  40 --  tasking operations. It causes infinite loops and other problems.
  41
  42 with Interfaces.C;
  43
  44 package body System.OS_Interface is
  45
  46    use Interfaces.C;
  47
  48    -----------------
  49    -- To_Duration --
  50    -----------------
  51
  52    function To_Duration (TS : timespec) return Duration is
  53    begin
  54       return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
  55    end To_Duration;
  56
  57    function To_Duration (TV : struct_timeval) return Duration is
  58    begin
  59       return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
  60    end To_Duration;
  61
  62    -----------------
  63    -- To_Timespec --
  64    -----------------
  65
  66    function To_Timespec (D : Duration) return timespec is
  67       S : time_t;
  68       F : Duration;
  69
  70    begin
  71       S := time_t (Long_Long_Integer (D));
  72       F := D - Duration (S);
  73
  74       --  If F has negative value due to a round-up, adjust for positive F
  75       --  value.
  76
  77       if F < 0.0 then
  78          S := S - 1;
  79          F := F + 1.0;
  80       end if;
  81
  82       return timespec' (tv_sec => S,
  83         tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
  84    end To_Timespec;
  85
  86    ----------------
  87    -- To_Timeval --
  88    ----------------
  89
  90    function To_Timeval (D : Duration) return struct_timeval is
  91       S : long;
  92       F : Duration;
  93
  94    begin
  95       S := long (Long_Long_Integer (D));
  96       F := D - Duration (S);
  97
  98       --  If F has negative value due to a round-up, adjust for positive F
  99       --  value.
 100
 101       if F < 0.0 then
 102          S := S - 1;
 103          F := F + 1.0;
 104       end if;
 105
 106       return struct_timeval' (tv_sec => S,
 107         tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
 108    end To_Timeval;
 109
 110    -------------
 111    -- sigwait --
 112    -------------
 113
 114    --  FSU_THREADS has a nonstandard sigwait
 115
 116    function sigwait
 117      (set  : access sigset_t;
 118       sig  : access Signal) return int
 119    is
 120       Result : int;
 121
 122       function sigwait_base (set : access sigset_t) return int;
 123       pragma Import (C, sigwait_base, "sigwait");
 124
 125    begin
 126       Result := sigwait_base (set);
 127
 128       if Result = -1 then
 129          sig.all := 0;
 130          return errno;
 131       end if;
 132
 133       sig.all := Signal (Result);
 134       return 0;
 135    end sigwait;
 136
 137    ------------------------
 138    -- pthread_mutex_lock --
 139    ------------------------
 140
 141    --  FSU_THREADS has nonstandard pthread_mutex_lock and unlock.
 142    --  It sets errno but the standard Posix requires it to be returned.
 143
 144    function pthread_mutex_lock (mutex : access pthread_mutex_t) return int is
 145       function pthread_mutex_lock_base
 146         (mutex : access pthread_mutex_t) return int;
 147       pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
 148
 149       Result : int;
 150
 151    begin
 152       Result := pthread_mutex_lock_base (mutex);
 153
 154       if Result /= 0 then
 155          return errno;
 156       end if;
 157
 158       return 0;
 159    end pthread_mutex_lock;
 160
 161    --------------------------
 162    -- pthread_mutex_unlock --
 163    --------------------------
 164
 165    function pthread_mutex_unlock
 166      (mutex : access pthread_mutex_t) return int
 167    is
 168       function pthread_mutex_unlock_base
 169         (mutex : access pthread_mutex_t) return int;
 170       pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
 171
 172       Result : int;
 173
 174    begin
 175       Result := pthread_mutex_unlock_base (mutex);
 176
 177       if Result /= 0 then
 178          return errno;
 179       end if;
 180
 181       return 0;
 182    end pthread_mutex_unlock;
 183
 184    -----------------------
 185    -- pthread_cond_wait --
 186    -----------------------
 187
 188    --  FSU_THREADS has a nonstandard pthread_cond_wait.
 189    --  The FSU_THREADS version returns EINTR when interrupted.
 190
 191    function pthread_cond_wait
 192      (cond  : access pthread_cond_t;
 193       mutex : access pthread_mutex_t) return int
 194    is
 195       function pthread_cond_wait_base
 196         (cond  : access pthread_cond_t;
 197          mutex : access pthread_mutex_t) return int;
 198       pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
 199
 200       Result : int;
 201
 202    begin
 203       Result := pthread_cond_wait_base (cond, mutex);
 204
 205       if Result = EINTR then
 206          return 0;
 207       else
 208          return Result;
 209       end if;
 210    end pthread_cond_wait;
 211
 212    ----------------------------
 213    -- pthread_cond_timedwait --
 214    ----------------------------
 215
 216    --  FSU_THREADS has a nonstandard pthread_cond_timedwait. The
 217    --  FSU_THREADS version returns -1 and set errno to EAGAIN for timeout.
 218
 219    function pthread_cond_timedwait
 220      (cond    : access pthread_cond_t;
 221       mutex   : access pthread_mutex_t;
 222       abstime : access timespec) return int
 223    is
 224       function pthread_cond_timedwait_base
 225         (cond    : access pthread_cond_t;
 226          mutex   : access pthread_mutex_t;
 227          abstime : access timespec) return int;
 228       pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
 229
 230       Result : int;
 231
 232    begin
 233       Result := pthread_cond_timedwait_base (cond, mutex, abstime);
 234
 235       if Result = -1 then
 236          if errno = EAGAIN then
 237             return ETIMEDOUT;
 238          else
 239             return EINVAL;
 240          end if;
 241       end if;
 242
 243       return 0;
 244    end pthread_cond_timedwait;
 245
 246    ---------------------------
 247    -- pthread_setschedparam --
 248    ---------------------------
 249
 250    --  FSU_THREADS does not have pthread_setschedparam
 251
 252    --  This routine returns a non-negative value upon failure
 253    --  but the error code can not be set conforming the POSIX standard.
 254
 255    function pthread_setschedparam
 256      (thread : pthread_t;
 257       policy : int;
 258       param  : access struct_sched_param) return int
 259    is
 260       function pthread_setschedattr
 261         (thread : pthread_t;
 262          attr   : pthread_attr_t) return int;
 263       pragma Import (C, pthread_setschedattr, "pthread_setschedattr");
 264
 265       attr   : aliased pthread_attr_t;
 266       Result : int;
 267
 268    begin
 269       Result := pthread_attr_init (attr'Access);
 270
 271       if Result /= 0 then
 272          return Result;
 273       end if;
 274
 275       attr.sched := policy;
 276
 277       --  Short-cut around pthread_attr_setprio
 278
 279       attr.prio := param.sched_priority;
 280
 281       Result := pthread_setschedattr (thread, attr);
 282
 283       if Result /= 0 then
 284          return Result;
 285       end if;
 286
 287       Result := pthread_attr_destroy (attr'Access);
 288
 289       if Result /= 0 then
 290          return Result;
 291       else
 292          return 0;
 293       end if;
 294    end pthread_setschedparam;
 295
 296    -------------------------
 297    -- pthread_getspecific --
 298    -------------------------
 299
 300    --  FSU_THREADS has a nonstandard pthread_getspecific
 301
 302    function pthread_getspecific (key : pthread_key_t) return System.Address is
 303       function pthread_getspecific_base
 304         (key   : pthread_key_t;
 305          value : access System.Address) return int;
 306       pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
 307
 308       Tmp    : aliased System.Address;
 309       Result : int;
 310
 311    begin
 312       Result := pthread_getspecific_base (key, Tmp'Access);
 313
 314       if Result /= 0 then
 315          return System.Null_Address;
 316       end if;
 317
 318       return Tmp;
 319    end pthread_getspecific;
 320
 321    ---------------------------------
 322    -- pthread_attr_setdetachstate --
 323    ---------------------------------
 324
 325    function pthread_attr_setdetachstate
 326      (attr        : access pthread_attr_t;
 327       detachstate : int) return int
 328    is
 329       function pthread_attr_setdetachstate_base
 330         (attr        : access pthread_attr_t;
 331          detachstate : access int) return int;
 332       pragma Import
 333         (C, pthread_attr_setdetachstate_base, "pthread_attr_setdetachstate");
 334
 335       Tmp : aliased int := detachstate;
 336
 337    begin
 338       return pthread_attr_setdetachstate_base (attr, Tmp'Access);
 339    end pthread_attr_setdetachstate;
 340
 341    -----------------
 342    -- sched_yield --
 343    -----------------
 344
 345    --  FSU_THREADS does not have sched_yield;
 346
 347    function sched_yield return int is
 348       procedure sched_yield_base (arg : System.Address);
 349       pragma Import (C, sched_yield_base, "pthread_yield");
 350
 351    begin
 352       sched_yield_base (System.Null_Address);
 353       return 0;
 354    end sched_yield;
 355
 356    ----------------
 357    -- Stack_Base --
 358    ----------------
 359
 360    function Get_Stack_Base (thread : pthread_t) return Address is
 361    begin
 362       return thread.stack_base;
 363    end Get_Stack_Base;
 364
 365 end System.OS_Interface;