gcc/ada/5zosinte.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.15 $
  10 --                                                                          --
  11 --             Copyright (C) 1997-2001 Free Software Foundation             --
  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 the VxWorks version.
  38
  39 --  This package encapsulates all direct interfaces to OS services
  40 --  that are needed by children of System.
  41
  42 pragma Polling (Off);
  43 --  Turn off polling, we do not want ATC polling to take place during
  44 --  tasking operations. It causes infinite loops and other problems.
  45
  46 with Interfaces.C; use Interfaces.C;
  47
  48 with System.VxWorks;
  49 --  used for Wind_TCB_Ptr
  50
  51 with Unchecked_Conversion;
  52
  53 package body System.OS_Interface is
  54
  55    use System.VxWorks;
  56
  57    --  Option flags for taskSpawn
  58
  59    VX_UNBREAKABLE    : constant := 16#0002#;
  60    VX_FP_TASK        : constant := 16#0008#;
  61    VX_FP_PRIVATE_ENV : constant := 16#0080#;
  62    VX_NO_STACK_FILL  : constant := 16#0100#;
  63
  64    function taskSpawn
  65      (name          : System.Address;  --  Pointer to task name
  66       priority      : int;
  67       options       : int;
  68       stacksize     : size_t;
  69       start_routine : Thread_Body;
  70       arg1          : System.Address;
  71       arg2          : int := 0;
  72       arg3          : int := 0;
  73       arg4          : int := 0;
  74       arg5          : int := 0;
  75       arg6          : int := 0;
  76       arg7          : int := 0;
  77       arg8          : int := 0;
  78       arg9          : int := 0;
  79       arg10         : int := 0) return pthread_t;
  80    pragma Import (C, taskSpawn, "taskSpawn");
  81
  82    procedure taskDelete (tid : pthread_t);
  83    pragma Import (C, taskDelete, "taskDelete");
  84
  85    --  These are the POSIX scheduling priorities. These are enabled
  86    --  when the global variable posixPriorityNumbering is 1.
  87
  88    POSIX_SCHED_FIFO_LOW_PRI  : constant := 0;
  89    POSIX_SCHED_FIFO_HIGH_PRI : constant := 255;
  90    POSIX_SCHED_RR_LOW_PRI    : constant := 0;
  91    POSIX_SCHED_RR_HIGH_PRI   : constant := 255;
  92
  93    --  These are the VxWorks native (default) scheduling priorities.
  94    --  These are used when the global variable posixPriorityNumbering
  95    --  is 0.
  96
  97    SCHED_FIFO_LOW_PRI  : constant := 255;
  98    SCHED_FIFO_HIGH_PRI : constant := 0;
  99    SCHED_RR_LOW_PRI    : constant := 255;
 100    SCHED_RR_HIGH_PRI   : constant := 0;
 101
 102    --  Global variable to enable POSIX priority numbering.
 103    --  By default, it is 0 and VxWorks native priority numbering
 104    --  is used.
 105
 106    posixPriorityNumbering : int;
 107    pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering");
 108
 109    --  VxWorks will let you set round-robin scheduling globally
 110    --  for all tasks, but not for individual tasks.  Attempting
 111    --  to set the scheduling policy for a specific task (using
 112    --  sched_setscheduler) to something other than what the system
 113    --  is currently using will fail.  If you wish to change the
 114    --  scheduling policy, then use the following function to set
 115    --  it globally for all tasks.  When ticks is 0, time slicing
 116    --  (round-robin scheduling) is disabled.
 117
 118    function kernelTimeSlice (ticks : int) return int;
 119    pragma Import (C, kernelTimeSlice, "kernelTimeSlice");
 120
 121    function taskPriorityGet
 122      (tid       : pthread_t;
 123       pPriority : access int)
 124      return int;
 125    pragma Import (C, taskPriorityGet, "taskPriorityGet");
 126
 127    function taskPrioritySet
 128      (tid         : pthread_t;
 129       newPriority : int)
 130      return int;
 131    pragma Import (C, taskPrioritySet, "taskPrioritySet");
 132
 133    function To_Wind_TCB_Ptr is
 134      new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr);
 135
 136
 137    --  Error codes (errno).  The lower level 16 bits are the
 138    --  error code, with the upper 16 bits representing the
 139    --  module number in which the error occurred.  By convention,
 140    --  the module number is 0 for UNIX errors.  VxWorks reserves
 141    --  module numbers 1-500, with the remaining module numbers
 142    --  being available for user applications.
 143
 144    M_objLib                 : constant := 61 * 2**16;
 145    --  semTake() failure with ticks = NO_WAIT
 146    S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2;
 147    --  semTake() timeout with ticks > NO_WAIT
 148    S_objLib_OBJ_TIMEOUT     : constant := M_objLib + 4;
 149
 150    --  We use two different kinds of VxWorks semaphores: mutex
 151    --  and binary semaphores.  A null (0) ID is returned when
 152    --  a semaphore cannot be created. Binary semaphores and common
 153    --  operations are declared in the spec of this package,
 154    --  as they are used to implement hardware interrupt handling
 155
 156    function semMCreate
 157      (options : int) return SEM_ID;
 158    pragma Import (C, semMCreate, "semMCreate");
 159
 160
 161    function taskLock return int;
 162    pragma Import (C, taskLock, "taskLock");
 163
 164    function taskUnlock return int;
 165    pragma Import (C, taskUnlock, "taskUnlock");
 166
 167    -------------------------------------------------------
 168    --  Convenience routines to convert between VxWorks  --
 169    --  priority and POSIX priority.                     --
 170    -------------------------------------------------------
 171
 172    function To_Vxworks_Priority (Priority : in int) return int;
 173    pragma Inline (To_Vxworks_Priority);
 174
 175    function To_Posix_Priority (Priority : in int) return int;
 176    pragma Inline (To_Posix_Priority);
 177
 178    function To_Vxworks_Priority (Priority : in int) return int is
 179    begin
 180       return SCHED_FIFO_LOW_PRI - Priority;
 181    end To_Vxworks_Priority;
 182
 183    function To_Posix_Priority (Priority : in int) return int is
 184    begin
 185       return SCHED_FIFO_LOW_PRI - Priority;
 186    end To_Posix_Priority;
 187
 188    ----------------------------------------
 189    --  Implementation of POSIX routines  --
 190    ----------------------------------------
 191
 192    -----------------------------------------
 193    --  Nonstandard Thread Initialization  --
 194    -----------------------------------------
 195
 196    procedure pthread_init is
 197    begin
 198       Keys_Created := 0;
 199       Time_Slice := -1;
 200    end pthread_init;
 201
 202    ---------------------------
 203    --  POSIX.1c  Section 3  --
 204    ---------------------------
 205
 206    function sigwait
 207      (set : access sigset_t;
 208       sig : access Signal) return int
 209    is
 210       Result  : Interfaces.C.int;
 211
 212       function sigwaitinfo
 213         (set : access sigset_t; sigvalue : System.Address) return int;
 214       pragma Import (C, sigwaitinfo, "sigwaitinfo");
 215
 216    begin
 217       Result := sigwaitinfo (set, System.Null_Address);
 218
 219       if Result /= -1 then
 220          sig.all := Signal (Result);
 221          return 0;
 222       else
 223          sig.all := 0;
 224          return errno;
 225       end if;
 226    end sigwait;
 227
 228    ----------------------------
 229    --  POSIX.1c  Section 11  --
 230    ----------------------------
 231
 232    function pthread_mutexattr_init
 233      (attr : access pthread_mutexattr_t) return int is
 234    begin
 235       --  Let's take advantage of VxWorks priority inversion
 236       --  protection.
 237       --
 238       --  ??? - Do we want to also specify SEM_DELETE_SAFE???
 239
 240       attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
 241
 242       --  Initialize the ceiling priority to the maximim priority.
 243       --  We will use POSIX priorities since these routines are
 244       --  emulating POSIX routines.
 245
 246       attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
 247       attr.Protocol := PTHREAD_PRIO_INHERIT;
 248       return 0;
 249    end pthread_mutexattr_init;
 250
 251    function pthread_mutexattr_destroy
 252      (attr : access pthread_mutexattr_t) return int is
 253    begin
 254       attr.Flags := 0;
 255       attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
 256       attr.Protocol := PTHREAD_PRIO_INHERIT;
 257       return 0;
 258    end pthread_mutexattr_destroy;
 259
 260    function pthread_mutex_init
 261      (mutex : access pthread_mutex_t;
 262       attr  : access pthread_mutexattr_t) return int
 263    is
 264       Result : int := 0;
 265
 266    begin
 267       --  A mutex should initially be created full and the task
 268       --  protected from deletion while holding the semaphore.
 269
 270       mutex.Mutex := semMCreate (attr.Flags);
 271       mutex.Prio_Ceiling := attr.Prio_Ceiling;
 272       mutex.Protocol := attr.Protocol;
 273
 274       if mutex.Mutex = 0 then
 275          Result := errno;
 276       end if;
 277
 278       return Result;
 279    end pthread_mutex_init;
 280
 281    function pthread_mutex_destroy
 282      (mutex : access pthread_mutex_t) return int
 283    is
 284       Result : STATUS;
 285    begin
 286       Result := semDelete (mutex.Mutex);
 287
 288       if Result /= 0 then
 289          Result := errno;
 290       end if;
 291
 292       mutex.Mutex := 0;  --  Ensure the mutex is properly cleaned.
 293       mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
 294       mutex.Protocol := PTHREAD_PRIO_INHERIT;
 295       return Result;
 296    end pthread_mutex_destroy;
 297
 298    function pthread_mutex_lock
 299      (mutex : access pthread_mutex_t) return int
 300    is
 301       Result    : int;
 302       WTCB_Ptr  : Wind_TCB_Ptr;
 303    begin
 304       WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf);
 305
 306       if WTCB_Ptr = null then
 307          return errno;
 308       end if;
 309
 310       --  Check the current inherited priority in the WIND_TCB
 311       --  against the mutex ceiling priority and return EINVAL
 312       --  upon a ceiling violation.
 313       --
 314       --  We always convert the VxWorks priority to POSIX priority
 315       --  in case the current priority ordering has changed (see
 316       --  posixPriorityNumbering).  The mutex ceiling priority is
 317       --  maintained as POSIX compatible.
 318
 319       if mutex.Protocol = PTHREAD_PRIO_PROTECT and then
 320          To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling
 321       then
 322          return EINVAL;
 323       end if;
 324
 325       Result := semTake (mutex.Mutex, WAIT_FOREVER);
 326
 327       if Result /= 0 then
 328          Result := errno;
 329       end if;
 330
 331       return Result;
 332    end pthread_mutex_lock;
 333
 334    function pthread_mutex_unlock
 335      (mutex : access pthread_mutex_t) return int
 336    is
 337       Result : int;
 338    begin
 339       Result := semGive (mutex.Mutex);
 340
 341       if Result /= 0 then
 342          Result := errno;
 343       end if;
 344
 345       return Result;
 346    end pthread_mutex_unlock;
 347
 348    function pthread_condattr_init
 349      (attr : access pthread_condattr_t) return int is
 350    begin
 351       attr.Flags := SEM_Q_PRIORITY;
 352       return 0;
 353    end pthread_condattr_init;
 354
 355    function pthread_condattr_destroy
 356      (attr : access pthread_condattr_t) return int is
 357    begin
 358       attr.Flags := 0;
 359       return 0;
 360    end pthread_condattr_destroy;
 361
 362    function pthread_cond_init
 363      (cond : access pthread_cond_t;
 364       attr : access pthread_condattr_t) return int
 365    is
 366       Result  : int := 0;
 367
 368    begin
 369       --  Condition variables should be initially created
 370       --  empty.
 371
 372       cond.Sem := semBCreate (attr.Flags, SEM_EMPTY);
 373       cond.Waiting := 0;
 374
 375       if cond.Sem = 0 then
 376          Result := errno;
 377       end if;
 378
 379       return Result;
 380    end pthread_cond_init;
 381
 382    function pthread_cond_destroy (cond : access pthread_cond_t) return int is
 383       Result : int;
 384
 385    begin
 386       Result := semDelete (cond.Sem);
 387
 388       if Result /= 0 then
 389          Result := errno;
 390       end if;
 391
 392       return Result;
 393    end pthread_cond_destroy;
 394
 395    function pthread_cond_signal
 396      (cond : access pthread_cond_t) return int
 397    is
 398       Result : int := 0;
 399       Status : int;
 400
 401    begin
 402       --  Disable task scheduling.
 403
 404       Status := taskLock;
 405
 406       --  Iff someone is currently waiting on the condition variable
 407       --  then release the semaphore; we don't want to leave the
 408       --  semaphore in the full state because the next guy to do
 409       --  a condition wait operation would not block.
 410
 411       if cond.Waiting > 0 then
 412          Result := semGive (cond.Sem);
 413
 414          --  One less thread waiting on the CV.
 415
 416          cond.Waiting := cond.Waiting - 1;
 417
 418          if Result /= 0 then
 419             Result := errno;
 420          end if;
 421       end if;
 422
 423       --  Reenable task scheduling.
 424
 425       Status := taskUnlock;
 426
 427       return Result;
 428    end pthread_cond_signal;
 429
 430    function pthread_cond_wait
 431      (cond  : access pthread_cond_t;
 432       mutex : access pthread_mutex_t) return int
 433    is
 434       Result : int;
 435       Status : int;
 436    begin
 437       --  Disable task scheduling.
 438
 439       Status := taskLock;
 440
 441       --  Release the mutex as required by POSIX.
 442
 443       Result := semGive (mutex.Mutex);
 444
 445       --  Indicate that there is another thread waiting on the CV.
 446
 447       cond.Waiting := cond.Waiting + 1;
 448
 449       --  Perform a blocking operation to take the CV semaphore.
 450       --  Note that a blocking operation in VxWorks will reenable
 451       --  task scheduling.  When we are no longer blocked and control
 452       --  is returned, task scheduling will again be disabled.
 453
 454       Result := semTake (cond.Sem, WAIT_FOREVER);
 455
 456       if Result /= 0 then
 457          cond.Waiting := cond.Waiting - 1;
 458          Result := EINVAL;
 459       end if;
 460
 461       --  Take the mutex as required by POSIX.
 462
 463       Status := semTake (mutex.Mutex, WAIT_FOREVER);
 464
 465       if Status /= 0 then
 466          Result := EINVAL;
 467       end if;
 468
 469       --  Reenable task scheduling.
 470
 471       Status := taskUnlock;
 472
 473       return Result;
 474    end pthread_cond_wait;
 475
 476    function pthread_cond_timedwait
 477      (cond    : access pthread_cond_t;
 478       mutex   : access pthread_mutex_t;
 479       abstime : access timespec) return int
 480    is
 481       Result  : int;
 482       Status  : int;
 483       Ticks   : int;
 484       TS      : aliased timespec;
 485    begin
 486       Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 487
 488       --  Calculate the number of clock ticks for the timeout.
 489
 490       Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS));
 491
 492       if Ticks <= 0 then
 493          --  It is not worth the time to try to perform a semTake,
 494          --  because we know it will always fail.  A semTake with
 495          --  ticks = 0 (NO_WAIT) will not block and therefore not
 496          --  allow another task to give the semaphore.  And if we've
 497          --  designed pthread_cond_signal correctly, the semaphore
 498          --  should never be left in a full state.
 499          --
 500          --  Make sure we give up the CPU.
 501
 502          Status := taskDelay (0);
 503          return ETIMEDOUT;
 504       end if;
 505
 506       --  Disable task scheduling.
 507
 508       Status := taskLock;
 509
 510       --  Release the mutex as required by POSIX.
 511
 512       Result := semGive (mutex.Mutex);
 513
 514       --  Indicate that there is another thread waiting on the CV.
 515
 516       cond.Waiting := cond.Waiting + 1;
 517
 518       --  Perform a blocking operation to take the CV semaphore.
 519       --  Note that a blocking operation in VxWorks will reenable
 520       --  task scheduling.  When we are no longer blocked and control
 521       --  is returned, task scheduling will again be disabled.
 522
 523       Result := semTake (cond.Sem, Ticks);
 524
 525       if Result /= 0 then
 526          if errno = S_objLib_OBJ_TIMEOUT then
 527             Result := ETIMEDOUT;
 528          else
 529             Result := EINVAL;
 530          end if;
 531          cond.Waiting := cond.Waiting - 1;
 532       end if;
 533
 534       --  Take the mutex as required by POSIX.
 535
 536       Status := semTake (mutex.Mutex, WAIT_FOREVER);
 537
 538       if Status /= 0 then
 539          Result := EINVAL;
 540       end if;
 541
 542       --  Reenable task scheduling.
 543
 544       Status := taskUnlock;
 545
 546       return Result;
 547    end pthread_cond_timedwait;
 548
 549    ----------------------------
 550    --  POSIX.1c  Section 13  --
 551    ----------------------------
 552
 553    function pthread_mutexattr_setprotocol
 554      (attr     : access pthread_mutexattr_t;
 555       protocol : int) return int is
 556    begin
 557       if protocol < PTHREAD_PRIO_NONE
 558         or protocol > PTHREAD_PRIO_PROTECT
 559       then
 560          return EINVAL;
 561       end if;
 562
 563       attr.Protocol := protocol;
 564       return 0;
 565    end pthread_mutexattr_setprotocol;
 566
 567    function pthread_mutexattr_setprioceiling
 568      (attr        : access pthread_mutexattr_t;
 569       prioceiling : int) return int is
 570    begin
 571       --  Our interface to the rest of the world is meant
 572       --  to be POSIX compliant; keep the priority in POSIX
 573       --  format.
 574
 575       attr.Prio_Ceiling := prioceiling;
 576       return 0;
 577    end pthread_mutexattr_setprioceiling;
 578
 579    function pthread_setschedparam
 580      (thread : pthread_t;
 581       policy : int;
 582       param  : access struct_sched_param) return int
 583    is
 584       Result : int;
 585    begin
 586       --  Convert the POSIX priority to VxWorks native
 587       --  priority.
 588
 589       Result := taskPrioritySet (thread,
 590         To_Vxworks_Priority (param.sched_priority));
 591       return 0;
 592    end pthread_setschedparam;
 593
 594    function sched_yield return int is
 595    begin
 596       return taskDelay (0);
 597    end sched_yield;
 598
 599    function pthread_sched_rr_set_interval (usecs : int) return int is
 600       Result  : int := 0;
 601       D_Slice : Duration;
 602    begin
 603       --  Check to see if round-robin scheduling (time slicing)
 604       --  is enabled.  If the time slice is the default value (-1)
 605       --  or any negative number, we will leave the kernel time
 606       --  slice unchanged.  If the time slice is 0, we disable
 607       --  kernel time slicing by setting it to 0.  Otherwise, we
 608       --  set the kernel time slice to the specified value converted
 609       --  to clock ticks.
 610
 611       Time_Slice := usecs;
 612
 613       if Time_Slice > 0 then
 614          D_Slice := Duration (Time_Slice) / Duration (1_000_000.0);
 615          Result := kernelTimeSlice (To_Clock_Ticks (D_Slice));
 616
 617       else
 618          if Time_Slice = 0 then
 619             Result := kernelTimeSlice (0);
 620          end if;
 621       end if;
 622
 623       return Result;
 624    end pthread_sched_rr_set_interval;
 625
 626    function pthread_attr_init (attr : access pthread_attr_t) return int is
 627    begin
 628       attr.Stacksize := 100000;   -- What else can I do?
 629       attr.Detachstate := PTHREAD_CREATE_DETACHED;
 630       attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
 631       attr.Taskname := System.Null_Address;
 632       return 0;
 633    end pthread_attr_init;
 634
 635    function pthread_attr_destroy (attr : access pthread_attr_t) return int is
 636    begin
 637       attr.Stacksize := 0;
 638       attr.Detachstate := 0;
 639       attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
 640       attr.Taskname := System.Null_Address;
 641       return 0;
 642    end pthread_attr_destroy;
 643
 644    function pthread_attr_setdetachstate
 645      (attr        : access pthread_attr_t;
 646       detachstate : int) return int is
 647    begin
 648       attr.Detachstate := detachstate;
 649       return 0;
 650    end pthread_attr_setdetachstate;
 651
 652    function pthread_attr_setstacksize
 653      (attr      : access pthread_attr_t;
 654       stacksize : size_t) return int is
 655    begin
 656       attr.Stacksize := stacksize;
 657       return 0;
 658    end pthread_attr_setstacksize;
 659
 660    --  In VxWorks tasks, we can set the task name.  This
 661    --  makes it really convenient for debugging.
 662
 663    function pthread_attr_setname_np
 664      (attr : access pthread_attr_t;
 665       name : System.Address) return int is
 666    begin
 667       attr.Taskname := name;
 668       return 0;
 669    end pthread_attr_setname_np;
 670
 671    function pthread_create
 672      (thread        : access pthread_t;
 673       attr          : access pthread_attr_t;
 674       start_routine : Thread_Body;
 675       arg           : System.Address) return int is
 676    begin
 677       thread.all := taskSpawn (attr.Taskname,
 678         To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize,
 679         start_routine, arg);
 680
 681       if thread.all = -1 then
 682          return -1;
 683       else
 684          return 0;
 685       end if;
 686    end pthread_create;
 687
 688    function pthread_detach (thread : pthread_t) return int is
 689    begin
 690       return 0;
 691    end pthread_detach;
 692
 693    procedure pthread_exit (status : System.Address) is
 694    begin
 695       taskDelete (0);
 696    end pthread_exit;
 697
 698    function pthread_self return pthread_t is
 699    begin
 700       return taskIdSelf;
 701    end pthread_self;
 702
 703    function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is
 704    begin
 705       if t1 = t2 then
 706          return 1;
 707       else
 708          return 0;
 709       end if;
 710    end pthread_equal;
 711
 712    function pthread_setspecific
 713      (key   : pthread_key_t;
 714       value : System.Address) return int
 715    is
 716       Result : int;
 717    begin
 718       if Integer (key) not in Key_Storage'Range then
 719          return EINVAL;
 720       end if;
 721
 722       Key_Storage (Integer (key)) := value;
 723       Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access);
 724
 725       --  We should be able to directly set the key with the following:
 726       --     Key_Storage (key) := value;
 727       --  but we'll be safe and use taskVarSet.
 728       --  ??? Come back and revisit this.
 729
 730       Result := taskVarSet (taskIdSelf,
 731         Key_Storage (Integer (key))'Access, value);
 732       return Result;
 733    end pthread_setspecific;
 734
 735    function pthread_getspecific (key : pthread_key_t) return System.Address is
 736    begin
 737       return Key_Storage (Integer (key));
 738    end pthread_getspecific;
 739
 740    function pthread_key_create
 741      (key        : access pthread_key_t;
 742       destructor : destructor_pointer) return int is
 743    begin
 744       Keys_Created := Keys_Created + 1;
 745
 746       if Keys_Created not in Key_Storage'Range then
 747          return ENOMEM;
 748       end if;
 749
 750       key.all := pthread_key_t (Keys_Created);
 751       return 0;
 752    end pthread_key_create;
 753
 754    -----------------
 755    -- To_Duration --
 756    -----------------
 757
 758    function To_Duration (TS : timespec) return Duration is
 759    begin
 760       return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
 761    end To_Duration;
 762
 763    -----------------
 764    -- To_Timespec --
 765    -----------------
 766
 767    function To_Timespec (D : Duration) return timespec is
 768       S : time_t;
 769       F : Duration;
 770    begin
 771       S := time_t (Long_Long_Integer (D));
 772       F := D - Duration (S);
 773
 774       --  If F has negative value due to a round-up, adjust for positive F
 775       --  value.
 776       if F < 0.0 then
 777          S := S - 1;
 778          F := F + 1.0;
 779       end if;
 780       return timespec' (ts_sec => S,
 781         ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
 782    end To_Timespec;
 783
 784    --------------------
 785    -- To_Clock_Ticks --
 786    --------------------
 787
 788    --  ??? - For now, we'll always get the system clock rate
 789    --  since it is allowed to be changed during run-time in
 790    --  VxWorks.  A better method would be to provide an operation
 791    --  to set it that so we can always know its value.
 792    --
 793    --  Another thing we should probably allow for is a resultant
 794    --  tick count greater than int'Last.  This should probably
 795    --  be a procedure with two output parameters, one in the
 796    --  range 0 .. int'Last, and another representing the overflow
 797    --  count.
 798
 799    function To_Clock_Ticks (D : Duration) return int is
 800       Ticks          : Long_Long_Integer;
 801       Rate_Duration  : Duration;
 802       Ticks_Duration : Duration;
 803    begin
 804
 805       --  Ensure that the duration can be converted to ticks
 806       --  at the current clock tick rate without overflowing.
 807
 808       Rate_Duration := Duration (sysClkRateGet);
 809
 810       if D > (Duration'Last / Rate_Duration) then
 811          Ticks := Long_Long_Integer (int'Last);
 812
 813       else
 814          --  We always want to round up to the nearest clock tick.
 815
 816          Ticks_Duration := D * Rate_Duration;
 817          Ticks := Long_Long_Integer (Ticks_Duration);
 818
 819          if Ticks_Duration > Duration (Ticks) then
 820             Ticks := Ticks + 1;
 821          end if;
 822
 823          if Ticks > Long_Long_Integer (int'Last) then
 824             Ticks := Long_Long_Integer (int'Last);
 825          end if;
 826       end if;
 827
 828       return int (Ticks);
 829    end To_Clock_Ticks;
 830
 831 end System.OS_Interface;