1------------------------------------------------------------------------------ 2-- -- 3-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . O S _ P R I M I T I V E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 2, or (at your option) any later ver- -- 14-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNARL; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNARL was developed by the GNARL team at Florida State University. -- 30-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34-- This is the OS/2 version of this package 35 36with Interfaces.C; use Interfaces.C; 37with Interfaces.OS2Lib; use Interfaces.OS2Lib; 38with Interfaces.OS2Lib.Synchronization; use Interfaces.OS2Lib.Synchronization; 39 40package body System.OS_Primitives is 41 42 ---------------- 43 -- Local Data -- 44 ---------------- 45 46 Epoch_Offset : Duration; -- See Set_Epoch_Offset 47 Max_Tick_Count : QWORD := 0.0; 48 -- This is needed to compensate for small glitches in the 49 -- hardware clock or the way it is read by the OS 50 51 ----------------------- 52 -- Local Subprograms -- 53 ----------------------- 54 55 procedure Set_Epoch_Offset; 56 -- Initializes the Epoch_1970_Offset to the offset of the System_Clock 57 -- relative to the Unix epoch (Jan 1, 1970), such that 58 -- Clock = System_Clock + Epoch_1970_Offset 59 60 function System_Clock return Duration; 61 pragma Inline (System_Clock); 62 -- Function returning value of system clock with system-dependent timebase. 63 -- For OS/2 the system clock returns the elapsed time since system boot. 64 -- The clock resolution is approximately 838 ns. 65 66 ------------------ 67 -- System_Clock -- 68 ------------------ 69 70 function System_Clock return Duration is 71 72 -- Implement conversion from tick count to Duration 73 -- using fixed point arithmetic. The frequency of 74 -- the Intel 8254 timer chip is 18.2 * 2**16 Hz. 75 76 Tick_Duration : constant := 1.0 / (18.2 * 2**16); 77 Tick_Count : aliased QWORD; 78 79 begin 80 Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); 81 -- Read nr of clock ticks since boot time 82 83 Max_Tick_Count := QWORD'Max (Tick_Count, Max_Tick_Count); 84 85 return Max_Tick_Count * Tick_Duration; 86 end System_Clock; 87 88 ----------- 89 -- Clock -- 90 ----------- 91 92 function Clock return Duration is 93 begin 94 return System_Clock + Epoch_Offset; 95 end Clock; 96 97 --------------------- 98 -- Monotonic_Clock -- 99 --------------------- 100 101 function Monotonic_Clock return Duration renames Clock; 102 103 ---------------------- 104 -- Set_Epoch_Offset -- 105 ---------------------- 106 107 procedure Set_Epoch_Offset is 108 109 -- Interface to Unix C style gettimeofday 110 111 type timeval is record 112 tv_sec : long; 113 tv_usec : long; 114 end record; 115 116 procedure gettimeofday 117 (time : access timeval; 118 zone : System.Address := System.Address'Null_Parameter); 119 pragma Import (C, gettimeofday); 120 121 Time_Of_Day : aliased timeval; 122 Micro_To_Nano : constant := 1.0E3; 123 Sec_To_Nano : constant := 1.0E9; 124 Nanos_Since_Epoch : QWORD; 125 126 begin 127 gettimeofday (Time_Of_Day'Access); 128 Nanos_Since_Epoch := QWORD (Time_Of_Day.tv_sec) * Sec_To_Nano 129 + QWORD (Time_Of_Day.tv_usec) * Micro_To_Nano; 130 131 Epoch_Offset := 132 Duration'(Nanos_Since_Epoch / Sec_To_Nano) - System_Clock; 133 134 end Set_Epoch_Offset; 135 136 ----------------- 137 -- Timed_Delay -- 138 ----------------- 139 140 procedure Timed_Delay 141 (Time : Duration; 142 Mode : Integer) 143 is 144 Rel_Time : Duration; 145 Abs_Time : Duration; 146 Check_Time : Duration := Clock; 147 148 begin 149 if Mode = Relative then 150 Rel_Time := Time; 151 Abs_Time := Time + Check_Time; 152 else 153 Rel_Time := Time - Check_Time; 154 Abs_Time := Time; 155 end if; 156 157 if Rel_Time > 0.0 then 158 loop 159 Must_Not_Fail (DosSleep (ULONG (Rel_Time * 1000.0))); 160 161 Check_Time := Clock; 162 163 exit when Abs_Time <= Check_Time; 164 165 Rel_Time := Abs_Time - Check_Time; 166 end loop; 167 end if; 168 end Timed_Delay; 169 170begin 171 Set_Epoch_Offset; 172end System.OS_Primitives; 173