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