2014-09-15 Andreas Krebbel <Andreas.Krebbel@de.ibm.com>
[official-gcc.git] / gcc / ada / a-reatim.adb
blobef0632bc5bc1058b407734b49db0b83cabe9824d
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 ------------------------------------------------------------------------------
33 with System.Tasking;
35 package body Ada.Real_Time is
37 ---------
38 -- "*" --
39 ---------
41 -- Note that Constraint_Error may be propagated
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 "*";
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 "*";
55 ---------
56 -- "+" --
57 ---------
59 -- Note that Constraint_Error may be propagated
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 "+";
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 "+";
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 "+";
79 ---------
80 -- "-" --
81 ---------
83 -- Note that Constraint_Error may be propagated
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 "-";
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 "-";
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 "-";
103 function "-" (Right : Time_Span) return Time_Span is
104 pragma Unsuppress (Overflow_Check);
105 begin
106 return Time_Span_Zero - Right;
107 end "-";
109 ---------
110 -- "/" --
111 ---------
113 -- Note that Constraint_Error may be propagated
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 "/";
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 "/";
127 -----------
128 -- Clock --
129 -----------
131 function Clock return Time is
132 begin
133 return Time (System.Task_Primitives.Operations.Monotonic_Clock);
134 end Clock;
136 ------------------
137 -- Microseconds --
138 ------------------
140 function Microseconds (US : Integer) return Time_Span is
141 begin
142 return Time_Span_Unit * US * 1_000;
143 end Microseconds;
145 ------------------
146 -- Milliseconds --
147 ------------------
149 function Milliseconds (MS : Integer) return Time_Span is
150 begin
151 return Time_Span_Unit * MS * 1_000_000;
152 end Milliseconds;
154 -------------
155 -- Minutes --
156 -------------
158 function Minutes (M : Integer) return Time_Span is
159 begin
160 return Milliseconds (M) * Integer'(60_000);
161 end Minutes;
163 -----------------
164 -- Nanoseconds --
165 -----------------
167 function Nanoseconds (NS : Integer) return Time_Span is
168 begin
169 return Time_Span_Unit * NS;
170 end Nanoseconds;
172 -------------
173 -- Seconds --
174 -------------
176 function Seconds (S : Integer) return Time_Span is
177 begin
178 return Milliseconds (S) * Integer'(1000);
179 end Seconds;
181 -----------
182 -- Split --
183 -----------
185 procedure Split (T : Time; SC : out Seconds_Count; TS : out Time_Span) is
186 T_Val : Time;
188 begin
189 -- Special-case for Time_First, whose absolute value is anomalous,
190 -- courtesy of two's complement.
192 T_Val := (if T = Time_First then abs (Time_Last) else abs (T));
194 -- Extract the integer part of T, truncating towards zero
196 SC :=
197 (if T_Val < 0.5 then 0 else Seconds_Count (Time_Span'(T_Val - 0.5)));
199 if T < 0.0 then
200 SC := -SC;
201 end if;
203 -- If original time is negative, need to truncate towards negative
204 -- infinity, to make TS non-negative, as per ARM.
206 if Time (SC) > T then
207 SC := SC - 1;
208 end if;
210 TS := Time_Span (Duration (T) - Duration (SC));
211 end Split;
213 -------------
214 -- Time_Of --
215 -------------
217 function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
218 begin
219 return Time (SC) + TS;
220 end Time_Of;
222 -----------------
223 -- To_Duration --
224 -----------------
226 function To_Duration (TS : Time_Span) return Duration is
227 begin
228 return Duration (TS);
229 end To_Duration;
231 ------------------
232 -- To_Time_Span --
233 ------------------
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.
242 return Time_Span (D);
243 end To_Time_Span;
245 begin
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.
250 System.Tasking.Initialize;
251 end Ada.Real_Time;