| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
| -- -- |
| -- S Y S T E M . O S _ I N T E R F A C E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision: 1.15 $ |
| -- -- |
| -- Copyright (C) 1997-2001 Free Software Foundation -- |
| -- -- |
| -- GNARL is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 2, or (at your option) any later ver- -- |
| -- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNARL; see file COPYING. If not, write -- |
| -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, USA. -- |
| -- -- |
| -- As a special exception, if other files instantiate generics from this -- |
| -- unit, or you link this unit with other files to produce an executable, -- |
| -- this unit does not by itself cause the resulting executable to be -- |
| -- covered by the GNU General Public License. This exception does not -- |
| -- however invalidate any other reasons why the executable file might be -- |
| -- covered by the GNU Public License. -- |
| -- -- |
| -- GNARL was developed by the GNARL team at Florida State University. It is -- |
| -- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- |
| -- State University (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- This is the VxWorks version. |
| |
| -- This package encapsulates all direct interfaces to OS services |
| -- that are needed by children of System. |
| |
| pragma Polling (Off); |
| -- Turn off polling, we do not want ATC polling to take place during |
| -- tasking operations. It causes infinite loops and other problems. |
| |
| with Interfaces.C; use Interfaces.C; |
| |
| with System.VxWorks; |
| -- used for Wind_TCB_Ptr |
| |
| with Unchecked_Conversion; |
| |
| package body System.OS_Interface is |
| |
| use System.VxWorks; |
| |
| -- Option flags for taskSpawn |
| |
| VX_UNBREAKABLE : constant := 16#0002#; |
| VX_FP_TASK : constant := 16#0008#; |
| VX_FP_PRIVATE_ENV : constant := 16#0080#; |
| VX_NO_STACK_FILL : constant := 16#0100#; |
| |
| function taskSpawn |
| (name : System.Address; -- Pointer to task name |
| priority : int; |
| options : int; |
| stacksize : size_t; |
| start_routine : Thread_Body; |
| arg1 : System.Address; |
| arg2 : int := 0; |
| arg3 : int := 0; |
| arg4 : int := 0; |
| arg5 : int := 0; |
| arg6 : int := 0; |
| arg7 : int := 0; |
| arg8 : int := 0; |
| arg9 : int := 0; |
| arg10 : int := 0) return pthread_t; |
| pragma Import (C, taskSpawn, "taskSpawn"); |
| |
| procedure taskDelete (tid : pthread_t); |
| pragma Import (C, taskDelete, "taskDelete"); |
| |
| -- These are the POSIX scheduling priorities. These are enabled |
| -- when the global variable posixPriorityNumbering is 1. |
| |
| POSIX_SCHED_FIFO_LOW_PRI : constant := 0; |
| POSIX_SCHED_FIFO_HIGH_PRI : constant := 255; |
| POSIX_SCHED_RR_LOW_PRI : constant := 0; |
| POSIX_SCHED_RR_HIGH_PRI : constant := 255; |
| |
| -- These are the VxWorks native (default) scheduling priorities. |
| -- These are used when the global variable posixPriorityNumbering |
| -- is 0. |
| |
| SCHED_FIFO_LOW_PRI : constant := 255; |
| SCHED_FIFO_HIGH_PRI : constant := 0; |
| SCHED_RR_LOW_PRI : constant := 255; |
| SCHED_RR_HIGH_PRI : constant := 0; |
| |
| -- Global variable to enable POSIX priority numbering. |
| -- By default, it is 0 and VxWorks native priority numbering |
| -- is used. |
| |
| posixPriorityNumbering : int; |
| pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering"); |
| |
| -- VxWorks will let you set round-robin scheduling globally |
| -- for all tasks, but not for individual tasks. Attempting |
| -- to set the scheduling policy for a specific task (using |
| -- sched_setscheduler) to something other than what the system |
| -- is currently using will fail. If you wish to change the |
| -- scheduling policy, then use the following function to set |
| -- it globally for all tasks. When ticks is 0, time slicing |
| -- (round-robin scheduling) is disabled. |
| |
| function kernelTimeSlice (ticks : int) return int; |
| pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); |
| |
| function taskPriorityGet |
| (tid : pthread_t; |
| pPriority : access int) |
| return int; |
| pragma Import (C, taskPriorityGet, "taskPriorityGet"); |
| |
| function taskPrioritySet |
| (tid : pthread_t; |
| newPriority : int) |
| return int; |
| pragma Import (C, taskPrioritySet, "taskPrioritySet"); |
| |
| function To_Wind_TCB_Ptr is |
| new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr); |
| |
| |
| -- Error codes (errno). The lower level 16 bits are the |
| -- error code, with the upper 16 bits representing the |
| -- module number in which the error occurred. By convention, |
| -- the module number is 0 for UNIX errors. VxWorks reserves |
| -- module numbers 1-500, with the remaining module numbers |
| -- being available for user applications. |
| |
| M_objLib : constant := 61 * 2**16; |
| -- semTake() failure with ticks = NO_WAIT |
| S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; |
| -- semTake() timeout with ticks > NO_WAIT |
| S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; |
| |
| -- We use two different kinds of VxWorks semaphores: mutex |
| -- and binary semaphores. A null (0) ID is returned when |
| -- a semaphore cannot be created. Binary semaphores and common |
| -- operations are declared in the spec of this package, |
| -- as they are used to implement hardware interrupt handling |
| |
| function semMCreate |
| (options : int) return SEM_ID; |
| pragma Import (C, semMCreate, "semMCreate"); |
| |
| |
| function taskLock return int; |
| pragma Import (C, taskLock, "taskLock"); |
| |
| function taskUnlock return int; |
| pragma Import (C, taskUnlock, "taskUnlock"); |
| |
| ------------------------------------------------------- |
| -- Convenience routines to convert between VxWorks -- |
| -- priority and POSIX priority. -- |
| ------------------------------------------------------- |
| |
| function To_Vxworks_Priority (Priority : in int) return int; |
| pragma Inline (To_Vxworks_Priority); |
| |
| function To_Posix_Priority (Priority : in int) return int; |
| pragma Inline (To_Posix_Priority); |
| |
| function To_Vxworks_Priority (Priority : in int) return int is |
| begin |
| return SCHED_FIFO_LOW_PRI - Priority; |
| end To_Vxworks_Priority; |
| |
| function To_Posix_Priority (Priority : in int) return int is |
| begin |
| return SCHED_FIFO_LOW_PRI - Priority; |
| end To_Posix_Priority; |
| |
| ---------------------------------------- |
| -- Implementation of POSIX routines -- |
| ---------------------------------------- |
| |
| ----------------------------------------- |
| -- Nonstandard Thread Initialization -- |
| ----------------------------------------- |
| |
| procedure pthread_init is |
| begin |
| Keys_Created := 0; |
| Time_Slice := -1; |
| end pthread_init; |
| |
| --------------------------- |
| -- POSIX.1c Section 3 -- |
| --------------------------- |
| |
| function sigwait |
| (set : access sigset_t; |
| sig : access Signal) return int |
| is |
| Result : Interfaces.C.int; |
| |
| function sigwaitinfo |
| (set : access sigset_t; sigvalue : System.Address) return int; |
| pragma Import (C, sigwaitinfo, "sigwaitinfo"); |
| |
| begin |
| Result := sigwaitinfo (set, System.Null_Address); |
| |
| if Result /= -1 then |
| sig.all := Signal (Result); |
| return 0; |
| else |
| sig.all := 0; |
| return errno; |
| end if; |
| end sigwait; |
| |
| ---------------------------- |
| -- POSIX.1c Section 11 -- |
| ---------------------------- |
| |
| function pthread_mutexattr_init |
| (attr : access pthread_mutexattr_t) return int is |
| begin |
| -- Let's take advantage of VxWorks priority inversion |
| -- protection. |
| -- |
| -- ??? - Do we want to also specify SEM_DELETE_SAFE??? |
| |
| attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); |
| |
| -- Initialize the ceiling priority to the maximim priority. |
| -- We will use POSIX priorities since these routines are |
| -- emulating POSIX routines. |
| |
| attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; |
| attr.Protocol := PTHREAD_PRIO_INHERIT; |
| return 0; |
| end pthread_mutexattr_init; |
| |
| function pthread_mutexattr_destroy |
| (attr : access pthread_mutexattr_t) return int is |
| begin |
| attr.Flags := 0; |
| attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; |
| attr.Protocol := PTHREAD_PRIO_INHERIT; |
| return 0; |
| end pthread_mutexattr_destroy; |
| |
| function pthread_mutex_init |
| (mutex : access pthread_mutex_t; |
| attr : access pthread_mutexattr_t) return int |
| is |
| Result : int := 0; |
| |
| begin |
| -- A mutex should initially be created full and the task |
| -- protected from deletion while holding the semaphore. |
| |
| mutex.Mutex := semMCreate (attr.Flags); |
| mutex.Prio_Ceiling := attr.Prio_Ceiling; |
| mutex.Protocol := attr.Protocol; |
| |
| if mutex.Mutex = 0 then |
| Result := errno; |
| end if; |
| |
| return Result; |
| end pthread_mutex_init; |
| |
| function pthread_mutex_destroy |
| (mutex : access pthread_mutex_t) return int |
| is |
| Result : STATUS; |
| begin |
| Result := semDelete (mutex.Mutex); |
| |
| if Result /= 0 then |
| Result := errno; |
| end if; |
| |
| mutex.Mutex := 0; -- Ensure the mutex is properly cleaned. |
| mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI; |
| mutex.Protocol := PTHREAD_PRIO_INHERIT; |
| return Result; |
| end pthread_mutex_destroy; |
| |
| function pthread_mutex_lock |
| (mutex : access pthread_mutex_t) return int |
| is |
| Result : int; |
| WTCB_Ptr : Wind_TCB_Ptr; |
| begin |
| WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf); |
| |
| if WTCB_Ptr = null then |
| return errno; |
| end if; |
| |
| -- Check the current inherited priority in the WIND_TCB |
| -- against the mutex ceiling priority and return EINVAL |
| -- upon a ceiling violation. |
| -- |
| -- We always convert the VxWorks priority to POSIX priority |
| -- in case the current priority ordering has changed (see |
| -- posixPriorityNumbering). The mutex ceiling priority is |
| -- maintained as POSIX compatible. |
| |
| if mutex.Protocol = PTHREAD_PRIO_PROTECT and then |
| To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling |
| then |
| return EINVAL; |
| end if; |
| |
| Result := semTake (mutex.Mutex, WAIT_FOREVER); |
| |
| if Result /= 0 then |
| Result := errno; |
| end if; |
| |
| return Result; |
| end pthread_mutex_lock; |
| |
| function pthread_mutex_unlock |
| (mutex : access pthread_mutex_t) return int |
| is |
| Result : int; |
| begin |
| Result := semGive (mutex.Mutex); |
| |
| if Result /= 0 then |
| Result := errno; |
| end if; |
| |
| return Result; |
| end pthread_mutex_unlock; |
| |
| function pthread_condattr_init |
| (attr : access pthread_condattr_t) return int is |
| begin |
| attr.Flags := SEM_Q_PRIORITY; |
| return 0; |
| end pthread_condattr_init; |
| |
| function pthread_condattr_destroy |
| (attr : access pthread_condattr_t) return int is |
| begin |
| attr.Flags := 0; |
| return 0; |
| end pthread_condattr_destroy; |
| |
| function pthread_cond_init |
| (cond : access pthread_cond_t; |
| attr : access pthread_condattr_t) return int |
| is |
| Result : int := 0; |
| |
| begin |
| -- Condition variables should be initially created |
| -- empty. |
| |
| cond.Sem := semBCreate (attr.Flags, SEM_EMPTY); |
| cond.Waiting := 0; |
| |
| if cond.Sem = 0 then |
| Result := errno; |
| end if; |
| |
| return Result; |
| end pthread_cond_init; |
| |
| function pthread_cond_destroy (cond : access pthread_cond_t) return int is |
| Result : int; |
| |
| begin |
| Result := semDelete (cond.Sem); |
| |
| if Result /= 0 then |
| Result := errno; |
| end if; |
| |
| return Result; |
| end pthread_cond_destroy; |
| |
| function pthread_cond_signal |
| (cond : access pthread_cond_t) return int |
| is |
| Result : int := 0; |
| Status : int; |
| |
| begin |
| -- Disable task scheduling. |
| |
| Status := taskLock; |
| |
| -- Iff someone is currently waiting on the condition variable |
| -- then release the semaphore; we don't want to leave the |
| -- semaphore in the full state because the next guy to do |
| -- a condition wait operation would not block. |
| |
| if cond.Waiting > 0 then |
| Result := semGive (cond.Sem); |
| |
| -- One less thread waiting on the CV. |
| |
| cond.Waiting := cond.Waiting - 1; |
| |
| if Result /= 0 then |
| Result := errno; |
| end if; |
| end if; |
| |
| -- Reenable task scheduling. |
| |
| Status := taskUnlock; |
| |
| return Result; |
| end pthread_cond_signal; |
| |
| function pthread_cond_wait |
| (cond : access pthread_cond_t; |
| mutex : access pthread_mutex_t) return int |
| is |
| Result : int; |
| Status : int; |
| begin |
| -- Disable task scheduling. |
| |
| Status := taskLock; |
| |
| -- Release the mutex as required by POSIX. |
| |
| Result := semGive (mutex.Mutex); |
| |
| -- Indicate that there is another thread waiting on the CV. |
| |
| cond.Waiting := cond.Waiting + 1; |
| |
| -- Perform a blocking operation to take the CV semaphore. |
| -- Note that a blocking operation in VxWorks will reenable |
| -- task scheduling. When we are no longer blocked and control |
| -- is returned, task scheduling will again be disabled. |
| |
| Result := semTake (cond.Sem, WAIT_FOREVER); |
| |
| if Result /= 0 then |
| cond.Waiting := cond.Waiting - 1; |
| Result := EINVAL; |
| end if; |
| |
| -- Take the mutex as required by POSIX. |
| |
| Status := semTake (mutex.Mutex, WAIT_FOREVER); |
| |
| if Status /= 0 then |
| Result := EINVAL; |
| end if; |
| |
| -- Reenable task scheduling. |
| |
| Status := taskUnlock; |
| |
| return Result; |
| end pthread_cond_wait; |
| |
| function pthread_cond_timedwait |
| (cond : access pthread_cond_t; |
| mutex : access pthread_mutex_t; |
| abstime : access timespec) return int |
| is |
| Result : int; |
| Status : int; |
| Ticks : int; |
| TS : aliased timespec; |
| begin |
| Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); |
| |
| -- Calculate the number of clock ticks for the timeout. |
| |
| Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS)); |
| |
| if Ticks <= 0 then |
| -- It is not worth the time to try to perform a semTake, |
| -- because we know it will always fail. A semTake with |
| -- ticks = 0 (NO_WAIT) will not block and therefore not |
| -- allow another task to give the semaphore. And if we've |
| -- designed pthread_cond_signal correctly, the semaphore |
| -- should never be left in a full state. |
| -- |
| -- Make sure we give up the CPU. |
| |
| Status := taskDelay (0); |
| return ETIMEDOUT; |
| end if; |
| |
| -- Disable task scheduling. |
| |
| Status := taskLock; |
| |
| -- Release the mutex as required by POSIX. |
| |
| Result := semGive (mutex.Mutex); |
| |
| -- Indicate that there is another thread waiting on the CV. |
| |
| cond.Waiting := cond.Waiting + 1; |
| |
| -- Perform a blocking operation to take the CV semaphore. |
| -- Note that a blocking operation in VxWorks will reenable |
| -- task scheduling. When we are no longer blocked and control |
| -- is returned, task scheduling will again be disabled. |
| |
| Result := semTake (cond.Sem, Ticks); |
| |
| if Result /= 0 then |
| if errno = S_objLib_OBJ_TIMEOUT then |
| Result := ETIMEDOUT; |
| else |
| Result := EINVAL; |
| end if; |
| cond.Waiting := cond.Waiting - 1; |
| end if; |
| |
| -- Take the mutex as required by POSIX. |
| |
| Status := semTake (mutex.Mutex, WAIT_FOREVER); |
| |
| if Status /= 0 then |
| Result := EINVAL; |
| end if; |
| |
| -- Reenable task scheduling. |
| |
| Status := taskUnlock; |
| |
| return Result; |
| end pthread_cond_timedwait; |
| |
| ---------------------------- |
| -- POSIX.1c Section 13 -- |
| ---------------------------- |
| |
| function pthread_mutexattr_setprotocol |
| (attr : access pthread_mutexattr_t; |
| protocol : int) return int is |
| begin |
| if protocol < PTHREAD_PRIO_NONE |
| or protocol > PTHREAD_PRIO_PROTECT |
| then |
| return EINVAL; |
| end if; |
| |
| attr.Protocol := protocol; |
| return 0; |
| end pthread_mutexattr_setprotocol; |
| |
| function pthread_mutexattr_setprioceiling |
| (attr : access pthread_mutexattr_t; |
| prioceiling : int) return int is |
| begin |
| -- Our interface to the rest of the world is meant |
| -- to be POSIX compliant; keep the priority in POSIX |
| -- format. |
| |
| attr.Prio_Ceiling := prioceiling; |
| return 0; |
| end pthread_mutexattr_setprioceiling; |
| |
| function pthread_setschedparam |
| (thread : pthread_t; |
| policy : int; |
| param : access struct_sched_param) return int |
| is |
| Result : int; |
| begin |
| -- Convert the POSIX priority to VxWorks native |
| -- priority. |
| |
| Result := taskPrioritySet (thread, |
| To_Vxworks_Priority (param.sched_priority)); |
| return 0; |
| end pthread_setschedparam; |
| |
| function sched_yield return int is |
| begin |
| return taskDelay (0); |
| end sched_yield; |
| |
| function pthread_sched_rr_set_interval (usecs : int) return int is |
| Result : int := 0; |
| D_Slice : Duration; |
| begin |
| -- Check to see if round-robin scheduling (time slicing) |
| -- is enabled. If the time slice is the default value (-1) |
| -- or any negative number, we will leave the kernel time |
| -- slice unchanged. If the time slice is 0, we disable |
| -- kernel time slicing by setting it to 0. Otherwise, we |
| -- set the kernel time slice to the specified value converted |
| -- to clock ticks. |
| |
| Time_Slice := usecs; |
| |
| if Time_Slice > 0 then |
| D_Slice := Duration (Time_Slice) / Duration (1_000_000.0); |
| Result := kernelTimeSlice (To_Clock_Ticks (D_Slice)); |
| |
| else |
| if Time_Slice = 0 then |
| Result := kernelTimeSlice (0); |
| end if; |
| end if; |
| |
| return Result; |
| end pthread_sched_rr_set_interval; |
| |
| function pthread_attr_init (attr : access pthread_attr_t) return int is |
| begin |
| attr.Stacksize := 100000; -- What else can I do? |
| attr.Detachstate := PTHREAD_CREATE_DETACHED; |
| attr.Priority := POSIX_SCHED_FIFO_LOW_PRI; |
| attr.Taskname := System.Null_Address; |
| return 0; |
| end pthread_attr_init; |
| |
| function pthread_attr_destroy (attr : access pthread_attr_t) return int is |
| begin |
| attr.Stacksize := 0; |
| attr.Detachstate := 0; |
| attr.Priority := POSIX_SCHED_FIFO_LOW_PRI; |
| attr.Taskname := System.Null_Address; |
| return 0; |
| end pthread_attr_destroy; |
| |
| function pthread_attr_setdetachstate |
| (attr : access pthread_attr_t; |
| detachstate : int) return int is |
| begin |
| attr.Detachstate := detachstate; |
| return 0; |
| end pthread_attr_setdetachstate; |
| |
| function pthread_attr_setstacksize |
| (attr : access pthread_attr_t; |
| stacksize : size_t) return int is |
| begin |
| attr.Stacksize := stacksize; |
| return 0; |
| end pthread_attr_setstacksize; |
| |
| -- In VxWorks tasks, we can set the task name. This |
| -- makes it really convenient for debugging. |
| |
| function pthread_attr_setname_np |
| (attr : access pthread_attr_t; |
| name : System.Address) return int is |
| begin |
| attr.Taskname := name; |
| return 0; |
| end pthread_attr_setname_np; |
| |
| function pthread_create |
| (thread : access pthread_t; |
| attr : access pthread_attr_t; |
| start_routine : Thread_Body; |
| arg : System.Address) return int is |
| begin |
| thread.all := taskSpawn (attr.Taskname, |
| To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize, |
| start_routine, arg); |
| |
| if thread.all = -1 then |
| return -1; |
| else |
| return 0; |
| end if; |
| end pthread_create; |
| |
| function pthread_detach (thread : pthread_t) return int is |
| begin |
| return 0; |
| end pthread_detach; |
| |
| procedure pthread_exit (status : System.Address) is |
| begin |
| taskDelete (0); |
| end pthread_exit; |
| |
| function pthread_self return pthread_t is |
| begin |
| return taskIdSelf; |
| end pthread_self; |
| |
| function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is |
| begin |
| if t1 = t2 then |
| return 1; |
| else |
| return 0; |
| end if; |
| end pthread_equal; |
| |
| function pthread_setspecific |
| (key : pthread_key_t; |
| value : System.Address) return int |
| is |
| Result : int; |
| begin |
| if Integer (key) not in Key_Storage'Range then |
| return EINVAL; |
| end if; |
| |
| Key_Storage (Integer (key)) := value; |
| Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access); |
| |
| -- We should be able to directly set the key with the following: |
| -- Key_Storage (key) := value; |
| -- but we'll be safe and use taskVarSet. |
| -- ??? Come back and revisit this. |
| |
| Result := taskVarSet (taskIdSelf, |
| Key_Storage (Integer (key))'Access, value); |
| return Result; |
| end pthread_setspecific; |
| |
| function pthread_getspecific (key : pthread_key_t) return System.Address is |
| begin |
| return Key_Storage (Integer (key)); |
| end pthread_getspecific; |
| |
| function pthread_key_create |
| (key : access pthread_key_t; |
| destructor : destructor_pointer) return int is |
| begin |
| Keys_Created := Keys_Created + 1; |
| |
| if Keys_Created not in Key_Storage'Range then |
| return ENOMEM; |
| end if; |
| |
| key.all := pthread_key_t (Keys_Created); |
| return 0; |
| end pthread_key_create; |
| |
| ----------------- |
| -- To_Duration -- |
| ----------------- |
| |
| function To_Duration (TS : timespec) return Duration is |
| begin |
| return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; |
| end To_Duration; |
| |
| ----------------- |
| -- To_Timespec -- |
| ----------------- |
| |
| function To_Timespec (D : Duration) return timespec is |
| S : time_t; |
| F : Duration; |
| begin |
| S := time_t (Long_Long_Integer (D)); |
| F := D - Duration (S); |
| |
| -- If F has negative value due to a round-up, adjust for positive F |
| -- value. |
| if F < 0.0 then |
| S := S - 1; |
| F := F + 1.0; |
| end if; |
| return timespec' (ts_sec => S, |
| ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); |
| end To_Timespec; |
| |
| -------------------- |
| -- To_Clock_Ticks -- |
| -------------------- |
| |
| -- ??? - For now, we'll always get the system clock rate |
| -- since it is allowed to be changed during run-time in |
| -- VxWorks. A better method would be to provide an operation |
| -- to set it that so we can always know its value. |
| -- |
| -- Another thing we should probably allow for is a resultant |
| -- tick count greater than int'Last. This should probably |
| -- be a procedure with two output parameters, one in the |
| -- range 0 .. int'Last, and another representing the overflow |
| -- count. |
| |
| function To_Clock_Ticks (D : Duration) return int is |
| Ticks : Long_Long_Integer; |
| Rate_Duration : Duration; |
| Ticks_Duration : Duration; |
| begin |
| |
| -- Ensure that the duration can be converted to ticks |
| -- at the current clock tick rate without overflowing. |
| |
| Rate_Duration := Duration (sysClkRateGet); |
| |
| if D > (Duration'Last / Rate_Duration) then |
| Ticks := Long_Long_Integer (int'Last); |
| |
| else |
| -- We always want to round up to the nearest clock tick. |
| |
| Ticks_Duration := D * Rate_Duration; |
| Ticks := Long_Long_Integer (Ticks_Duration); |
| |
| if Ticks_Duration > Duration (Ticks) then |
| Ticks := Ticks + 1; |
| end if; |
| |
| if Ticks > Long_Long_Integer (int'Last) then |
| Ticks := Long_Long_Integer (int'Last); |
| end if; |
| end if; |
| |
| return int (Ticks); |
| end To_Clock_Ticks; |
| |
| end System.OS_Interface; |
