File : a-reatim-raven-sfp.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) 2001-2015, AdaCore --
10 -- --
11 -- GNAT 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is the Ravenscar/HI-E version of this package for VxWorks 5
33
34 with System.Tasking;
35 with System.Task_Primitives.Operations;
36
37 with Unchecked_Conversion;
38
39 package body Ada.Real_Time with
40 SPARK_Mode => Off
41 is
42
43 package STPO renames System.Task_Primitives.Operations;
44
45 function To_Integer is new Unchecked_Conversion (Duration, Integer);
46
47 function Convert_To_Duration is new
48 Unchecked_Conversion (Integer, Duration);
49
50 ---------
51 -- "*" --
52 ---------
53
54 function "*" (Left : Time_Span; Right : Integer) return Time_Span is
55 begin
56 return Left * Time_Span (Right);
57 end "*";
58
59 function "*" (Left : Integer; Right : Time_Span) return Time_Span is
60 begin
61 return Time_Span (Left) * Right;
62 end "*";
63
64 ---------
65 -- "+" --
66 ---------
67
68 function "+" (Left : Time; Right : Time_Span) return Time is
69 begin
70 return Left + Time (Right);
71 end "+";
72
73 function "+" (Left : Time_Span; Right : Time) return Time is
74 begin
75 return Time (Left) + Right;
76 end "+";
77
78 function "+" (Left, Right : Time_Span) return Time_Span is
79 begin
80 return Time_Span (Integer (Left) + Integer (Right));
81 end "+";
82
83 ---------
84 -- "-" --
85 ---------
86
87 function "-" (Left : Time; Right : Time_Span) return Time is
88 begin
89 return Left - Time (Right);
90 end "-";
91
92 function "-" (Left, Right : Time) return Time_Span is
93 begin
94 return Time_Span (Integer (Left) - Integer (Right));
95 end "-";
96
97 function "-" (Left, Right : Time_Span) return Time_Span is
98 begin
99 return Time_Span (Integer (Left) - Integer (Right));
100 end "-";
101
102 function "-" (Right : Time_Span) return Time_Span is
103 begin
104 return Time_Span (-Integer (Right));
105 end "-";
106
107 ---------
108 -- "/" --
109 ---------
110
111 function "/" (Left, Right : Time_Span) return Integer is
112 begin
113 return Integer (Left) / Integer (Right);
114 end "/";
115
116 function "/" (Left : Time_Span; Right : Integer) return Time_Span is
117 begin
118 return Left / Time_Span (Right);
119 end "/";
120
121 -----------
122 -- Clock --
123 -----------
124
125 function Clock return Time is
126 begin
127 return Time (System.Task_Primitives.Operations.Monotonic_Clock);
128 end Clock;
129
130 ------------------
131 -- Microseconds --
132 ------------------
133
134 function Microseconds (US : Integer) return Time_Span is
135 begin
136 return
137 Time_Span (US * Integer (STPO.RT_Resolution)) / Time_Span (10#1#E6);
138 end Microseconds;
139
140 ------------------
141 -- Milliseconds --
142 ------------------
143
144 function Milliseconds (MS : Integer) return Time_Span is
145 begin
146 return
147 Time_Span (MS * Integer (STPO.RT_Resolution)) / Time_Span (10#1#E3);
148 end Milliseconds;
149
150 -------------
151 -- Minutes --
152 -------------
153
154 function Minutes (M : Integer) return Time_Span is
155 begin
156 return Milliseconds (M) * Integer'(60_000);
157 end Minutes;
158
159 -----------------
160 -- Nanoseconds --
161 -----------------
162
163 function Nanoseconds (NS : Integer) return Time_Span is
164 begin
165 return
166 Time_Span (NS * Integer (STPO.RT_Resolution)) / Time_Span (10#1#E9);
167 end Nanoseconds;
168
169 -------------
170 -- Seconds --
171 -------------
172
173 function Seconds (S : Integer) return Time_Span is
174 begin
175 return Milliseconds (S) * Integer'(1000);
176 end Seconds;
177
178 -----------
179 -- Split --
180 -----------
181
182 procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
183 Res : constant Time := Time (STPO.RT_Resolution);
184
185 begin
186 SC := Seconds_Count (T / Res);
187
188 -- TS will always be non-negative, as required by ARM D.8 (29), because
189 -- T is non-negative.
190
191 TS := Time_Span (T) - Time_Span (Time (SC) * Res);
192 end Split;
193
194 -------------
195 -- Time_Of --
196 -------------
197
198 function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
199 begin
200 -- We want to return SC * RT_Resolution + TS. To avoid spurious
201 -- overflows in the intermediate result (SC * RT_Resolution) we take
202 -- advantage of the different signs in SC and TS, when that is the case.
203
204 -- If the signs of SC and TS are different then we avoid converting SC
205 -- to Time (as we do in the else part). The reason for that is that SC
206 -- converted to Time may overflow the range of Time, while the addition
207 -- of SC plus TS does not overflow (because of their different signs).
208 -- The approach is to add and remove the greatest value of time
209 -- (greatest absolute value) to both SC and TS. SC and TS have different
210 -- signs, so we add the positive constant to the negative value, and the
211 -- negative constant to the positive value, to prevent overflows.
212
213 if (SC > 0 and then TS < 0)
214 or else (SC < 0 and then TS > 0)
215 then
216 declare
217 Closest_Boundary : constant Seconds_Count :=
218 (if TS >= 0 then Time_Span_Last / Time_Span (STPO.RT_Resolution)
219 else Time_Span_First / Time_Span (STPO.RT_Resolution));
220 -- Value representing the number of seconds of the Time_Span
221 -- boundary closest to TS. The sign of Closest_Boundary is always
222 -- different from the sign of SC, hence avoiding overflow in the
223 -- expression (SC + Closest_Boundary) * STPO.RT_Resolution which
224 -- is part of the return statement.
225
226 Dist_To_Boundary : constant Time_Span :=
227 TS - Closest_Boundary * Time_Span (STPO.RT_Resolution);
228 -- Distance between TS and Closest_Boundary expressed in Time_Span
229 -- Both operands in the subtraction have different signs, hence
230 -- avoiding overflow.
231
232 begin
233 -- Both operands in the inner addition have different signs,
234 -- hence avoiding overflow. The Time () conversion and the outer
235 -- addition can overflow only if SC + TC is not within Time'Range.
236
237 return Time (SC + Closest_Boundary) * Time (STPO.RT_Resolution) +
238 Dist_To_Boundary;
239 end;
240
241 -- Both operands have the same sign, so we can convert SC into Time
242 -- right away; if this conversion overflows then the result of adding SC
243 -- and TS would overflow anyway (so we would just be detecting the
244 -- overflow a bit earlier).
245
246 else
247 return Time (SC) * Time (STPO.RT_Resolution) + TS;
248 end if;
249 end Time_Of;
250
251 -----------------
252 -- To_Duration --
253 -----------------
254
255 function To_Duration (TS : Time_Span) return Duration is
256 begin
257 -- Where does this 10000 come from ???
258 return Convert_To_Duration
259 ((Integer (TS) * 10000) / Integer (STPO.RT_Resolution));
260 end To_Duration;
261
262 ------------------
263 -- To_Time_Span --
264 ------------------
265
266 function To_Time_Span (D : Duration) return Time_Span is
267 begin
268 -- Where does this 10000 come from ???
269 return Time_Span (To_Integer (D) * Integer (STPO.RT_Resolution) / 10000);
270 end To_Time_Span;
271
272 begin
273 -- Ensure that the tasking run time is initialized when using clock and/or
274 -- delay operations. The initialization routine has the required machinery
275 -- to prevent multiple calls to Initialize.
276
277 System.Tasking.Initialize;
278 end Ada.Real_Time;