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