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