Makefile.in: Rebuilt.
[official-gcc.git] / gcc / ada / a-calend.adb
blob02851ad50b32c23b1ffa90c508e06aa9b469c4ad
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . C A L E N D A R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
10 -- --
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. --
21 -- --
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. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Unchecked_Conversion;
36 with System.OS_Primitives;
37 -- used for Clock
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.
64 type tm is record
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
76 end record;
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
85 (C : time_t_Pointer;
86 res : tm_Pointer;
87 off : long_Pointer);
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
111 -- years.
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);
129 ---------
130 -- "+" --
131 ---------
133 function "+" (Left : Time; Right : Duration) return Time is
134 pragma Unsuppress (Overflow_Check);
135 begin
136 return (Left + Time (Right));
137 exception
138 when Constraint_Error =>
139 raise Time_Error;
140 end "+";
142 function "+" (Left : Duration; Right : Time) return Time is
143 pragma Unsuppress (Overflow_Check);
144 begin
145 return (Time (Left) + Right);
146 exception
147 when Constraint_Error =>
148 raise Time_Error;
149 end "+";
151 ---------
152 -- "-" --
153 ---------
155 function "-" (Left : Time; Right : Duration) return Time is
156 pragma Unsuppress (Overflow_Check);
157 begin
158 return Left - Time (Right);
159 exception
160 when Constraint_Error =>
161 raise Time_Error;
162 end "-";
164 function "-" (Left : Time; Right : Time) return Duration is
165 pragma Unsuppress (Overflow_Check);
166 begin
167 return Duration (Left) - Duration (Right);
168 exception
169 when Constraint_Error =>
170 raise Time_Error;
171 end "-";
173 ---------
174 -- "<" --
175 ---------
177 function "<" (Left, Right : Time) return Boolean is
178 begin
179 return Duration (Left) < Duration (Right);
180 end "<";
182 ----------
183 -- "<=" --
184 ----------
186 function "<=" (Left, Right : Time) return Boolean is
187 begin
188 return Duration (Left) <= Duration (Right);
189 end "<=";
191 ---------
192 -- ">" --
193 ---------
195 function ">" (Left, Right : Time) return Boolean is
196 begin
197 return Duration (Left) > Duration (Right);
198 end ">";
200 ----------
201 -- ">=" --
202 ----------
204 function ">=" (Left, Right : Time) return Boolean is
205 begin
206 return Duration (Left) >= Duration (Right);
207 end ">=";
209 -----------
210 -- Clock --
211 -----------
213 function Clock return Time is
214 begin
215 return Time (System.OS_Primitives.Clock);
216 end Clock;
218 ---------
219 -- Day --
220 ---------
222 function Day (Date : Time) return Day_Number is
223 DY : Year_Number;
224 DM : Month_Number;
225 DD : Day_Number;
226 DS : Day_Duration;
227 begin
228 Split (Date, DY, DM, DD, DS);
229 return DD;
230 end Day;
232 -----------
233 -- Month --
234 -----------
236 function Month (Date : Time) return Month_Number is
237 DY : Year_Number;
238 DM : Month_Number;
239 DD : Day_Number;
240 DS : Day_Duration;
241 begin
242 Split (Date, DY, DM, DD, DS);
243 return DM;
244 end Month;
246 -------------
247 -- Seconds --
248 -------------
250 function Seconds (Date : Time) return Day_Duration is
251 DY : Year_Number;
252 DM : Month_Number;
253 DD : Day_Number;
254 DS : Day_Duration;
255 begin
256 Split (Date, DY, DM, DD, DS);
257 return DS;
258 end Seconds;
260 -----------
261 -- Split --
262 -----------
264 procedure Split
265 (Date : Time;
266 Year : out Year_Number;
267 Month : out Month_Number;
268 Day : out Day_Number;
269 Seconds : out Day_Duration)
271 Offset : Long_Integer;
273 begin
274 Split_With_Offset (Date, Year, Month, Day, Seconds, Offset);
275 end Split;
277 -----------------------
278 -- Split_With_Offset --
279 -----------------------
281 procedure Split_With_Offset
282 (Date : Time;
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;
303 D : Duration;
304 Frac_Sec : Duration;
305 Local_Offset : aliased long;
306 Tm_Val : aliased tm;
307 Year_Val : Integer;
309 begin
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
322 raise Time_Error;
323 end if;
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.
336 Year_Val := 0;
338 while D < 0.0 loop
339 D := D + Seconds_In_56_YearsD;
340 Year_Val := Year_Val - 56;
341 end loop;
343 while D >= Seconds_In_56_YearsD loop
344 D := D - Seconds_In_56_YearsD;
345 Year_Val := Year_Val + 56;
346 end loop;
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
357 declare
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);
367 begin
368 Adjusted_Seconds := time_t (D_As_Int / Small_Div);
369 Frac_Sec := To_Duration (D_As_Int rem Small_Div);
370 end;
372 localtime_tzoff
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 +
388 Tm_Val.tm_min * 60 +
389 Tm_Val.tm_sec)
390 + Frac_Sec;
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
404 raise Time_Error;
405 else
406 Year := Year_Val;
407 end if;
408 end Split_With_Offset;
410 -------------
411 -- Time_Of --
412 -------------
414 function Time_Of
415 (Year : Year_Number;
416 Month : Month_Number;
417 Day : Day_Number;
418 Seconds : Day_Duration := 0.0)
419 return Time
421 Result_Secs : aliased time_t;
422 TM_Val : aliased tm;
423 Int_Secs : constant Integer := Integer (Seconds);
425 Year_Val : Integer := Year;
426 Duration_Adjust : Duration := 0.0;
428 begin
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).
435 if not Year 'Valid
436 or else not Month 'Valid
437 or else not Day 'Valid
438 or else not Seconds'Valid
439 then
440 raise Constraint_Error;
441 end if;
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)
449 then
450 raise Time_Error;
451 end if;
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
463 -- modified.
465 while Year_Val < Unix_Year_Min loop
466 Year_Val := Year_Val + 56;
467 Duration_Adjust := Duration_Adjust - Seconds_In_56_YearsD;
468 end loop;
470 while Year_Val >= Unix_Year_Max loop
471 Year_Val := Year_Val - 56;
472 Duration_Adjust := Duration_Adjust + Seconds_In_56_YearsD;
473 end loop;
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
484 and then Month = 1
485 and then Day = 1
486 then
487 TM_Val.tm_mday := TM_Val.tm_mday + 1;
488 Duration_Adjust := Duration_Adjust - Duration (86400.0);
489 end if;
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.
503 return
504 Time (Duration (Result_Secs) +
505 Duration_Adjust +
506 (Seconds - Duration (Int_Secs)));
507 end Time_Of;
509 ----------
510 -- Year --
511 ----------
513 function Year (Date : Time) return Year_Number is
514 DY : Year_Number;
515 DM : Month_Number;
516 DD : Day_Number;
517 DS : Day_Duration;
518 begin
519 Split (Date, DY, DM, DD, DS);
520 return DY;
521 end Year;
523 -------------------
524 -- Leap_Sec_Ops --
525 -------------------
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
544 Year : Year_Number;
545 Month : Month_Number;
546 Day : Day_Number;
547 end record;
549 Leap_Second_Dates :
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
567 (Start_Date : Time;
568 End_Date : Time;
569 Leaps_Between : out Duration;
570 Next_Leap_Sec : out Time)
572 End_T : Time;
573 K : Positive;
574 Leap_Index : Positive;
575 Start_Tmp : Time;
576 Start_T : Time;
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);
582 D_As_Int : D_Int;
584 function To_D_As_Int is new Unchecked_Conversion (Duration, D_Int);
586 begin
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
591 -- are non-negative.
593 if End_Date < 0.0 then
594 Leaps_Between := 0.0;
595 return;
596 end if;
598 if Start_Date < 0.0 then
599 Start_Tmp := Time (0.0);
600 else
601 Start_Tmp := Start_Date;
602 end if;
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);
617 Leap_Index := 1;
618 loop
619 exit when Leap_Second_Times (Leap_Index) >= Start_T;
620 Leap_Index := Leap_Index + 1;
621 end loop;
623 K := Leap_Index;
624 loop
625 exit when K > N_Leap_Secs or else
626 Leap_Second_Times (K) >= End_T;
627 K := K + 1;
628 end loop;
630 if K <= N_Leap_Secs then
631 Next_Leap_Sec := Leap_Second_Times (K);
632 end if;
634 Leaps_Between := Duration (K - Leap_Index);
635 else
636 Leaps_Between := Duration (0.0);
637 end if;
638 end Cumulative_Leap_Secs;
640 ----------------------
641 -- All_Leap_Seconds --
642 ----------------------
644 function All_Leap_Seconds return Duration is
645 begin
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
652 begin
653 declare
654 Days : Natural;
655 Is_Leap_Year : Boolean;
656 Years : Natural;
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);
661 begin
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;
668 if Years = 1 then
669 Days := Days + 365;
671 elsif Years = 2 then
672 Is_Leap_Year := True;
674 -- 1972 or multiple of 4 after
676 Days := Days + 365 * 2;
678 elsif Years = 3 then
679 Days := Days + 365 * 3 + 1;
680 end if;
682 Days := Days + Cumulative_Days_Before_Month
683 (Leap_Second_Dates (J).Month);
685 if Is_Leap_Year
686 and then Leap_Second_Dates (J).Month > 2
687 then
688 Days := Days + 1;
689 end if;
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
697 -- leap seconds.
699 end loop;
700 end;
701 end Leap_Sec_Ops;
703 begin
704 System.OS_Primitives.Initialize;
705 end Ada.Calendar;