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-- 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 33with System.Tasking; 34with Unchecked_Conversion; 35 36package body Ada.Real_Time with 37 SPARK_Mode => Off 38is 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 384begin 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; 390end Ada.Real_Time; 391