1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . O S _ I N T E R F A C E --
11 -- Copyright (C) 1991-2000 Florida State University --
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. --
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. --
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). --
35 ------------------------------------------------------------------------------
37 -- This is the OS/2 version of this package
40 -- Turn off polling, we do not want ATC polling to take place during
41 -- tasking operations. It causes infinite loops and other problems.
43 with Interfaces.C.Strings;
44 with Interfaces.OS2Lib.Errors;
45 with Interfaces.OS2Lib.Synchronization;
47 package body System.OS_Interface is
50 use Interfaces.OS2Lib;
51 use Interfaces.OS2Lib.Synchronization;
52 use Interfaces.OS2Lib.Errors;
58 -- Although the OS uses a 32-bit integer representing milliseconds
59 -- as timer value that doesn't work for us since 32 bits are not
60 -- enough for absolute timing. Also it is useful to use better
61 -- intermediate precision when adding/substracting timing intervals.
62 -- So we use the standard Ada Duration type which is implemented using
65 -- Shouldn't the timer be moved to a separate package ???
68 Handle : aliased HTIMER := NULLHANDLE;
69 Event : aliased HEV := NULLHANDLE;
72 procedure Initialize (T : out Timer);
73 procedure Finalize (T : in out Timer);
74 procedure Wait (T : in out Timer);
75 procedure Reset (T : in out Timer);
77 procedure Set_Timer_For (T : in out Timer; Period : in Duration);
78 procedure Set_Timer_At (T : in out Timer; Time : in Duration);
79 -- Add a hook to locate the Epoch, for use with Calendar????
85 -- Give up the remainder of the time-slice and yield the processor
86 -- to other threads of equal priority. Yield will return immediately
87 -- without giving up the current time-slice when the only threads
88 -- that are ready have a lower priority.
90 -- ??? Just giving up the current time-slice seems not to be enough
91 -- to get the thread to the end of the ready queue if OS/2 does use
92 -- a queue at all. As a partial work-around, we give up two time-slices.
94 -- This is the best we can do now, and at least is sufficient for passing
95 -- the ACVC 2.0.1 Annex D tests.
107 procedure Delay_For (Period : in Duration_In_Millisec) is
111 pragma Assert (Period >= 0, "GNULLI---Delay_For: negative argument");
113 -- ??? DosSleep is not the appropriate function for a delay in real
114 -- time. It only gives up some number of scheduled time-slices.
115 -- Use a timer instead or block for some semaphore with a time-out.
116 Result := DosSleep (ULONG (Period));
118 if Result = ERROR_TS_WAKEUP then
120 -- Do appropriate processing for interrupted sleep
121 -- Can we raise an exception here?
126 pragma Assert (Result = NO_ERROR, "GNULLI---Error in Delay_For");
133 function Clock return Duration is
135 -- Implement conversion from tick count to Duration
136 -- using fixed point arithmetic. The frequency of
137 -- the Intel 8254 timer chip is 18.2 * 2**16 Hz.
139 Tick_Duration : constant := 1.0 / (18.2 * 2**16);
140 Tick_Count : aliased QWORD;
144 -- Read nr of clock ticks since boot time
145 Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access));
147 return Tick_Count * Tick_Duration;
150 ----------------------
151 -- Initialize Timer --
152 ----------------------
154 procedure Initialize (T : out Timer) is
157 (T.Handle = NULLHANDLE, "GNULLI---Timer already initialized");
159 Must_Not_Fail (DosCreateEventSem
160 (pszName => Interfaces.C.Strings.Null_Ptr,
161 f_phev => T.Event'Unchecked_Access,
162 flAttr => DC_SEM_SHARED,
170 procedure Set_Timer_For
172 Period : in Duration)
174 Rel_Time : Duration_In_Millisec :=
175 Duration_In_Millisec (Period * 1_000.0);
179 (T.Event /= NULLHANDLE, "GNULLI---Timer not initialized");
181 (T.Handle = NULLHANDLE, "GNULLI---Timer already in use");
183 Must_Not_Fail (DosAsyncTimer
184 (msec => ULONG (Rel_Time),
185 F_hsem => HSEM (T.Event),
186 F_phtimer => T.Handle'Unchecked_Access));
193 -- Note that the timer is started in a critical section to prevent the
194 -- race condition when absolute time is converted to time relative to
195 -- current time. T.Event will be posted when the Time has passed
197 procedure Set_Timer_At
201 Relative_Time : Duration;
204 Must_Not_Fail (DosEnterCritSec);
207 Relative_Time := Time - Clock;
208 if Relative_Time > 0.0 then
209 Set_Timer_For (T, Period => Time - Clock);
211 Sem_Must_Not_Fail (DosPostEventSem (T.Event));
215 Must_Not_Fail (DosExitCritSec);
222 procedure Wait (T : in out Timer) is
224 Sem_Must_Not_Fail (DosWaitEventSem (T.Event, SEM_INDEFINITE_WAIT));
225 T.Handle := NULLHANDLE;
232 procedure Reset (T : in out Timer) is
233 Dummy_Count : aliased ULONG;
236 if T.Handle /= NULLHANDLE then
237 Must_Not_Fail (DosStopTimer (T.Handle));
238 T.Handle := NULLHANDLE;
242 (DosResetEventSem (T.Event, Dummy_Count'Unchecked_Access));
249 procedure Finalize (T : in out Timer) is
252 Must_Not_Fail (DosCloseEventSem (T.Event));
253 T.Event := NULLHANDLE;
256 end System.OS_Interface;