1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- A D A . R E A L _ T I M E --
9 -- Copyright (C) 1991-2002, Florida State University --
11 -- GNARL 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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. It is --
30 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
32 ------------------------------------------------------------------------------
34 with System
.Task_Primitives
.Operations
;
35 -- used for Monotonic_Clock
37 package body Ada
.Real_Time
is
43 -- Note that Constraint_Error may be propagated
45 function "*" (Left
: Time_Span
; Right
: Integer) return Time_Span
is
46 pragma Unsuppress
(Overflow_Check
);
48 return Time_Span
(Duration (Left
) * Right
);
51 function "*" (Left
: Integer; Right
: Time_Span
) return Time_Span
is
52 pragma Unsuppress
(Overflow_Check
);
54 return Time_Span
(Left
* Duration (Right
));
61 -- Note that Constraint_Error may be propagated
63 function "+" (Left
: Time
; Right
: Time_Span
) return Time
is
64 pragma Unsuppress
(Overflow_Check
);
66 return Time
(Duration (Left
) + Duration (Right
));
69 function "+" (Left
: Time_Span
; Right
: Time
) return Time
is
70 pragma Unsuppress
(Overflow_Check
);
72 return Time
(Duration (Left
) + Duration (Right
));
75 function "+" (Left
, Right
: Time_Span
) return Time_Span
is
76 pragma Unsuppress
(Overflow_Check
);
78 return Time_Span
(Duration (Left
) + Duration (Right
));
85 -- Note that Constraint_Error may be propagated
87 function "-" (Left
: Time
; Right
: Time_Span
) return Time
is
88 pragma Unsuppress
(Overflow_Check
);
90 return Time
(Duration (Left
) - Duration (Right
));
93 function "-" (Left
, Right
: Time
) return Time_Span
is
94 pragma Unsuppress
(Overflow_Check
);
96 return Time_Span
(Duration (Left
) - Duration (Right
));
99 function "-" (Left
, Right
: Time_Span
) return Time_Span
is
100 pragma Unsuppress
(Overflow_Check
);
102 return Time_Span
(Duration (Left
) - Duration (Right
));
105 function "-" (Right
: Time_Span
) return Time_Span
is
106 pragma Unsuppress
(Overflow_Check
);
108 return Time_Span_Zero
- Right
;
115 -- Note that Constraint_Error may be propagated
117 function "/" (Left
, Right
: Time_Span
) return Integer is
118 pragma Unsuppress
(Overflow_Check
);
120 return Integer (Duration (Left
) / Duration (Right
));
123 function "/" (Left
: Time_Span
; Right
: Integer) return Time_Span
is
124 pragma Unsuppress
(Overflow_Check
);
126 return Time_Span
(Duration (Left
) / Right
);
133 function Clock
return Time
is
135 return Time
(System
.Task_Primitives
.Operations
.Monotonic_Clock
);
142 function Microseconds
(US
: Integer) return Time_Span
is
144 return Time_Span_Unit
* US
* 1_000
;
151 function Milliseconds
(MS
: Integer) return Time_Span
is
153 return Time_Span_Unit
* MS
* 1_000_000
;
160 function Nanoseconds
(NS
: Integer) return Time_Span
is
162 return Time_Span_Unit
* NS
;
169 procedure Split
(T
: Time
; SC
: out Seconds_Count
; TS
: out Time_Span
) is
173 -- Special-case for Time_First, whose absolute value is anomalous,
174 -- courtesy of two's complement.
176 if T
= Time_First
then
177 T_Val
:= abs (Time_Last
);
182 -- Extract the integer part of T, truncating towards zero.
187 SC
:= Seconds_Count
(Time_Span
' (T_Val - 0.5));
194 -- If original time is negative, need to truncate towards negative
195 -- infinity, to make TS non-negative, as per ARM.
197 if Time (SC) > T then
201 TS := Time_Span (Duration (T) - Duration (SC));
208 function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is
210 return Time (SC) + TS;
217 function To_Duration (TS : Time_Span) return Duration is
219 return Duration (TS);
226 function To_Time_Span (D : Duration) return Time_Span is
228 return Time_Span (D);