gcc/ada/s-osinte-lynxos-3.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) 1999-2003 Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a LynxOS (Native) version of this package
  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 with Interfaces.C;
  41
  42 package body System.OS_Interface is
  43
  44    use Interfaces.C;
  45
  46    -------------------
  47    -- clock_gettime --
  48    -------------------
  49
  50    function clock_gettime
  51      (clock_id : clockid_t;
  52       tp       : access timespec)
  53       return     int
  54    is
  55       function clock_gettime_base
  56         (clock_id : clockid_t;
  57          tp       : access timespec)
  58          return     int;
  59       pragma Import (C, clock_gettime_base, "clock_gettime");
  60
  61    begin
  62       if clock_gettime_base (clock_id, tp) /= 0 then
  63          return errno;
  64       end if;
  65
  66       return 0;
  67    end clock_gettime;
  68
  69    -----------------
  70    -- To_Duration --
  71    -----------------
  72
  73    function To_Duration (TS : timespec) return Duration is
  74    begin
  75       return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
  76    end To_Duration;
  77
  78    function To_Duration (TV : struct_timeval) return Duration is
  79    begin
  80       return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
  81    end To_Duration;
  82
  83    -----------------
  84    -- To_Timespec --
  85    -----------------
  86
  87    function To_Timespec (D : Duration) return timespec is
  88       S : time_t;
  89       F : Duration;
  90
  91    begin
  92       S := time_t (Long_Long_Integer (D));
  93       F := D - Duration (S);
  94
  95       --  If F has negative value due to a round-up, adjust for positive F
  96       --  value.
  97
  98       if F < 0.0 then
  99          S := S - 1;
 100          F := F + 1.0;
 101       end if;
 102
 103       return timespec'(tv_sec => S,
 104         tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
 105    end To_Timespec;
 106
 107    ----------------
 108    -- To_Timeval --
 109    ----------------
 110
 111    function To_Timeval (D : Duration) return struct_timeval is
 112       S : time_t;
 113       F : Duration;
 114
 115    begin
 116       S := time_t (Long_Long_Integer (D));
 117       F := D - Duration (S);
 118
 119       --  If F has negative value due to a round-up, adjust for positive F
 120       --  value.
 121
 122       if F < 0.0 then
 123          S := S - 1;
 124          F := F + 1.0;
 125       end if;
 126
 127       return struct_timeval'(tv_sec => S,
 128         tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
 129    end To_Timeval;
 130
 131    -------------------------
 132    -- POSIX.1c  Section 3 --
 133    -------------------------
 134
 135    function sigwait
 136      (set :  access sigset_t;
 137       sig :  access Signal)
 138       return int
 139    is
 140       function sigwait_base
 141         (set   : access sigset_t;
 142          value : System.Address)
 143          return  Signal;
 144       pragma Import (C, sigwait_base, "sigwait");
 145
 146    begin
 147       sig.all := sigwait_base (set, Null_Address);
 148
 149       if sig.all = -1 then
 150          return errno;
 151       end if;
 152
 153       return 0;
 154    end sigwait;
 155
 156    --------------------------
 157    -- POSIX.1c  Section 11 --
 158    --------------------------
 159
 160    --  For all the following functions, LynxOS threads has the POSIX Draft 4
 161    --  begavior; it sets errno but the standard Posix requires it to be
 162    --  returned.
 163
 164    function pthread_mutexattr_init
 165      (attr : access pthread_mutexattr_t)
 166       return int
 167    is
 168       function pthread_mutexattr_create
 169         (attr : access pthread_mutexattr_t)
 170          return int;
 171       pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
 172
 173    begin
 174       if pthread_mutexattr_create (attr) /= 0 then
 175          return errno;
 176       end if;
 177
 178       return 0;
 179    end pthread_mutexattr_init;
 180
 181    function pthread_mutexattr_destroy
 182      (attr : access pthread_mutexattr_t)
 183       return int
 184    is
 185       function pthread_mutexattr_delete
 186         (attr : access pthread_mutexattr_t)
 187          return int;
 188       pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
 189
 190    begin
 191       if pthread_mutexattr_delete (attr) /= 0 then
 192          return errno;
 193       end if;
 194
 195       return 0;
 196    end pthread_mutexattr_destroy;
 197
 198    function pthread_mutex_init
 199      (mutex : access pthread_mutex_t;
 200       attr  : access pthread_mutexattr_t)
 201       return  int
 202    is
 203       function pthread_mutex_init_base
 204         (mutex : access pthread_mutex_t;
 205          attr  : pthread_mutexattr_t)
 206          return  int;
 207       pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
 208
 209    begin
 210       if pthread_mutex_init_base (mutex, attr.all) /= 0 then
 211          return errno;
 212       end if;
 213
 214       return 0;
 215    end pthread_mutex_init;
 216
 217    function pthread_mutex_destroy
 218      (mutex : access pthread_mutex_t)
 219       return  int
 220    is
 221       function pthread_mutex_destroy_base
 222         (mutex : access pthread_mutex_t)
 223          return  int;
 224       pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
 225
 226    begin
 227       if pthread_mutex_destroy_base (mutex) /= 0 then
 228          return errno;
 229       end if;
 230
 231       return 0;
 232    end pthread_mutex_destroy;
 233
 234    function pthread_mutex_lock
 235      (mutex : access pthread_mutex_t)
 236       return  int
 237    is
 238       function pthread_mutex_lock_base
 239         (mutex : access pthread_mutex_t)
 240          return  int;
 241       pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
 242
 243    begin
 244       if pthread_mutex_lock_base (mutex) /= 0 then
 245          return errno;
 246       end if;
 247
 248       return 0;
 249    end pthread_mutex_lock;
 250
 251    function pthread_mutex_unlock
 252      (mutex : access pthread_mutex_t)
 253       return  int
 254    is
 255       function pthread_mutex_unlock_base
 256         (mutex : access pthread_mutex_t)
 257          return  int;
 258       pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
 259
 260    begin
 261       if pthread_mutex_unlock_base (mutex) /= 0 then
 262          return errno;
 263       end if;
 264
 265       return 0;
 266    end pthread_mutex_unlock;
 267
 268    function pthread_condattr_init
 269      (attr : access pthread_condattr_t)
 270       return int
 271    is
 272       function pthread_condattr_create
 273         (attr : access pthread_condattr_t)
 274          return int;
 275       pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
 276
 277    begin
 278       if pthread_condattr_create (attr) /= 0 then
 279          return errno;
 280       end if;
 281
 282       return 0;
 283    end pthread_condattr_init;
 284
 285    function pthread_condattr_destroy
 286      (attr : access pthread_condattr_t)
 287       return int
 288    is
 289       function pthread_condattr_delete
 290         (attr : access pthread_condattr_t)
 291          return int;
 292       pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
 293
 294    begin
 295       if pthread_condattr_delete (attr) /= 0 then
 296          return errno;
 297       end if;
 298
 299       return 0;
 300    end pthread_condattr_destroy;
 301
 302    function pthread_cond_init
 303      (cond : access pthread_cond_t;
 304       attr : access pthread_condattr_t)
 305       return int
 306    is
 307       function pthread_cond_init_base
 308         (cond : access pthread_cond_t;
 309          attr : pthread_condattr_t)
 310          return int;
 311       pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
 312
 313    begin
 314       if pthread_cond_init_base (cond, attr.all) /= 0 then
 315          return errno;
 316       end if;
 317
 318       return 0;
 319    end pthread_cond_init;
 320
 321    function pthread_cond_destroy
 322      (cond : access pthread_cond_t)
 323       return int
 324    is
 325       function pthread_cond_destroy_base
 326         (cond : access pthread_cond_t)
 327          return int;
 328       pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
 329
 330    begin
 331       if pthread_cond_destroy_base (cond) /= 0 then
 332          return errno;
 333       end if;
 334
 335       return 0;
 336    end pthread_cond_destroy;
 337
 338    function pthread_cond_signal
 339      (cond : access pthread_cond_t)
 340       return int
 341    is
 342       function pthread_cond_signal_base
 343         (cond : access pthread_cond_t)
 344          return int;
 345       pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
 346
 347    begin
 348       if pthread_cond_signal_base (cond) /= 0 then
 349          return errno;
 350       end if;
 351
 352       return 0;
 353    end pthread_cond_signal;
 354
 355    function pthread_cond_wait
 356      (cond  : access pthread_cond_t;
 357       mutex : access pthread_mutex_t)
 358       return  int
 359    is
 360       function pthread_cond_wait_base
 361         (cond  : access pthread_cond_t;
 362          mutex : access pthread_mutex_t)
 363          return  int;
 364       pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
 365
 366    begin
 367       if pthread_cond_wait_base (cond, mutex) /= 0 then
 368          return errno;
 369       end if;
 370
 371       return 0;
 372    end pthread_cond_wait;
 373
 374    function pthread_cond_timedwait
 375      (cond    : access pthread_cond_t;
 376       mutex   : access pthread_mutex_t;
 377       reltime : access timespec) return int
 378    is
 379       function pthread_cond_timedwait_base
 380         (cond    : access pthread_cond_t;
 381          mutex   : access pthread_mutex_t;
 382          reltime : access timespec) return int;
 383       pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
 384
 385    begin
 386       if pthread_cond_timedwait_base (cond, mutex, reltime) /= 0 then
 387          if errno = EAGAIN then
 388             return ETIMEDOUT;
 389          end if;
 390
 391          return errno;
 392       end if;
 393
 394       return 0;
 395    end pthread_cond_timedwait;
 396
 397    --------------------------
 398    -- POSIX.1c  Section 13 --
 399    --------------------------
 400
 401    function pthread_setschedparam
 402      (thread : pthread_t;
 403       policy : int;
 404       param  : access struct_sched_param)
 405       return   int
 406    is
 407       function pthread_setscheduler
 408         (thread : pthread_t;
 409          policy : int;
 410          prio   : int)
 411          return   int;
 412       pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
 413
 414    begin
 415       if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
 416          return errno;
 417       end if;
 418
 419       return 0;
 420    end pthread_setschedparam;
 421
 422    function pthread_mutexattr_setprotocol
 423      (attr     : access pthread_mutexattr_t;
 424       protocol : int)
 425       return     int
 426    is
 427       pragma Unreferenced (attr, protocol);
 428    begin
 429       return 0;
 430    end pthread_mutexattr_setprotocol;
 431
 432    function pthread_mutexattr_setprioceiling
 433      (attr        : access pthread_mutexattr_t;
 434       prioceiling : int)
 435       return        int
 436    is
 437       pragma Unreferenced (attr, prioceiling);
 438    begin
 439       return 0;
 440    end pthread_mutexattr_setprioceiling;
 441
 442    function pthread_attr_setscope
 443      (attr            : access pthread_attr_t;
 444       contentionscope : int)
 445       return            int
 446    is
 447       pragma Unreferenced (attr, contentionscope);
 448    begin
 449       return 0;
 450    end pthread_attr_setscope;
 451
 452    function sched_yield return int is
 453       procedure pthread_yield;
 454       pragma Import (C, pthread_yield, "pthread_yield");
 455
 456    begin
 457       pthread_yield;
 458       return 0;
 459    end sched_yield;
 460
 461    -----------------------------
 462    --  P1003.1c - Section 16  --
 463    -----------------------------
 464
 465    function pthread_attr_setdetachstate
 466      (attr        : access pthread_attr_t;
 467       detachstate : int)
 468       return        int
 469    is
 470       pragma Unreferenced (attr, detachstate);
 471    begin
 472       return 0;
 473    end pthread_attr_setdetachstate;
 474
 475    function pthread_create
 476      (thread        : access pthread_t;
 477       attributes    : access pthread_attr_t;
 478       start_routine : Thread_Body;
 479       arg           : System.Address)
 480       return          int
 481    is
 482       --  The LynxOS pthread_create doesn't seems to work.
 483       --  Workaround : We're using st_new instead.
 484       --
 485       --   function pthread_create_base
 486       --     (thread        : access pthread_t;
 487       --      attributes    : pthread_attr_t;
 488       --      start_routine : Thread_Body;
 489       --      arg           : System.Address)
 490       --      return          int;
 491       --   pragma Import (C, pthread_create_base, "pthread_create");
 492
 493       St : aliased st_t := attributes.st;
 494
 495       function st_new
 496         (start_routine : Thread_Body;
 497          arg           : System.Address;
 498          attributes    : access st_t;
 499          thread        : access pthread_t)
 500          return          int;
 501       pragma Import (C, st_new, "st_new");
 502
 503    begin
 504       --  Following code would be used if above commented function worked
 505
 506       --   if pthread_create_base
 507       --        (thread, attributes.all, start_routine, arg) /= 0 then
 508
 509       if st_new (start_routine, arg, St'Access, thread) /= 0 then
 510          return errno;
 511       end if;
 512
 513       return 0;
 514    end pthread_create;
 515
 516    function pthread_detach (thread : pthread_t) return int is
 517       aliased_thread : aliased pthread_t := thread;
 518
 519       function pthread_detach_base (thread : access pthread_t) return int;
 520       pragma Import (C, pthread_detach_base, "pthread_detach");
 521
 522    begin
 523       if pthread_detach_base (aliased_thread'Access) /= 0 then
 524          return errno;
 525       end if;
 526
 527       return 0;
 528    end pthread_detach;
 529
 530    --------------------------
 531    -- POSIX.1c  Section 17 --
 532    --------------------------
 533
 534    function pthread_setspecific
 535      (key   : pthread_key_t;
 536       value : System.Address)
 537       return  int
 538    is
 539       function pthread_setspecific_base
 540         (key   : pthread_key_t;
 541          value : System.Address)
 542          return  int;
 543       pragma Import (C, pthread_setspecific_base, "pthread_setspecific");
 544
 545    begin
 546       if pthread_setspecific_base (key, value) /= 0 then
 547          return errno;
 548       end if;
 549
 550       return 0;
 551    end pthread_setspecific;
 552
 553    function pthread_getspecific (key : pthread_key_t) return System.Address is
 554       procedure pthread_getspecific_base
 555         (key   : pthread_key_t;
 556          value : access System.Address);
 557       pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
 558
 559       value : aliased System.Address := System.Null_Address;
 560
 561    begin
 562       pthread_getspecific_base (key, value'Unchecked_Access);
 563       return value;
 564    end pthread_getspecific;
 565
 566    function Get_Stack_Base (thread : pthread_t) return Address is
 567       pragma Warnings (Off, thread);
 568
 569    begin
 570       return Null_Address;
 571    end Get_Stack_Base;
 572
 573    function pthread_key_create
 574      (key        : access pthread_key_t;
 575       destructor : destructor_pointer)
 576       return       int
 577    is
 578       function pthread_keycreate
 579         (key        : access pthread_key_t;
 580          destructor : destructor_pointer)
 581          return       int;
 582       pragma Import (C, pthread_keycreate, "pthread_keycreate");
 583
 584    begin
 585       if pthread_keycreate (key, destructor) /= 0 then
 586          return errno;
 587       end if;
 588
 589       return 0;
 590    end pthread_key_create;
 591
 592    procedure pthread_init is
 593    begin
 594       null;
 595    end pthread_init;
 596
 597 end System.OS_Interface;