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