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