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