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-2010, 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; 34 35package body Ada.Real_Time is 36 37 --------- 38 -- "*" -- 39 --------- 40 41 -- Note that Constraint_Error may be propagated 42 43 function "*" (Left : Time_Span; Right : Integer) return Time_Span is 44 pragma Unsuppress (Overflow_Check); 45 begin 46 return Time_Span (Duration (Left) * Right); 47 end "*"; 48 49 function "*" (Left : Integer; Right : Time_Span) return Time_Span is 50 pragma Unsuppress (Overflow_Check); 51 begin 52 return Time_Span (Left * Duration (Right)); 53 end "*"; 54 55 --------- 56 -- "+" -- 57 --------- 58 59 -- Note that Constraint_Error may be propagated 60 61 function "+" (Left : Time; Right : Time_Span) return Time is 62 pragma Unsuppress (Overflow_Check); 63 begin 64 return Time (Duration (Left) + Duration (Right)); 65 end "+"; 66 67 function "+" (Left : Time_Span; Right : Time) return Time is 68 pragma Unsuppress (Overflow_Check); 69 begin 70 return Time (Duration (Left) + Duration (Right)); 71 end "+"; 72 73 function "+" (Left, Right : Time_Span) return Time_Span is 74 pragma Unsuppress (Overflow_Check); 75 begin 76 return Time_Span (Duration (Left) + Duration (Right)); 77 end "+"; 78 79 --------- 80 -- "-" -- 81 --------- 82 83 -- Note that Constraint_Error may be propagated 84 85 function "-" (Left : Time; Right : Time_Span) return Time is 86 pragma Unsuppress (Overflow_Check); 87 begin 88 return Time (Duration (Left) - Duration (Right)); 89 end "-"; 90 91 function "-" (Left, Right : Time) return Time_Span is 92 pragma Unsuppress (Overflow_Check); 93 begin 94 return Time_Span (Duration (Left) - Duration (Right)); 95 end "-"; 96 97 function "-" (Left, Right : Time_Span) return Time_Span is 98 pragma Unsuppress (Overflow_Check); 99 begin 100 return Time_Span (Duration (Left) - Duration (Right)); 101 end "-"; 102 103 function "-" (Right : Time_Span) return Time_Span is 104 pragma Unsuppress (Overflow_Check); 105 begin 106 return Time_Span_Zero - Right; 107 end "-"; 108 109 --------- 110 -- "/" -- 111 --------- 112 113 -- Note that Constraint_Error may be propagated 114 115 function "/" (Left, Right : Time_Span) return Integer is 116 pragma Unsuppress (Overflow_Check); 117 begin 118 return Integer (Duration (Left) / Duration (Right)); 119 end "/"; 120 121 function "/" (Left : Time_Span; Right : Integer) return Time_Span is 122 pragma Unsuppress (Overflow_Check); 123 begin 124 return Time_Span (Duration (Left) / Right); 125 end "/"; 126 127 ----------- 128 -- Clock -- 129 ----------- 130 131 function Clock return Time is 132 begin 133 return Time (System.Task_Primitives.Operations.Monotonic_Clock); 134 end Clock; 135 136 ------------------ 137 -- Microseconds -- 138 ------------------ 139 140 function Microseconds (US : Integer) return Time_Span is 141 begin 142 return Time_Span_Unit * US * 1_000; 143 end Microseconds; 144 145 ------------------ 146 -- Milliseconds -- 147 ------------------ 148 149 function Milliseconds (MS : Integer) return Time_Span is 150 begin 151 return Time_Span_Unit * MS * 1_000_000; 152 end Milliseconds; 153 154 ------------- 155 -- Minutes -- 156 ------------- 157 158 function Minutes (M : Integer) return Time_Span is 159 begin 160 return Milliseconds (M) * Integer'(60_000); 161 end Minutes; 162 163 ----------------- 164 -- Nanoseconds -- 165 ----------------- 166 167 function Nanoseconds (NS : Integer) return Time_Span is 168 begin 169 return Time_Span_Unit * NS; 170 end Nanoseconds; 171 172 ------------- 173 -- Seconds -- 174 ------------- 175 176 function Seconds (S : Integer) return Time_Span is 177 begin 178 return Milliseconds (S) * Integer'(1000); 179 end Seconds; 180 181 ----------- 182 -- Split -- 183 ----------- 184 185 procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is 186 T_Val : Time; 187 188 begin 189 -- Special-case for Time_First, whose absolute value is anomalous, 190 -- courtesy of two's complement. 191 192 T_Val := (if T = Time_First then abs (Time_Last) else abs (T)); 193 194 -- Extract the integer part of T, truncating towards zero 195 196 SC := 197 (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5))); 198 199 if T < 0.0 then 200 SC := -SC; 201 end if; 202 203 -- If original time is negative, need to truncate towards negative 204 -- infinity, to make TS non-negative, as per ARM. 205 206 if Time (SC) > T then 207 SC := SC - 1; 208 end if; 209 210 TS := Time_Span (Duration (T) - Duration (SC)); 211 end Split; 212 213 ------------- 214 -- Time_Of -- 215 ------------- 216 217 function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is 218 begin 219 return Time (SC) + TS; 220 end Time_Of; 221 222 ----------------- 223 -- To_Duration -- 224 ----------------- 225 226 function To_Duration (TS : Time_Span) return Duration is 227 begin 228 return Duration (TS); 229 end To_Duration; 230 231 ------------------ 232 -- To_Time_Span -- 233 ------------------ 234 235 function To_Time_Span (D : Duration) return Time_Span is 236 begin 237 -- Note regarding AI-00432 requiring range checking on this conversion. 238 -- In almost all versions of GNAT (and all to which this version of the 239 -- Ada.Real_Time package apply), the range of Time_Span and Duration are 240 -- the same, so there is no issue of overflow. 241 242 return Time_Span (D); 243 end To_Time_Span; 244 245begin 246 -- Ensure that the tasking run time is initialized when using clock and/or 247 -- delay operations. The initialization routine has the required machinery 248 -- to prevent multiple calls to Initialize. 249 250 System.Tasking.Initialize; 251end Ada.Real_Time; 252