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