1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . C A L E N D A R --
9 -- Copyright (C) 1992-2006, 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 with Unchecked_Conversion
;
36 with System
.OS_Primitives
;
39 package body Ada
.Calendar
is
41 ------------------------------
42 -- Use of Pragma Unsuppress --
43 ------------------------------
45 -- This implementation of Calendar takes advantage of the permission in
46 -- Ada 95 of using arithmetic overflow checks to check for out of bounds
47 -- time values. This means that we must catch the constraint error that
48 -- results from arithmetic overflow, so we use pragma Unsuppress to make
49 -- sure that overflow is enabled, using software overflow checking if
50 -- necessary. That way, compiling Calendar with options to suppress this
51 -- checking will not affect its correctness.
53 ------------------------
54 -- Local Declarations --
55 ------------------------
57 type char_Pointer
is access Character;
58 subtype int
is Integer;
59 subtype long
is Long_Integer;
60 type long_Pointer
is access all long
;
61 -- Synonyms for C types. We don't want to get them from Interfaces.C
62 -- because there is no point in loading that unit just for calendar.
65 tm_sec
: int
; -- seconds after the minute (0 .. 60)
66 tm_min
: int
; -- minutes after the hour (0 .. 59)
67 tm_hour
: int
; -- hours since midnight (0 .. 24)
68 tm_mday
: int
; -- day of the month (1 .. 31)
69 tm_mon
: int
; -- months since January (0 .. 11)
70 tm_year
: int
; -- years since 1900
71 tm_wday
: int
; -- days since Sunday (0 .. 6)
72 tm_yday
: int
; -- days since January 1 (0 .. 365)
73 tm_isdst
: int
; -- Daylight Savings Time flag (-1 .. +1)
74 tm_gmtoff
: long
; -- offset from CUT in seconds
75 tm_zone
: char_Pointer
; -- timezone abbreviation
78 type tm_Pointer
is access all tm
;
80 subtype time_t
is long
;
82 type time_t_Pointer
is access all time_t
;
84 procedure localtime_tzoff
88 pragma Import
(C
, localtime_tzoff
, "__gnat_localtime_tzoff");
89 -- This is a lightweight wrapper around the system library localtime_r
90 -- function. Parameter 'off' captures the UTC offset which is either
91 -- retrieved from the tm struct or calculated from the 'timezone' extern
92 -- and the tm_isdst flag in the tm struct.
94 function mktime
(TM
: tm_Pointer
) return time_t
;
95 pragma Import
(C
, mktime
);
96 -- mktime returns -1 in case the calendar time given by components of
97 -- TM.all cannot be represented.
99 -- The following constants are used in adjusting Ada dates so that they
100 -- fit into a 56 year range that can be handled by Unix (1970 included -
101 -- 2026 excluded). Dates that are not in this 56 year range are shifted
102 -- by multiples of 56 years to fit in this range.
104 -- The trick is that the number of days in any four year period in the Ada
105 -- range of years (1901 - 2099) has a constant number of days. This is
106 -- because we have the special case of 2000 which, contrary to the normal
107 -- exception for centuries, is a leap year after all. 56 has been chosen,
108 -- because it is not only a multiple of 4, but also a multiple of 7. Thus
109 -- two dates 56 years apart fall on the same day of the week, and the
110 -- Daylight Saving Time change dates are usually the same for these two
113 Unix_Year_Min
: constant := 1970;
114 Unix_Year_Max
: constant := 2026;
116 Ada_Year_Min
: constant := 1901;
117 Ada_Year_Max
: constant := 2099;
119 -- Some basic constants used throughout
121 Days_In_Month
: constant array (Month_Number
) of Day_Number
:=
122 (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
124 Days_In_4_Years
: constant := 365 * 3 + 366;
125 Seconds_In_4_Years
: constant := 86_400
* Days_In_4_Years
;
126 Seconds_In_56_Years
: constant := Seconds_In_4_Years
* 14;
127 Seconds_In_56_YearsD
: constant := Duration (Seconds_In_56_Years
);
133 function "+" (Left
: Time
; Right
: Duration) return Time
is
134 pragma Unsuppress
(Overflow_Check
);
136 return (Left
+ Time
(Right
));
138 when Constraint_Error
=>
142 function "+" (Left
: Duration; Right
: Time
) return Time
is
143 pragma Unsuppress
(Overflow_Check
);
145 return (Time
(Left
) + Right
);
147 when Constraint_Error
=>
155 function "-" (Left
: Time
; Right
: Duration) return Time
is
156 pragma Unsuppress
(Overflow_Check
);
158 return Left
- Time
(Right
);
160 when Constraint_Error
=>
164 function "-" (Left
: Time
; Right
: Time
) return Duration is
165 pragma Unsuppress
(Overflow_Check
);
167 return Duration (Left
) - Duration (Right
);
169 when Constraint_Error
=>
177 function "<" (Left
, Right
: Time
) return Boolean is
179 return Duration (Left
) < Duration (Right
);
186 function "<=" (Left
, Right
: Time
) return Boolean is
188 return Duration (Left
) <= Duration (Right
);
195 function ">" (Left
, Right
: Time
) return Boolean is
197 return Duration (Left
) > Duration (Right
);
204 function ">=" (Left
, Right
: Time
) return Boolean is
206 return Duration (Left
) >= Duration (Right
);
213 function Clock
return Time
is
215 return Time
(System
.OS_Primitives
.Clock
);
222 function Day
(Date
: Time
) return Day_Number
is
228 Split
(Date
, DY
, DM
, DD
, DS
);
236 function Month
(Date
: Time
) return Month_Number
is
242 Split
(Date
, DY
, DM
, DD
, DS
);
250 function Seconds
(Date
: Time
) return Day_Duration
is
256 Split
(Date
, DY
, DM
, DD
, DS
);
266 Year
: out Year_Number
;
267 Month
: out Month_Number
;
268 Day
: out Day_Number
;
269 Seconds
: out Day_Duration
)
271 Offset
: Long_Integer;
274 Split_With_Offset
(Date
, Year
, Month
, Day
, Seconds
, Offset
);
277 -----------------------
278 -- Split_With_Offset --
279 -----------------------
281 procedure Split_With_Offset
283 Year
: out Year_Number
;
284 Month
: out Month_Number
;
285 Day
: out Day_Number
;
286 Seconds
: out Day_Duration
;
287 Offset
: out Long_Integer)
289 -- The following declare bounds for duration that are comfortably
290 -- wider than the maximum allowed output result for the Ada range
291 -- of representable split values. These are used for a quick check
292 -- that the value is not wildly out of range.
294 Low
: constant := (Ada_Year_Min
- Unix_Year_Min
- 2) * 365 * 86_400
;
295 High
: constant := (Ada_Year_Max
- Unix_Year_Min
+ 2) * 365 * 86_400
;
297 LowD
: constant Duration := Duration (Low
);
298 HighD
: constant Duration := Duration (High
);
300 -- Finally the actual variables used in the computation
302 Adjusted_Seconds
: aliased time_t
;
305 Local_Offset
: aliased long
;
310 -- For us a time is simply a signed duration value, so we work with
311 -- this duration value directly. Note that it can be negative.
313 D
:= Duration (Date
);
315 -- First of all, filter out completely ludicrous values. Remember that
316 -- we use the full stored range of duration values, which may be
317 -- significantly larger than the allowed range of Ada times. Note that
318 -- these checks are wider than required to make absolutely sure that
319 -- there are no end effects from time zone differences.
321 if D
< LowD
or else D
> HighD
then
325 -- The unix localtime_r function is more or less exactly what we need
326 -- here. The less comes from the fact that it does not support the
327 -- required range of years (the guaranteed range available is only
328 -- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1.
330 -- If we have a value outside this range, then we first adjust it to be
331 -- in the required range by adding multiples of 56 years. For the range
332 -- we are interested in, the number of days in any consecutive 56 year
333 -- period is constant. Then we do the split on the adjusted value, and
334 -- readjust the years value accordingly.
339 D
:= D
+ Seconds_In_56_YearsD
;
340 Year_Val
:= Year_Val
- 56;
343 while D
>= Seconds_In_56_YearsD
loop
344 D
:= D
- Seconds_In_56_YearsD
;
345 Year_Val
:= Year_Val
+ 56;
348 -- Now we need to take the value D, which is now non-negative, and
349 -- break it down into seconds (to pass to the localtime_r function) and
350 -- fractions of seconds (for the adjustment below).
352 -- Surprisingly there is no easy way to do this in Ada, and certainly
353 -- no easy way to do it and generate efficient code. Therefore we do it
354 -- at a low level, knowing that it is really represented as an integer
355 -- with units of Small
358 type D_Int
is range 0 .. 2 ** (Duration'Size - 1) - 1;
359 for D_Int
'Size use Duration'Size;
361 function To_D_Int
is new Unchecked_Conversion
(Duration, D_Int
);
362 function To_Duration
is new Unchecked_Conversion
(D_Int
, Duration);
364 D_As_Int
: constant D_Int
:= To_D_Int
(D
);
365 Small_Div
: constant D_Int
:= D_Int
(1.0 / Duration'Small);
368 Adjusted_Seconds
:= time_t
(D_As_Int
/ Small_Div
);
369 Frac_Sec
:= To_Duration
(D_As_Int
rem Small_Div
);
373 (Adjusted_Seconds
'Unchecked_Access,
374 Tm_Val
'Unchecked_Access,
375 Local_Offset
'Unchecked_Access);
377 Year_Val
:= Tm_Val
.tm_year
+ 1900 + Year_Val
;
378 Month
:= Tm_Val
.tm_mon
+ 1;
379 Day
:= Tm_Val
.tm_mday
;
380 Offset
:= Long_Integer (Local_Offset
);
382 -- The Seconds value is a little complex. The localtime function
383 -- returns the integral number of seconds, which is what we want, but
384 -- we want to retain the fractional part from the original Time value,
385 -- since this is typically stored more accurately.
387 Seconds
:= Duration (Tm_Val
.tm_hour
* 3600 +
392 -- Note: the above expression is pretty horrible, one of these days we
393 -- should stop using time_of and do everything ourselves to avoid these
394 -- unnecessary divides and multiplies???.
396 -- The Year may still be out of range, since our entry test was
397 -- deliberately crude. Trying to make this entry test accurate is
398 -- tricky due to time zone adjustment issues affecting the exact
399 -- boundary. It is interesting to note that whether or not a given
400 -- Calendar.Time value gets Time_Error when split depends on the
401 -- current time zone setting.
403 if Year_Val
not in Ada_Year_Min
.. Ada_Year_Max
then
408 end Split_With_Offset
;
416 Month
: Month_Number
;
418 Seconds
: Day_Duration
:= 0.0)
421 Result_Secs
: aliased time_t
;
423 Int_Secs
: constant Integer := Integer (Seconds
);
425 Year_Val
: Integer := Year
;
426 Duration_Adjust
: Duration := 0.0;
429 -- The following checks are redundant with respect to the constraint
430 -- error checks that should normally be made on parameters, but we
431 -- decide to raise Constraint_Error in any case if bad values come in
432 -- (as a result of checks being off in the caller, or for other
433 -- erroneous or bounded error cases).
436 or else not Month 'Valid
437 or else not Day
'Valid
438 or else not Seconds'Valid
440 raise Constraint_Error;
443 -- Check for Day value too large (one might expect mktime to do this
444 -- check, as well as the basic checks we did with 'Valid
, but it seems
445 -- that at least on some systems, this built-in check is too weak).
447 if Day
> Days_In_Month
(Month
)
448 and then (Day
/= 29 or Month
/= 2 or Year
mod 4 /= 0)
453 TM_Val
.tm_sec
:= Int_Secs
mod 60;
454 TM_Val
.tm_min
:= (Int_Secs
/ 60) mod 60;
455 TM_Val
.tm_hour
:= (Int_Secs
/ 60) / 60;
456 TM_Val
.tm_mday
:= Day
;
457 TM_Val
.tm_mon
:= Month
- 1;
459 -- For the year, we have to adjust it to a year that Unix can handle.
460 -- We do this in 56 year steps, since the number of days in 56 years is
461 -- constant, so the timezone effect on the conversion from local time
462 -- to GMT is unaffected; also the DST change dates are usually not
465 while Year_Val
< Unix_Year_Min
loop
466 Year_Val
:= Year_Val
+ 56;
467 Duration_Adjust
:= Duration_Adjust
- Seconds_In_56_YearsD
;
470 while Year_Val
>= Unix_Year_Max
loop
471 Year_Val
:= Year_Val
- 56;
472 Duration_Adjust
:= Duration_Adjust
+ Seconds_In_56_YearsD
;
475 TM_Val
.tm_year
:= Year_Val
- 1900;
477 -- If time is very close to UNIX epoch mktime may behave uncorrectly
478 -- because of the way the different time zones are handled (a date
479 -- after epoch in a given time zone may correspond to a GMT date
480 -- before epoch). Adding one day to the date (this amount is latter
481 -- substracted) avoids this problem.
483 if Year_Val
= Unix_Year_Min
487 TM_Val
.tm_mday
:= TM_Val
.tm_mday
+ 1;
488 Duration_Adjust
:= Duration_Adjust
- Duration (86400.0);
491 -- Since we do not have information on daylight savings, rely on the
492 -- default information.
494 TM_Val
.tm_isdst
:= -1;
495 Result_Secs
:= mktime
(TM_Val
'Unchecked_Access);
497 -- That gives us the basic value in seconds. Two adjustments are
498 -- needed. First we must undo the year adjustment carried out above.
499 -- Second we put back the fraction seconds value since in general the
500 -- Day_Duration value we received has additional precision which we do
501 -- not want to lose in the constructed result.
504 Time
(Duration (Result_Secs
) +
506 (Seconds
- Duration (Int_Secs
)));
513 function Year
(Date
: Time
) return Year_Number
is
519 Split
(Date
, DY
, DM
, DD
, DS
);
527 -- The package that is used by the Ada 2005 children of Ada.Calendar:
528 -- Ada.Calendar.Arithmetic and Ada.Calendar.Formatting.
530 package body Leap_Sec_Ops
is
532 -- This package must be updated when leap seconds are added. Adding a
533 -- leap second requires incrementing the value of N_Leap_Secs and adding
534 -- the day of the new leap second to the end of Leap_Second_Dates.
536 -- Elaboration of the Leap_Sec_Ops package takes care of converting the
537 -- Leap_Second_Dates table to a form that is better suited for the
538 -- procedures provided by this package (a table that would be more
539 -- difficult to maintain by hand).
541 N_Leap_Secs
: constant := 23;
543 type Leap_Second_Date
is record
545 Month
: Month_Number
;
550 constant array (1 .. N_Leap_Secs
) of Leap_Second_Date
:=
551 ((1972, 6, 30), (1972, 12, 31), (1973, 12, 31), (1974, 12, 31),
552 (1975, 12, 31), (1976, 12, 31), (1977, 12, 31), (1978, 12, 31),
553 (1979, 12, 31), (1981, 6, 30), (1982, 6, 30), (1983, 6, 30),
554 (1985, 6, 30), (1987, 12, 31), (1989, 12, 31), (1990, 12, 31),
555 (1992, 6, 30), (1993, 6, 30), (1994, 6, 30), (1995, 12, 31),
556 (1997, 6, 30), (1998, 12, 31), (2005, 12, 31));
558 Leap_Second_Times
: array (1 .. N_Leap_Secs
) of Time
;
559 -- This is the needed internal representation that is calculated
560 -- from Leap_Second_Dates during elaboration;
562 --------------------------
563 -- Cumulative_Leap_Secs --
564 --------------------------
566 procedure Cumulative_Leap_Secs
569 Leaps_Between
: out Duration;
570 Next_Leap_Sec
: out Time
)
574 Leap_Index
: Positive;
578 type D_Int
is range 0 .. 2 ** (Duration'Size - 1) - 1;
579 for D_Int
'Size use Duration'Size;
581 Small_Div
: constant D_Int
:= D_Int
(1.0 / Duration'Small);
584 function To_D_As_Int
is new Unchecked_Conversion
(Duration, D_Int
);
587 Next_Leap_Sec
:= After_Last_Leap
;
589 -- We want to throw away the fractional part of seconds. Before
590 -- proceding with this operation, make sure our working values
593 if End_Date
< 0.0 then
594 Leaps_Between
:= 0.0;
598 if Start_Date
< 0.0 then
599 Start_Tmp
:= Time
(0.0);
601 Start_Tmp
:= Start_Date
;
604 if Start_Date
<= Leap_Second_Times
(N_Leap_Secs
) then
606 -- Manipulate the fixed point value as an integer, similar to
607 -- Ada.Calendar.Split in order to remove the fractional part
608 -- from the time we will work with, Start_T and End_T.
610 D_As_Int
:= To_D_As_Int
(Duration (Start_Tmp
));
611 D_As_Int
:= D_As_Int
/ Small_Div
;
612 Start_T
:= Time
(D_As_Int
);
613 D_As_Int
:= To_D_As_Int
(Duration (End_Date
));
614 D_As_Int
:= D_As_Int
/ Small_Div
;
615 End_T
:= Time
(D_As_Int
);
619 exit when Leap_Second_Times
(Leap_Index
) >= Start_T
;
620 Leap_Index
:= Leap_Index
+ 1;
625 exit when K
> N_Leap_Secs
or else
626 Leap_Second_Times
(K
) >= End_T
;
630 if K
<= N_Leap_Secs
then
631 Next_Leap_Sec
:= Leap_Second_Times
(K
);
634 Leaps_Between
:= Duration (K
- Leap_Index
);
636 Leaps_Between
:= Duration (0.0);
638 end Cumulative_Leap_Secs
;
640 ----------------------
641 -- All_Leap_Seconds --
642 ----------------------
644 function All_Leap_Seconds
return Duration is
646 return Duration (N_Leap_Secs
);
647 -- Presumes each leap second is +1.0 second;
648 end All_Leap_Seconds
;
650 -- Start of processing in package Leap_Sec_Ops
655 Is_Leap_Year
: Boolean;
658 Cumulative_Days_Before_Month
:
659 constant array (Month_Number
) of Natural :=
660 (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
662 for J
in 1 .. N_Leap_Secs
loop
663 Years
:= Leap_Second_Dates
(J
).Year
- Unix_Year_Min
;
664 Days
:= (Years
/ 4) * Days_In_4_Years
;
665 Years
:= Years
mod 4;
666 Is_Leap_Year
:= False;
672 Is_Leap_Year
:= True;
674 -- 1972 or multiple of 4 after
676 Days
:= Days
+ 365 * 2;
679 Days
:= Days
+ 365 * 3 + 1;
682 Days
:= Days
+ Cumulative_Days_Before_Month
683 (Leap_Second_Dates
(J
).Month
);
686 and then Leap_Second_Dates
(J
).Month
> 2
691 Days
:= Days
+ Leap_Second_Dates
(J
).Day
;
693 Leap_Second_Times
(J
) :=
694 Time
(Days
* Duration (86_400
.0
) + Duration (J
- 1));
696 -- Add one to get to the leap second. Add J - 1 previous
704 System
.OS_Primitives
.Initialize
;