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. It is --
  31 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  32 -- State University (http://www.gnat.com).                                  --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This is a LynxOS (Native) version of this package
  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 with Interfaces.C;
  43
  44 package body System.OS_Interface is
  45
  46    use Interfaces.C;
  47
  48    -------------------
  49    -- clock_gettime --
  50    -------------------
  51
  52    function clock_gettime
  53      (clock_id : clockid_t;
  54       tp       : access timespec)
  55       return  int
  56    is
  57       function clock_gettime_base
  58         (clock_id : clockid_t;
  59          tp       : access timespec)
  60          return  int;
  61       pragma Import (C, clock_gettime_base, "clock_gettime");
  62
  63    begin
  64       if clock_gettime_base (clock_id, tp) /= 0 then
  65          return errno;
  66       end if;
  67
  68       return 0;
  69    end clock_gettime;
  70
  71    -----------------
  72    -- To_Duration --
  73    -----------------
  74
  75    function To_Duration (TS : timespec) return Duration is
  76    begin
  77       return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
  78    end To_Duration;
  79
  80    function To_Duration (TV : struct_timeval) return Duration is
  81    begin
  82       return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
  83    end To_Duration;
  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    -- To_Timeval --
 111    ----------------
 112
 113    function To_Timeval (D : Duration) return struct_timeval is
 114       S : time_t;
 115       F : Duration;
 116
 117    begin
 118       S := time_t (Long_Long_Integer (D));
 119       F := D - Duration (S);
 120
 121       --  If F has negative value due to a round-up, adjust for positive F
 122       --  value.
 123
 124       if F < 0.0 then
 125          S := S - 1;
 126          F := F + 1.0;
 127       end if;
 128
 129       return struct_timeval' (tv_sec => S,
 130         tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
 131    end To_Timeval;
 132
 133    -------------------------
 134    -- POSIX.1c  Section 3 --
 135    -------------------------
 136
 137    function sigwait
 138      (set :  access sigset_t;
 139       sig :  access Signal)
 140       return int
 141    is
 142       function sigwait_base
 143         (set   : access sigset_t;
 144          value : System.Address)
 145         return Signal;
 146       pragma Import (C, sigwait_base, "sigwait");
 147
 148    begin
 149       sig.all := sigwait_base (set, Null_Address);
 150
 151       if sig.all = -1 then
 152          return errno;
 153       end if;
 154
 155       return 0;
 156    end sigwait;
 157
 158    --------------------------
 159    -- POSIX.1c  Section 11 --
 160    --------------------------
 161
 162    --  For all the following functions, LynxOS threads has the POSIX Draft 4
 163    --  begavior; it sets errno but the standard Posix requires it to be
 164    --  returned.
 165
 166    function pthread_mutexattr_init
 167      (attr : access pthread_mutexattr_t)
 168       return int
 169    is
 170       function pthread_mutexattr_create
 171         (attr : access pthread_mutexattr_t)
 172          return int;
 173       pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create");
 174
 175    begin
 176       if pthread_mutexattr_create (attr) /= 0 then
 177          return errno;
 178       end if;
 179
 180       return 0;
 181    end pthread_mutexattr_init;
 182
 183    function pthread_mutexattr_destroy
 184      (attr : access pthread_mutexattr_t)
 185       return int
 186    is
 187       function pthread_mutexattr_delete
 188         (attr : access pthread_mutexattr_t)
 189          return int;
 190       pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete");
 191
 192    begin
 193       if pthread_mutexattr_delete (attr) /= 0 then
 194          return errno;
 195       end if;
 196
 197       return 0;
 198    end pthread_mutexattr_destroy;
 199
 200    function pthread_mutex_init
 201      (mutex : access pthread_mutex_t;
 202       attr  : access pthread_mutexattr_t)
 203       return  int
 204    is
 205       function pthread_mutex_init_base
 206         (mutex : access pthread_mutex_t;
 207          attr  : pthread_mutexattr_t)
 208          return  int;
 209       pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init");
 210
 211    begin
 212       if pthread_mutex_init_base (mutex, attr.all) /= 0 then
 213          return errno;
 214       end if;
 215
 216       return 0;
 217    end pthread_mutex_init;
 218
 219    function pthread_mutex_destroy
 220      (mutex : access pthread_mutex_t)
 221       return  int
 222    is
 223       function pthread_mutex_destroy_base
 224         (mutex : access pthread_mutex_t)
 225          return  int;
 226       pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy");
 227
 228    begin
 229       if pthread_mutex_destroy_base (mutex) /= 0 then
 230          return errno;
 231       end if;
 232
 233       return 0;
 234    end pthread_mutex_destroy;
 235
 236    function pthread_mutex_lock
 237      (mutex : access pthread_mutex_t)
 238       return  int
 239    is
 240       function pthread_mutex_lock_base
 241         (mutex : access pthread_mutex_t)
 242          return  int;
 243       pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
 244
 245    begin
 246       if pthread_mutex_lock_base (mutex) /= 0 then
 247          return errno;
 248       end if;
 249
 250       return 0;
 251    end pthread_mutex_lock;
 252
 253    function pthread_mutex_unlock
 254      (mutex : access pthread_mutex_t)
 255       return  int
 256    is
 257       function pthread_mutex_unlock_base
 258         (mutex : access pthread_mutex_t)
 259          return  int;
 260       pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
 261
 262    begin
 263       if pthread_mutex_unlock_base (mutex) /= 0 then
 264          return errno;
 265       end if;
 266
 267       return 0;
 268    end pthread_mutex_unlock;
 269
 270    function pthread_condattr_init
 271      (attr : access pthread_condattr_t)
 272       return int
 273    is
 274       function pthread_condattr_create
 275         (attr : access pthread_condattr_t)
 276          return int;
 277       pragma Import (C, pthread_condattr_create, "pthread_condattr_create");
 278
 279    begin
 280       if pthread_condattr_create (attr) /= 0 then
 281          return errno;
 282       end if;
 283
 284       return 0;
 285    end pthread_condattr_init;
 286
 287    function pthread_condattr_destroy
 288      (attr : access pthread_condattr_t)
 289       return int
 290    is
 291       function pthread_condattr_delete
 292         (attr : access pthread_condattr_t)
 293          return int;
 294       pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete");
 295
 296    begin
 297       if pthread_condattr_delete (attr) /= 0 then
 298          return errno;
 299       end if;
 300
 301       return 0;
 302    end pthread_condattr_destroy;
 303
 304    function pthread_cond_init
 305      (cond : access pthread_cond_t;
 306       attr : access pthread_condattr_t)
 307       return int
 308    is
 309       function pthread_cond_init_base
 310         (cond : access pthread_cond_t;
 311          attr : pthread_condattr_t)
 312          return int;
 313       pragma Import (C, pthread_cond_init_base, "pthread_cond_init");
 314
 315    begin
 316       if pthread_cond_init_base (cond, attr.all) /= 0 then
 317          return errno;
 318       end if;
 319
 320       return 0;
 321    end pthread_cond_init;
 322
 323    function pthread_cond_destroy
 324      (cond : access pthread_cond_t)
 325       return int
 326    is
 327       function pthread_cond_destroy_base
 328         (cond : access pthread_cond_t)
 329          return int;
 330       pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy");
 331
 332    begin
 333       if pthread_cond_destroy_base (cond) /= 0 then
 334          return errno;
 335       end if;
 336
 337       return 0;
 338    end pthread_cond_destroy;
 339
 340    function pthread_cond_signal
 341      (cond : access pthread_cond_t)
 342       return int
 343    is
 344       function pthread_cond_signal_base
 345         (cond : access pthread_cond_t)
 346          return int;
 347       pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal");
 348
 349    begin
 350       if pthread_cond_signal_base (cond) /= 0 then
 351          return errno;
 352       end if;
 353
 354       return 0;
 355    end pthread_cond_signal;
 356
 357    function pthread_cond_wait
 358      (cond  : access pthread_cond_t;
 359       mutex : access pthread_mutex_t)
 360       return  int
 361    is
 362       function pthread_cond_wait_base
 363         (cond  : access pthread_cond_t;
 364          mutex : access pthread_mutex_t)
 365          return  int;
 366       pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
 367
 368    begin
 369       if pthread_cond_wait_base (cond, mutex) /= 0 then
 370          return errno;
 371       end if;
 372
 373       return 0;
 374    end pthread_cond_wait;
 375
 376    function pthread_cond_timedwait
 377      (cond    : access pthread_cond_t;
 378       mutex   : access pthread_mutex_t;
 379       reltime : access timespec) return int
 380    is
 381       function pthread_cond_timedwait_base
 382         (cond    : access pthread_cond_t;
 383          mutex   : access pthread_mutex_t;
 384          reltime : access timespec) return int;
 385       pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
 386
 387    begin
 388       if pthread_cond_timedwait_base (cond, mutex, reltime) /= 0 then
 389          if errno = EAGAIN then
 390             return ETIMEDOUT;
 391          end if;
 392
 393          return errno;
 394       end if;
 395
 396       return 0;
 397    end pthread_cond_timedwait;
 398
 399    --------------------------
 400    -- POSIX.1c  Section 13 --
 401    --------------------------
 402
 403    function pthread_setschedparam
 404      (thread : pthread_t;
 405       policy : int;
 406       param  : access struct_sched_param)
 407       return   int
 408    is
 409       function pthread_setscheduler
 410         (thread : pthread_t;
 411          policy : int;
 412          prio   : int)
 413          return   int;
 414       pragma Import (C, pthread_setscheduler, "pthread_setscheduler");
 415
 416    begin
 417       if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then
 418          return errno;
 419       end if;
 420
 421       return 0;
 422    end pthread_setschedparam;
 423
 424    function pthread_mutexattr_setprotocol
 425      (attr     : access pthread_mutexattr_t;
 426       protocol : int)
 427       return     int
 428    is
 429    begin
 430       return 0;
 431    end pthread_mutexattr_setprotocol;
 432
 433    function pthread_mutexattr_setprioceiling
 434      (attr        : access pthread_mutexattr_t;
 435       prioceiling : int)
 436       return        int
 437    is
 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    begin
 448       return 0;
 449    end pthread_attr_setscope;
 450
 451    function sched_yield return int is
 452       procedure pthread_yield;
 453       pragma Import (C, pthread_yield, "pthread_yield");
 454
 455    begin
 456       pthread_yield;
 457       return 0;
 458    end sched_yield;
 459
 460    -----------------------------
 461    --  P1003.1c - Section 16  --
 462    -----------------------------
 463
 464    function pthread_attr_setdetachstate
 465      (attr        : access pthread_attr_t;
 466       detachstate : int)
 467       return        int
 468    is
 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    begin
 566       return Null_Address;
 567    end Get_Stack_Base;
 568
 569    function pthread_key_create
 570      (key        : access pthread_key_t;
 571       destructor : destructor_pointer)
 572       return       int
 573    is
 574       function pthread_keycreate
 575         (key        : access pthread_key_t;
 576          destructor : destructor_pointer)
 577          return       int;
 578       pragma Import (C, pthread_keycreate, "pthread_keycreate");
 579
 580    begin
 581       if pthread_keycreate (key, destructor) /= 0 then
 582          return errno;
 583       end if;
 584
 585       return 0;
 586    end pthread_key_create;
 587
 588    procedure pthread_init is
 589    begin
 590       null;
 591    end pthread_init;
 592
 593 end System.OS_Interface;