1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . C A L E N D A R --
9 -- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
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 2, 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. 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 GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the Windows NT/95 version
36 -- Why do we need separate version ???
37 -- Do we need *this* much code duplication???
39 with System
.OS_Primitives
;
42 with System
.OS_Interface
;
44 package body Ada
.Calendar
is
46 use System
.OS_Interface
;
48 ------------------------------
49 -- Use of Pragma Unsuppress --
50 ------------------------------
52 -- This implementation of Calendar takes advantage of the permission in
53 -- Ada 95 of using arithmetic overflow checks to check for out of bounds
54 -- time values. This means that we must catch the constraint error that
55 -- results from arithmetic overflow, so we use pragma Unsuppress to make
56 -- sure that overflow is enabled, using software overflow checking if
57 -- necessary. That way, compiling Calendar with options to suppress this
58 -- checking will not affect its correctness.
60 ------------------------
61 -- Local Declarations --
62 ------------------------
64 Ada_Year_Min
: constant := 1901;
65 Ada_Year_Max
: constant := 2099;
67 -- Win32 time constants
69 epoch_1970
: constant := 16#
19D_B1DE_D53E_8000#
; -- win32 UTC epoch
70 system_time_ns
: constant := 100; -- 100 ns per tick
71 Sec_Unit
: constant := 10#
1#E9
;
77 function "+" (Left
: Time
; Right
: Duration) return Time
is
78 pragma Unsuppress
(Overflow_Check
);
80 return (Left
+ Time
(Right
));
83 when Constraint_Error
=>
87 function "+" (Left
: Duration; Right
: Time
) return Time
is
88 pragma Unsuppress
(Overflow_Check
);
90 return (Time
(Left
) + Right
);
93 when Constraint_Error
=>
101 function "-" (Left
: Time
; Right
: Duration) return Time
is
102 pragma Unsuppress
(Overflow_Check
);
104 return Left
- Time
(Right
);
107 when Constraint_Error
=>
111 function "-" (Left
: Time
; Right
: Time
) return Duration is
112 pragma Unsuppress
(Overflow_Check
);
114 return Duration (Left
) - Duration (Right
);
117 when Constraint_Error
=>
125 function "<" (Left
, Right
: Time
) return Boolean is
127 return Duration (Left
) < Duration (Right
);
134 function "<=" (Left
, Right
: Time
) return Boolean is
136 return Duration (Left
) <= Duration (Right
);
143 function ">" (Left
, Right
: Time
) return Boolean is
145 return Duration (Left
) > Duration (Right
);
152 function ">=" (Left
, Right
: Time
) return Boolean is
154 return Duration (Left
) >= Duration (Right
);
161 -- The Ada.Calendar.Clock function gets the time from the soft links
162 -- interface which will call the appropriate function depending wether
163 -- tasking is involved or not.
165 function Clock
return Time
is
167 return Time
(System
.OS_Primitives
.Clock
);
174 function Day
(Date
: Time
) return Day_Number
is
180 Split
(Date
, DY
, DM
, DD
, DS
);
188 function Month
(Date
: Time
) return Month_Number
is
195 Split
(Date
, DY
, DM
, DD
, DS
);
203 function Seconds
(Date
: Time
) return Day_Duration
is
209 Split
(Date
, DY
, DM
, DD
, DS
);
219 Year
: out Year_Number
;
220 Month
: out Month_Number
;
221 Day
: out Day_Number
;
222 Seconds
: out Day_Duration
)
225 Date_Int
: aliased Long_Long_Integer;
226 Date_Loc
: aliased Long_Long_Integer;
227 Timbuf
: aliased SYSTEMTIME
;
228 Int_Date
: Long_Long_Integer;
229 Sub_Seconds
: Duration;
232 -- We take the sub-seconds (decimal part) of Date and this is added
233 -- to compute the Seconds. This way we keep the precision of the
234 -- high-precision clock that was lost with the Win32 API calls
239 -- this is a Date before Epoch (January 1st, 1970)
241 Sub_Seconds
:= Duration (Date
) -
242 Duration (Long_Long_Integer (Date
+ Duration'(0.5)));
244 Int_Date := Long_Long_Integer (Date - Sub_Seconds);
246 -- For Date = -86400.1 we are 2 days before Epoch at 0.1 seconds
247 -- from day 1 before Epoch. It means that it is 23h 59m 59.9s.
248 -- here we adjust for that.
250 if Sub_Seconds < 0.0 then
251 Int_Date := Int_Date - 1;
252 Sub_Seconds := 1.0 + Sub_Seconds;
257 -- this is a Date after Epoch (January 1st, 1970)
259 Sub_Seconds := Duration (Date) -
260 Duration (Long_Long_Integer (Date - Duration'(0.5)));
262 Int_Date
:= Long_Long_Integer (Date
- Sub_Seconds
);
266 -- Date_Int is the number of seconds from Epoch
268 Date_Int
:= Long_Long_Integer
269 (Int_Date
* Sec_Unit
/ system_time_ns
) + epoch_1970
;
271 if not FileTimeToLocalFileTime
(Date_Int
'Access, Date_Loc
'Access) then
275 if not FileTimeToSystemTime
(Date_Loc
'Access, Timbuf
'Access) then
279 if Timbuf
.wYear
not in Ada_Year_Min
.. Ada_Year_Max
then
284 Duration (Timbuf
.wHour
) * 3_600
.0
+
285 Duration (Timbuf
.wMinute
) * 60.0 +
286 Duration (Timbuf
.wSecond
) +
289 Day
:= Integer (Timbuf
.wDay
);
290 Month
:= Integer (Timbuf
.wMonth
);
291 Year
:= Integer (Timbuf
.wYear
);
300 Month
: Month_Number
;
302 Seconds
: Day_Duration
:= 0.0)
306 Timbuf
: aliased SYSTEMTIME
;
307 Now
: aliased Long_Long_Integer;
308 Loc
: aliased Long_Long_Integer;
311 Add_One_Day
: Boolean := False;
315 -- The following checks are redundant with respect to the constraint
316 -- error checks that should normally be made on parameters, but we
317 -- decide to raise Constraint_Error in any case if bad values come
318 -- in (as a result of checks being off in the caller, or for other
319 -- erroneous or bounded error cases).
322 or else not Month 'Valid
323 or else not Day
'Valid
324 or else not Seconds'Valid
326 raise Constraint_Error;
329 if Seconds = 0.0 then
332 Int_Secs := Integer (Seconds - 0.5);
335 -- Timbuf.wMillisec is to keep the msec. We can't use that because the
336 -- high-resolution clock has a precision of 1 Microsecond.
337 -- Anyway the sub-seconds part is not needed to compute the number
338 -- of seconds in UTC.
340 if Int_Secs = 86_400 then
347 Timbuf.wMilliseconds := 0;
348 Timbuf.wSecond := WORD (Secs mod 60);
349 Timbuf.wMinute := WORD ((Secs / 60) mod 60);
350 Timbuf.wHour := WORD (Secs / 3600);
351 Timbuf.wDay := WORD (Day);
352 Timbuf.wMonth := WORD (Month);
353 Timbuf.wYear := WORD (Year);
355 if not SystemTimeToFileTime (Timbuf'Access, Loc'Access) then
359 if not LocalFileTimeToFileTime (Loc'Access, Now'Access) then
363 -- Here we have the UTC now translate UTC to Epoch time (UNIX style
364 -- time based on 1 january 1970) and add there the sub-seconds part.
367 Sub_Sec : constant Duration := Seconds - Duration (Int_Secs);
369 Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) +
374 Date := Date + Duration (86400.0);
384 function Year (Date : Time) return Year_Number is
391 Split (Date, DY, DM, DD, DS);
396 System.OS_Primitives.Initialize;