gcc/ada/s-osinte-hpux-dce.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT 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 --             Copyright (C) 1991-1994, Florida State University            --
  10 --                     Copyright (C) 1995-2007, AdaCore                     --
  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,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, 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.       --
  31 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is a DCE version of this package.
  36 --  Currently HP-UX and SNI use this file
  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 --  This package encapsulates all direct interfaces to OS services
  43 --  that are needed by children of System.
  44
  45 with Interfaces.C; use Interfaces.C;
  46
  47 package body System.OS_Interface is
  48
  49    -----------------
  50    -- To_Duration --
  51    -----------------
  52
  53    function To_Duration (TS : timespec) return Duration is
  54    begin
  55       return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
  56    end To_Duration;
  57
  58    -----------------
  59    -- To_Timespec --
  60    -----------------
  61
  62    function To_Timespec (D : Duration) return timespec is
  63       S : time_t;
  64       F : Duration;
  65
  66    begin
  67       S := time_t (Long_Long_Integer (D));
  68       F := D - Duration (S);
  69
  70       --  If F has negative value due to a round-up, adjust for positive F
  71       --  value.
  72       if F < 0.0 then
  73          S := S - 1;
  74          F := F + 1.0;
  75       end if;
  76
  77       return timespec'(tv_sec => S,
  78                        tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
  79    end To_Timespec;
  80
  81    function To_Duration (TV : struct_timeval) return Duration is
  82    begin
  83       return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
  84    end To_Duration;
  85
  86    function To_Timeval (D : Duration) return struct_timeval is
  87       S : time_t;
  88       F : Duration;
  89    begin
  90       S := time_t (Long_Long_Integer (D));
  91       F := D - Duration (S);
  92
  93       --  If F has negative value due to a round-up, adjust for positive F
  94       --  value.
  95
  96       if F < 0.0 then
  97          S := S - 1;
  98          F := F + 1.0;
  99       end if;
 100
 101       return
 102         struct_timeval'
 103           (tv_sec => S,
 104            tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
 105    end To_Timeval;
 106
 107    -------------------------
 108    -- POSIX.1c  Section 3 --
 109    -------------------------
 110
 111    function sigwait
 112      (set : access sigset_t;
 113       sig : access Signal) return int
 114    is
 115       Result : int;
 116
 117    begin
 118       Result := sigwait (set);
 119
 120       if Result = -1 then
 121          sig.all := 0;
 122          return errno;
 123       end if;
 124
 125       sig.all := Signal (Result);
 126       return 0;
 127    end sigwait;
 128
 129    --  DCE_THREADS does not have pthread_kill. Instead, we just ignore it
 130
 131    function pthread_kill (thread : pthread_t; sig : Signal) return int is
 132       pragma Unreferenced (thread, sig);
 133    begin
 134       return 0;
 135    end pthread_kill;
 136
 137    --------------------------
 138    -- POSIX.1c  Section 11 --
 139    --------------------------
 140
 141    --  For all following functions, DCE Threads has a non standard behavior.
 142    --  It sets errno but the standard Posix requires it to be returned.
 143
 144    function pthread_mutexattr_init
 145      (attr : access pthread_mutexattr_t) return int
 146    is
 147       function pthread_mutexattr_create
 148         (attr : access pthread_mutexattr_t) return int;
 149       pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
 150
 151    begin
 152       if pthread_mutexattr_create (attr) /= 0 then
 153          return errno;
 154       else
 155          return 0;
 156       end if;
 157    end pthread_mutexattr_init;
 158
 159    function pthread_mutexattr_destroy
 160      (attr : access pthread_mutexattr_t) return int
 161    is
 162       function pthread_mutexattr_delete
 163         (attr : access pthread_mutexattr_t) return int;
 164       pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
 165
 166    begin
 167       if pthread_mutexattr_delete (attr) /= 0 then
 168          return errno;
 169       else
 170          return 0;
 171       end if;
 172    end pthread_mutexattr_destroy;
 173
 174    function pthread_mutex_init
 175      (mutex : access pthread_mutex_t;
 176       attr  : access pthread_mutexattr_t) return int
 177    is
 178       function pthread_mutex_init_base
 179         (mutex : access pthread_mutex_t;
 180          attr  : pthread_mutexattr_t) return int;
 181       pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
 182
 183    begin
 184       if pthread_mutex_init_base (mutex, attr.all) /= 0 then
 185          return errno;
 186       else
 187          return 0;
 188       end if;
 189    end pthread_mutex_init;
 190
 191    function pthread_mutex_destroy
 192      (mutex : access pthread_mutex_t) return int
 193    is
 194       function pthread_mutex_destroy_base
 195         (mutex : access pthread_mutex_t) return int;
 196       pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
 197
 198    begin
 199       if pthread_mutex_destroy_base (mutex) /= 0 then
 200          return errno;
 201       else
 202          return 0;
 203       end if;
 204    end pthread_mutex_destroy;
 205
 206    function pthread_mutex_lock
 207      (mutex : access pthread_mutex_t) return int
 208    is
 209       function pthread_mutex_lock_base
 210         (mutex : access pthread_mutex_t) return int;
 211       pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
 212
 213    begin
 214       if pthread_mutex_lock_base (mutex) /= 0 then
 215          return errno;
 216       else
 217          return 0;
 218       end if;
 219    end pthread_mutex_lock;
 220
 221    function pthread_mutex_unlock
 222      (mutex : access pthread_mutex_t) return int
 223    is
 224       function pthread_mutex_unlock_base
 225         (mutex : access pthread_mutex_t) return int;
 226       pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
 227
 228    begin
 229       if pthread_mutex_unlock_base (mutex) /= 0 then
 230          return errno;
 231       else
 232          return 0;
 233       end if;
 234    end pthread_mutex_unlock;
 235
 236    function pthread_condattr_init
 237      (attr : access pthread_condattr_t) return int
 238    is
 239       function pthread_condattr_create
 240         (attr : access pthread_condattr_t) return int;
 241       pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
 242
 243    begin
 244       if pthread_condattr_create (attr) /= 0 then
 245          return errno;
 246       else
 247          return 0;
 248       end if;
 249    end pthread_condattr_init;
 250
 251    function pthread_condattr_destroy
 252      (attr : access pthread_condattr_t) return int
 253    is
 254       function pthread_condattr_delete
 255         (attr : access pthread_condattr_t) return int;
 256       pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
 257
 258    begin
 259       if pthread_condattr_delete (attr) /= 0 then
 260          return errno;
 261       else
 262          return 0;
 263       end if;
 264    end pthread_condattr_destroy;
 265
 266    function pthread_cond_init
 267      (cond : access pthread_cond_t;
 268       attr : access pthread_condattr_t) return int
 269    is
 270       function pthread_cond_init_base
 271         (cond : access pthread_cond_t;
 272          attr : pthread_condattr_t) return int;
 273       pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
 274
 275    begin
 276       if pthread_cond_init_base (cond, attr.all) /= 0 then
 277          return errno;
 278       else
 279          return 0;
 280       end if;
 281    end pthread_cond_init;
 282
 283    function pthread_cond_destroy
 284      (cond : access pthread_cond_t) return int
 285    is
 286       function pthread_cond_destroy_base
 287         (cond : access pthread_cond_t) return int;
 288       pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
 289
 290    begin
 291       if pthread_cond_destroy_base (cond) /= 0 then
 292          return errno;
 293       else
 294          return 0;
 295       end if;
 296    end pthread_cond_destroy;
 297
 298    function pthread_cond_signal
 299      (cond : access pthread_cond_t) return int
 300    is
 301       function pthread_cond_signal_base
 302         (cond : access pthread_cond_t) return int;
 303       pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
 304
 305    begin
 306       if pthread_cond_signal_base (cond) /= 0 then
 307          return errno;
 308       else
 309          return 0;
 310       end if;
 311    end pthread_cond_signal;
 312
 313    function pthread_cond_wait
 314      (cond  : access pthread_cond_t;
 315       mutex : access pthread_mutex_t) return int
 316    is
 317       function pthread_cond_wait_base
 318         (cond  : access pthread_cond_t;
 319          mutex : access pthread_mutex_t) return int;
 320       pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
 321
 322    begin
 323       if pthread_cond_wait_base (cond, mutex) /= 0 then
 324          return errno;
 325       else
 326          return 0;
 327       end if;
 328    end pthread_cond_wait;
 329
 330    function pthread_cond_timedwait
 331      (cond    : access pthread_cond_t;
 332       mutex   : access pthread_mutex_t;
 333       abstime : access timespec) return int
 334    is
 335       function pthread_cond_timedwait_base
 336         (cond    : access pthread_cond_t;
 337          mutex   : access pthread_mutex_t;
 338          abstime : access timespec) return int;
 339       pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
 340
 341    begin
 342       if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then
 343          if errno = EAGAIN then
 344             return ETIMEDOUT;
 345          else
 346             return errno;
 347          end if;
 348       else
 349          return 0;
 350       end if;
 351    end pthread_cond_timedwait;
 352
 353    ----------------------------
 354    --  POSIX.1c  Section 13  --
 355    ----------------------------
 356
 357    function pthread_setschedparam
 358      (thread : pthread_t;
 359       policy : int;
 360       param  : access struct_sched_param) return int
 361    is
 362       function pthread_setscheduler
 363         (thread   : pthread_t;
 364          policy   : int;
 365          priority : int) return int;
 366       pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
 367
 368    begin
 369       if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
 370          return errno;
 371       else
 372          return 0;
 373       end if;
 374    end pthread_setschedparam;
 375
 376    function sched_yield return int is
 377       procedure pthread_yield;
 378       pragma Import (C, pthread_yield, "pthread_yield");
 379    begin
 380       pthread_yield;
 381       return 0;
 382    end sched_yield;
 383
 384    -----------------------------
 385    --  P1003.1c - Section 16  --
 386    -----------------------------
 387
 388    function pthread_attr_init
 389      (attributes : access pthread_attr_t) return int
 390    is
 391       function pthread_attr_create
 392         (attributes : access pthread_attr_t) return int;
 393       pragma Import (C, pthread_attr_create, "pthread_attr_create");
 394
 395    begin
 396       if pthread_attr_create (attributes) /= 0 then
 397          return errno;
 398       else
 399          return 0;
 400       end if;
 401    end pthread_attr_init;
 402
 403    function pthread_attr_destroy
 404      (attributes : access pthread_attr_t) return int
 405    is
 406       function pthread_attr_delete
 407         (attributes : access pthread_attr_t) return int;
 408       pragma Import (C, pthread_attr_delete, "pthread_attr_delete");
 409
 410    begin
 411       if pthread_attr_delete (attributes) /= 0 then
 412          return errno;
 413       else
 414          return 0;
 415       end if;
 416    end pthread_attr_destroy;
 417
 418    function pthread_attr_setstacksize
 419      (attr      : access pthread_attr_t;
 420       stacksize : size_t) return int
 421    is
 422       function pthread_attr_setstacksize_base
 423         (attr      : access pthread_attr_t;
 424          stacksize : size_t) return int;
 425       pragma Import (C, pthread_attr_setstacksize_base,
 426                      "pthread_attr_setstacksize");
 427
 428    begin
 429       if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then
 430          return errno;
 431       else
 432          return 0;
 433       end if;
 434    end pthread_attr_setstacksize;
 435
 436    function pthread_create
 437      (thread        : access pthread_t;
 438       attributes    : access pthread_attr_t;
 439       start_routine : Thread_Body;
 440       arg           : System.Address) return int
 441    is
 442       function pthread_create_base
 443         (thread        : access pthread_t;
 444          attributes    : pthread_attr_t;
 445          start_routine : Thread_Body;
 446          arg           : System.Address) return int;
 447       pragma Import (C, pthread_create_base, "pthread_create");
 448
 449    begin
 450       if pthread_create_base
 451         (thread, attributes.all, start_routine, arg) /= 0
 452       then
 453          return errno;
 454       else
 455          return 0;
 456       end if;
 457    end pthread_create;
 458
 459    --------------------------
 460    -- POSIX.1c  Section 17 --
 461    --------------------------
 462
 463    function pthread_setspecific
 464      (key   : pthread_key_t;
 465       value : System.Address) return int
 466    is
 467       function pthread_setspecific_base
 468         (key   : pthread_key_t;
 469          value : System.Address) return int;
 470       pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
 471
 472    begin
 473       if pthread_setspecific_base (key, value) /= 0 then
 474          return errno;
 475       else
 476          return 0;
 477       end if;
 478    end pthread_setspecific;
 479
 480    function pthread_getspecific (key : pthread_key_t) return System.Address is
 481       function pthread_getspecific_base
 482         (key   : pthread_key_t;
 483          value : access System.Address) return  int;
 484       pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
 485       Addr : aliased System.Address;
 486
 487    begin
 488       if pthread_getspecific_base (key, Addr'Access) /= 0 then
 489          return System.Null_Address;
 490       else
 491          return Addr;
 492       end if;
 493    end pthread_getspecific;
 494
 495    function pthread_key_create
 496      (key        : access pthread_key_t;
 497       destructor : destructor_pointer) return int
 498    is
 499       function pthread_keycreate
 500         (key        : access pthread_key_t;
 501          destructor : destructor_pointer) return int;
 502       pragma Import (C, pthread_keycreate, "pthread_keycreate");
 503
 504    begin
 505       if pthread_keycreate (key, destructor) /= 0 then
 506          return errno;
 507       else
 508          return 0;
 509       end if;
 510    end pthread_key_create;
 511
 512    function Get_Stack_Base (thread : pthread_t) return Address is
 513       pragma Warnings (Off, thread);
 514    begin
 515       return Null_Address;
 516    end Get_Stack_Base;
 517
 518    procedure pthread_init is
 519    begin
 520       null;
 521    end pthread_init;
 522
 523    function intr_attach (sig : int; handler : isr_address) return long is
 524       function c_signal (sig : int; handler : isr_address) return long;
 525       pragma Import (C, c_signal, "signal");
 526    begin
 527       return c_signal (sig, handler);
 528    end intr_attach;
 529
 530 end System.OS_Interface;