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