File : a-reatim.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- A D A . R E A L _ T I M E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2015, AdaCore --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 3, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- --
23 -- You should have received a copy of the GNU General Public License and --
24 -- a copy of the GCC Runtime Library Exception along with this program; --
25 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
26 -- <http://www.gnu.org/licenses/>. --
27 -- --
28 -- GNARL was developed by the GNARL team at Florida State University. --
29 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 -- --
31 ------------------------------------------------------------------------------
32
33 with System.Tasking;
34 with Unchecked_Conversion;
35
36 package body Ada.Real_Time with
37 SPARK_Mode => Off
38 is
39
40 ---------
41 -- "*" --
42 ---------
43
44 -- Note that Constraint_Error may be propagated
45
46 function "*" (Left : Time_Span; Right : Integer) return Time_Span is
47 pragma Unsuppress (Overflow_Check);
48 begin
49 return Time_Span (Duration (Left) * Right);
50 end "*";
51
52 function "*" (Left : Integer; Right : Time_Span) return Time_Span is
53 pragma Unsuppress (Overflow_Check);
54 begin
55 return Time_Span (Left * Duration (Right));
56 end "*";
57
58 ---------
59 -- "+" --
60 ---------
61
62 -- Note that Constraint_Error may be propagated
63
64 function "+" (Left : Time; Right : Time_Span) return Time is
65 pragma Unsuppress (Overflow_Check);
66 begin
67 return Time (Duration (Left) + Duration (Right));
68 end "+";
69
70 function "+" (Left : Time_Span; Right : Time) return Time is
71 pragma Unsuppress (Overflow_Check);
72 begin
73 return Time (Duration (Left) + Duration (Right));
74 end "+";
75
76 function "+" (Left, Right : Time_Span) return Time_Span is
77 pragma Unsuppress (Overflow_Check);
78 begin
79 return Time_Span (Duration (Left) + Duration (Right));
80 end "+";
81
82 ---------
83 -- "-" --
84 ---------
85
86 -- Note that Constraint_Error may be propagated
87
88 function "-" (Left : Time; Right : Time_Span) return Time is
89 pragma Unsuppress (Overflow_Check);
90 begin
91 return Time (Duration (Left) - Duration (Right));
92 end "-";
93
94 function "-" (Left, Right : Time) return Time_Span is
95 pragma Unsuppress (Overflow_Check);
96 begin
97 return Time_Span (Duration (Left) - Duration (Right));
98 end "-";
99
100 function "-" (Left, Right : Time_Span) return Time_Span is
101 pragma Unsuppress (Overflow_Check);
102 begin
103 return Time_Span (Duration (Left) - Duration (Right));
104 end "-";
105
106 function "-" (Right : Time_Span) return Time_Span is
107 pragma Unsuppress (Overflow_Check);
108 begin
109 return Time_Span_Zero - Right;
110 end "-";
111
112 ---------
113 -- "/" --
114 ---------
115
116 -- Note that Constraint_Error may be propagated
117
118 function "/" (Left, Right : Time_Span) return Integer is
119 pragma Unsuppress (Overflow_Check);
120 pragma Unsuppress (Division_Check);
121
122 -- RM D.8 (27) specifies the effects of operators on Time_Span, and
123 -- rounding of the division operator in particular, to be the same as
124 -- effects on integer types. To get the correct rounding we first
125 -- convert Time_Span to its root type Duration, which is represented as
126 -- a 64-bit signed integer, and then use integer division.
127
128 type Duration_Rep is range -(2 ** 63) .. +((2 ** 63 - 1));
129
130 function To_Integer is
131 new Unchecked_Conversion (Duration, Duration_Rep);
132 begin
133 return Integer
134 (To_Integer (Duration (Left)) / To_Integer (Duration (Right)));
135 end "/";
136
137 function "/" (Left : Time_Span; Right : Integer) return Time_Span is
138 pragma Unsuppress (Overflow_Check);
139 pragma Unsuppress (Division_Check);
140 begin
141 -- Even though checks are unsuppressed, we need an explicit check for
142 -- the case of largest negative integer divided by minus one, since
143 -- some library routines we use fail to catch this case. This will be
144 -- fixed at the compiler level in the future, at which point this test
145 -- can be removed.
146
147 if Left = Time_Span_First and then Right = -1 then
148 raise Constraint_Error with "overflow";
149 end if;
150
151 return Time_Span (Duration (Left) / Right);
152 end "/";
153
154 -----------
155 -- Clock --
156 -----------
157
158 function Clock return Time is
159 begin
160 return Time (System.Task_Primitives.Operations.Monotonic_Clock);
161 end Clock;
162
163 ------------------
164 -- Microseconds --
165 ------------------
166
167 function Microseconds (US : Integer) return Time_Span is
168 begin
169 return Time_Span_Unit * US * 1_000;
170 end Microseconds;
171
172 ------------------
173 -- Milliseconds --
174 ------------------
175
176 function Milliseconds (MS : Integer) return Time_Span is
177 begin
178 return Time_Span_Unit * MS * 1_000_000;
179 end Milliseconds;
180
181 -------------
182 -- Minutes --
183 -------------
184
185 function Minutes (M : Integer) return Time_Span is
186 begin
187 return Milliseconds (M) * Integer'(60_000);
188 end Minutes;
189
190 -----------------
191 -- Nanoseconds --
192 -----------------
193
194 function Nanoseconds (NS : Integer) return Time_Span is
195 begin
196 return Time_Span_Unit * NS;
197 end Nanoseconds;
198
199 -------------
200 -- Seconds --
201 -------------
202
203 function Seconds (S : Integer) return Time_Span is
204 begin
205 return Milliseconds (S) * Integer'(1000);
206 end Seconds;
207
208 -----------
209 -- Split --
210 -----------
211
212 procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
213 T_Val : Time;
214
215 begin
216 -- Special-case for Time_First, whose absolute value is anomalous,
217 -- courtesy of two's complement.
218
219 T_Val := (if T = Time_First then abs (Time_Last) else abs (T));
220
221 -- Extract the integer part of T, truncating towards zero
222
223 SC :=
224 (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5)));
225
226 if T < 0.0 then
227 SC := -SC;
228 end if;
229
230 -- If original time is negative, need to truncate towards negative
231 -- infinity, to make TS non-negative, as per ARM.
232
233 if Time (SC) > T then
234 SC := SC - 1;
235 end if;
236
237 TS := Time_Span (Duration (T) - Duration (SC));
238 end Split;
239
240 -------------
241 -- Time_Of --
242 -------------
243
244 function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
245 pragma Suppress (Overflow_Check);
246 pragma Suppress (Range_Check);
247 -- We do all our own checks for this function
248
249 -- This is not such a simple case, since TS is already 64 bits, and
250 -- so we can't just promote everything to a wider type to ensure proper
251 -- testing for overflow. The situation is that Seconds_Count is a MUCH
252 -- wider type than Time_Span and Time (both of which have the underlying
253 -- type Duration).
254
255 -- <------------------- Seconds_Count -------------------->
256 -- <-- Duration -->
257
258 -- Now it is possible for an SC value outside the Duration range to
259 -- be "brought back into range" by an appropriate TS value, but there
260 -- are also clearly SC values that are completely out of range. Note
261 -- that the above diagram is wildly out of scale, the difference in
262 -- ranges is much greater than shown.
263
264 -- We can't just go generating out of range Duration values to test for
265 -- overflow, since Duration is a full range type, so we follow the steps
266 -- shown below.
267
268 SC_Lo : constant Seconds_Count :=
269 Seconds_Count (Duration (Time_Span_First) + Duration'(0.5));
270 SC_Hi : constant Seconds_Count :=
271 Seconds_Count (Duration (Time_Span_Last) - Duration'(0.5));
272 -- These are the maximum values of the seconds (integer) part of the
273 -- Duration range. Used to compute and check the seconds in the result.
274
275 TS_SC : Seconds_Count;
276 -- Seconds part of input value
277
278 TS_Fraction : Duration;
279 -- Fractional part of input value, may be negative
280
281 Result_SC : Seconds_Count;
282 -- Seconds value for result
283
284 Fudge : constant Seconds_Count := 10;
285 -- Fudge value used to do end point checks far from end point
286
287 FudgeD : constant Duration := Duration (Fudge);
288 -- Fudge value as Duration
289
290 Fudged_Result : Duration;
291 -- Result fudged up or down by FudgeD
292
293 procedure Out_Of_Range;
294 pragma No_Return (Out_Of_Range);
295 -- Raise exception for result out of range
296
297 ------------------
298 -- Out_Of_Range --
299 ------------------
300
301 procedure Out_Of_Range is
302 begin
303 raise Constraint_Error with
304 "result for Ada.Real_Time.Time_Of is out of range";
305 end Out_Of_Range;
306
307 -- Start of processing for Time_Of
308
309 begin
310 -- If SC is so far out of range that there is no possibility of the
311 -- addition of TS getting it back in range, raise an exception right
312 -- away. That way we don't have to worry about SC values overflowing.
313
314 if SC < 3 * SC_Lo or else SC > 3 * SC_Hi then
315 Out_Of_Range;
316 end if;
317
318 -- Decompose input TS value
319
320 TS_SC := Seconds_Count (Duration (TS));
321 TS_Fraction := Duration (TS) - Duration (TS_SC);
322
323 -- Compute result seconds. If clearly out of range, raise error now
324
325 Result_SC := SC + TS_SC;
326
327 if Result_SC < (SC_Lo - 1) or else Result_SC > (SC_Hi + 1) then
328 Out_Of_Range;
329 end if;
330
331 -- Now the result is simply Result_SC + TS_Fraction, but we can't just
332 -- go computing that since it might be out of range. So what we do is
333 -- to compute a value fudged down or up by 10.0 (arbitrary value, but
334 -- that will do fine), and check that fudged value, and if in range
335 -- unfudge it and return the result.
336
337 -- Fudge positive result down, and check high bound
338
339 if Result_SC > 0 then
340 Fudged_Result := Duration (Result_SC - Fudge) + TS_Fraction;
341
342 if Fudged_Result <= Duration'Last - FudgeD then
343 return Time (Fudged_Result + FudgeD);
344 else
345 Out_Of_Range;
346 end if;
347
348 -- Same for negative values of seconds, fudge up and check low bound
349
350 else
351 Fudged_Result := Duration (Result_SC + Fudge) + TS_Fraction;
352
353 if Fudged_Result >= Duration'First + FudgeD then
354 return Time (Fudged_Result - FudgeD);
355 else
356 Out_Of_Range;
357 end if;
358 end if;
359 end Time_Of;
360
361 -----------------
362 -- To_Duration --
363 -----------------
364
365 function To_Duration (TS : Time_Span) return Duration is
366 begin
367 return Duration (TS);
368 end To_Duration;
369
370 ------------------
371 -- To_Time_Span --
372 ------------------
373
374 function To_Time_Span (D : Duration) return Time_Span is
375 begin
376 -- Note regarding AI-00432 requiring range checking on this conversion.
377 -- In almost all versions of GNAT (and all to which this version of the
378 -- Ada.Real_Time package apply), the range of Time_Span and Duration are
379 -- the same, so there is no issue of overflow.
380
381 return Time_Span (D);
382 end To_Time_Span;
383
384 begin
385 -- Ensure that the tasking run time is initialized when using clock and/or
386 -- delay operations. The initialization routine has the required machinery
387 -- to prevent multiple calls to Initialize.
388
389 System.Tasking.Initialize;
390 end Ada.Real_Time;