Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnarl/a-reatim.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
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-2017, Florida State University -- | |
10 -- Copyright (C) 1995-2017, 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 -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
20 -- additional permissions described in the GCC Runtime Library Exception, -- | |
21 -- version 3.1, as published by the Free Software Foundation. -- | |
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; |