OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
gcc/gcc/ada/a-calend.adb

706 lines
24 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C A L E N D A R --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Unchecked_Conversion;
with System.OS_Primitives;
-- used for Clock
package body Ada.Calendar is
------------------------------
-- Use of Pragma Unsuppress --
------------------------------
-- This implementation of Calendar takes advantage of the permission in
-- Ada 95 of using arithmetic overflow checks to check for out of bounds
-- time values. This means that we must catch the constraint error that
-- results from arithmetic overflow, so we use pragma Unsuppress to make
-- sure that overflow is enabled, using software overflow checking if
-- necessary. That way, compiling Calendar with options to suppress this
-- checking will not affect its correctness.
------------------------
-- Local Declarations --
------------------------
type char_Pointer is access Character;
subtype int is Integer;
subtype long is Long_Integer;
type long_Pointer is access all long;
-- Synonyms for C types. We don't want to get them from Interfaces.C
-- because there is no point in loading that unit just for calendar.
type tm is record
tm_sec : int; -- seconds after the minute (0 .. 60)
tm_min : int; -- minutes after the hour (0 .. 59)
tm_hour : int; -- hours since midnight (0 .. 24)
tm_mday : int; -- day of the month (1 .. 31)
tm_mon : int; -- months since January (0 .. 11)
tm_year : int; -- years since 1900
tm_wday : int; -- days since Sunday (0 .. 6)
tm_yday : int; -- days since January 1 (0 .. 365)
tm_isdst : int; -- Daylight Savings Time flag (-1 .. +1)
tm_gmtoff : long; -- offset from CUT in seconds
tm_zone : char_Pointer; -- timezone abbreviation
end record;
type tm_Pointer is access all tm;
subtype time_t is long;
type time_t_Pointer is access all time_t;
procedure localtime_tzoff
(C : time_t_Pointer;
res : tm_Pointer;
off : long_Pointer);
pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff");
-- This is a lightweight wrapper around the system library localtime_r
-- function. Parameter 'off' captures the UTC offset which is either
-- retrieved from the tm struct or calculated from the 'timezone' extern
-- and the tm_isdst flag in the tm struct.
function mktime (TM : tm_Pointer) return time_t;
pragma Import (C, mktime);
-- mktime returns -1 in case the calendar time given by components of
-- TM.all cannot be represented.
-- The following constants are used in adjusting Ada dates so that they
-- fit into a 56 year range that can be handled by Unix (1970 included -
-- 2026 excluded). Dates that are not in this 56 year range are shifted
-- by multiples of 56 years to fit in this range.
-- The trick is that the number of days in any four year period in the Ada
-- range of years (1901 - 2099) has a constant number of days. This is
-- because we have the special case of 2000 which, contrary to the normal
-- exception for centuries, is a leap year after all. 56 has been chosen,
-- because it is not only a multiple of 4, but also a multiple of 7. Thus
-- two dates 56 years apart fall on the same day of the week, and the
-- Daylight Saving Time change dates are usually the same for these two
-- years.
Unix_Year_Min : constant := 1970;
Unix_Year_Max : constant := 2026;
Ada_Year_Min : constant := 1901;
Ada_Year_Max : constant := 2099;
-- Some basic constants used throughout
Days_In_Month : constant array (Month_Number) of Day_Number :=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
Days_In_4_Years : constant := 365 * 3 + 366;
Seconds_In_4_Years : constant := 86_400 * Days_In_4_Years;
Seconds_In_56_Years : constant := Seconds_In_4_Years * 14;
Seconds_In_56_YearsD : constant := Duration (Seconds_In_56_Years);
---------
-- "+" --
---------
function "+" (Left : Time; Right : Duration) return Time is
pragma Unsuppress (Overflow_Check);
begin
return (Left + Time (Right));
exception
when Constraint_Error =>
raise Time_Error;
end "+";
function "+" (Left : Duration; Right : Time) return Time is
pragma Unsuppress (Overflow_Check);
begin
return (Time (Left) + Right);
exception
when Constraint_Error =>
raise Time_Error;
end "+";
---------
-- "-" --
---------
function "-" (Left : Time; Right : Duration) return Time is
pragma Unsuppress (Overflow_Check);
begin
return Left - Time (Right);
exception
when Constraint_Error =>
raise Time_Error;
end "-";
function "-" (Left : Time; Right : Time) return Duration is
pragma Unsuppress (Overflow_Check);
begin
return Duration (Left) - Duration (Right);
exception
when Constraint_Error =>
raise Time_Error;
end "-";
---------
-- "<" --
---------
function "<" (Left, Right : Time) return Boolean is
begin
return Duration (Left) < Duration (Right);
end "<";
----------
-- "<=" --
----------
function "<=" (Left, Right : Time) return Boolean is
begin
return Duration (Left) <= Duration (Right);
end "<=";
---------
-- ">" --
---------
function ">" (Left, Right : Time) return Boolean is
begin
return Duration (Left) > Duration (Right);
end ">";
----------
-- ">=" --
----------
function ">=" (Left, Right : Time) return Boolean is
begin
return Duration (Left) >= Duration (Right);
end ">=";
-----------
-- Clock --
-----------
function Clock return Time is
begin
return Time (System.OS_Primitives.Clock);
end Clock;
---------
-- Day --
---------
function Day (Date : Time) return Day_Number is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DD;
end Day;
-----------
-- Month --
-----------
function Month (Date : Time) return Month_Number is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DM;
end Month;
-------------
-- Seconds --
-------------
function Seconds (Date : Time) return Day_Duration is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DS;
end Seconds;
-----------
-- Split --
-----------
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration)
is
Offset : Long_Integer;
begin
Split_With_Offset (Date, Year, Month, Day, Seconds, Offset);
end Split;
-----------------------
-- Split_With_Offset --
-----------------------
procedure Split_With_Offset
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration;
Offset : out Long_Integer)
is
-- The following declare bounds for duration that are comfortably
-- wider than the maximum allowed output result for the Ada range
-- of representable split values. These are used for a quick check
-- that the value is not wildly out of range.
Low : constant := (Ada_Year_Min - Unix_Year_Min - 2) * 365 * 86_400;
High : constant := (Ada_Year_Max - Unix_Year_Min + 2) * 365 * 86_400;
LowD : constant Duration := Duration (Low);
HighD : constant Duration := Duration (High);
-- Finally the actual variables used in the computation
Adjusted_Seconds : aliased time_t;
D : Duration;
Frac_Sec : Duration;
Local_Offset : aliased long;
Tm_Val : aliased tm;
Year_Val : Integer;
begin
-- For us a time is simply a signed duration value, so we work with
-- this duration value directly. Note that it can be negative.
D := Duration (Date);
-- First of all, filter out completely ludicrous values. Remember that
-- we use the full stored range of duration values, which may be
-- significantly larger than the allowed range of Ada times. Note that
-- these checks are wider than required to make absolutely sure that
-- there are no end effects from time zone differences.
if D < LowD or else D > HighD then
raise Time_Error;
end if;
-- The unix localtime_r function is more or less exactly what we need
-- here. The less comes from the fact that it does not support the
-- required range of years (the guaranteed range available is only
-- EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1.
-- If we have a value outside this range, then we first adjust it to be
-- in the required range by adding multiples of 56 years. For the range
-- we are interested in, the number of days in any consecutive 56 year
-- period is constant. Then we do the split on the adjusted value, and
-- readjust the years value accordingly.
Year_Val := 0;
while D < 0.0 loop
D := D + Seconds_In_56_YearsD;
Year_Val := Year_Val - 56;
end loop;
while D >= Seconds_In_56_YearsD loop
D := D - Seconds_In_56_YearsD;
Year_Val := Year_Val + 56;
end loop;
-- Now we need to take the value D, which is now non-negative, and
-- break it down into seconds (to pass to the localtime_r function) and
-- fractions of seconds (for the adjustment below).
-- Surprisingly there is no easy way to do this in Ada, and certainly
-- no easy way to do it and generate efficient code. Therefore we do it
-- at a low level, knowing that it is really represented as an integer
-- with units of Small
declare
type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1;
for D_Int'Size use Duration'Size;
function To_D_Int is new Unchecked_Conversion (Duration, D_Int);
function To_Duration is new Unchecked_Conversion (D_Int, Duration);
D_As_Int : constant D_Int := To_D_Int (D);
Small_Div : constant D_Int := D_Int (1.0 / Duration'Small);
begin
Adjusted_Seconds := time_t (D_As_Int / Small_Div);
Frac_Sec := To_Duration (D_As_Int rem Small_Div);
end;
localtime_tzoff
(Adjusted_Seconds'Unchecked_Access,
Tm_Val'Unchecked_Access,
Local_Offset'Unchecked_Access);
Year_Val := Tm_Val.tm_year + 1900 + Year_Val;
Month := Tm_Val.tm_mon + 1;
Day := Tm_Val.tm_mday;
Offset := Long_Integer (Local_Offset);
-- The Seconds value is a little complex. The localtime function
-- returns the integral number of seconds, which is what we want, but
-- we want to retain the fractional part from the original Time value,
-- since this is typically stored more accurately.
Seconds := Duration (Tm_Val.tm_hour * 3600 +
Tm_Val.tm_min * 60 +
Tm_Val.tm_sec)
+ Frac_Sec;
-- Note: the above expression is pretty horrible, one of these days we
-- should stop using time_of and do everything ourselves to avoid these
-- unnecessary divides and multiplies???.
-- The Year may still be out of range, since our entry test was
-- deliberately crude. Trying to make this entry test accurate is
-- tricky due to time zone adjustment issues affecting the exact
-- boundary. It is interesting to note that whether or not a given
-- Calendar.Time value gets Time_Error when split depends on the
-- current time zone setting.
if Year_Val not in Ada_Year_Min .. Ada_Year_Max then
raise Time_Error;
else
Year := Year_Val;
end if;
end Split_With_Offset;
-------------
-- Time_Of --
-------------
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration := 0.0)
return Time
is
Result_Secs : aliased time_t;
TM_Val : aliased tm;
Int_Secs : constant Integer := Integer (Seconds);
Year_Val : Integer := Year;
Duration_Adjust : Duration := 0.0;
begin
-- The following checks are redundant with respect to the constraint
-- error checks that should normally be made on parameters, but we
-- decide to raise Constraint_Error in any case if bad values come in
-- (as a result of checks being off in the caller, or for other
-- erroneous or bounded error cases).
if not Year 'Valid
or else not Month 'Valid
or else not Day 'Valid
or else not Seconds'Valid
then
raise Constraint_Error;
end if;
-- Check for Day value too large (one might expect mktime to do this
-- check, as well as the basic checks we did with 'Valid, but it seems
-- that at least on some systems, this built-in check is too weak).
if Day > Days_In_Month (Month)
and then (Day /= 29 or Month /= 2 or Year mod 4 /= 0)
then
raise Time_Error;
end if;
TM_Val.tm_sec := Int_Secs mod 60;
TM_Val.tm_min := (Int_Secs / 60) mod 60;
TM_Val.tm_hour := (Int_Secs / 60) / 60;
TM_Val.tm_mday := Day;
TM_Val.tm_mon := Month - 1;
-- For the year, we have to adjust it to a year that Unix can handle.
-- We do this in 56 year steps, since the number of days in 56 years is
-- constant, so the timezone effect on the conversion from local time
-- to GMT is unaffected; also the DST change dates are usually not
-- modified.
while Year_Val < Unix_Year_Min loop
Year_Val := Year_Val + 56;
Duration_Adjust := Duration_Adjust - Seconds_In_56_YearsD;
end loop;
while Year_Val >= Unix_Year_Max loop
Year_Val := Year_Val - 56;
Duration_Adjust := Duration_Adjust + Seconds_In_56_YearsD;
end loop;
TM_Val.tm_year := Year_Val - 1900;
-- If time is very close to UNIX epoch mktime may behave uncorrectly
-- because of the way the different time zones are handled (a date
-- after epoch in a given time zone may correspond to a GMT date
-- before epoch). Adding one day to the date (this amount is latter
-- substracted) avoids this problem.
if Year_Val = Unix_Year_Min
and then Month = 1
and then Day = 1
then
TM_Val.tm_mday := TM_Val.tm_mday + 1;
Duration_Adjust := Duration_Adjust - Duration (86400.0);
end if;
-- Since we do not have information on daylight savings, rely on the
-- default information.
TM_Val.tm_isdst := -1;
Result_Secs := mktime (TM_Val'Unchecked_Access);
-- That gives us the basic value in seconds. Two adjustments are
-- needed. First we must undo the year adjustment carried out above.
-- Second we put back the fraction seconds value since in general the
-- Day_Duration value we received has additional precision which we do
-- not want to lose in the constructed result.
return
Time (Duration (Result_Secs) +
Duration_Adjust +
(Seconds - Duration (Int_Secs)));
end Time_Of;
----------
-- Year --
----------
function Year (Date : Time) return Year_Number is
DY : Year_Number;
DM : Month_Number;
DD : Day_Number;
DS : Day_Duration;
begin
Split (Date, DY, DM, DD, DS);
return DY;
end Year;
-------------------
-- Leap_Sec_Ops --
-------------------
-- The package that is used by the Ada 2005 children of Ada.Calendar:
-- Ada.Calendar.Arithmetic and Ada.Calendar.Formatting.
package body Leap_Sec_Ops is
-- This package must be updated when leap seconds are added. Adding a
-- leap second requires incrementing the value of N_Leap_Secs and adding
-- the day of the new leap second to the end of Leap_Second_Dates.
-- Elaboration of the Leap_Sec_Ops package takes care of converting the
-- Leap_Second_Dates table to a form that is better suited for the
-- procedures provided by this package (a table that would be more
-- difficult to maintain by hand).
N_Leap_Secs : constant := 23;
type Leap_Second_Date is record
Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
end record;
Leap_Second_Dates :
constant array (1 .. N_Leap_Secs) of Leap_Second_Date :=
((1972, 6, 30), (1972, 12, 31), (1973, 12, 31), (1974, 12, 31),
(1975, 12, 31), (1976, 12, 31), (1977, 12, 31), (1978, 12, 31),
(1979, 12, 31), (1981, 6, 30), (1982, 6, 30), (1983, 6, 30),
(1985, 6, 30), (1987, 12, 31), (1989, 12, 31), (1990, 12, 31),
(1992, 6, 30), (1993, 6, 30), (1994, 6, 30), (1995, 12, 31),
(1997, 6, 30), (1998, 12, 31), (2005, 12, 31));
Leap_Second_Times : array (1 .. N_Leap_Secs) of Time;
-- This is the needed internal representation that is calculated
-- from Leap_Second_Dates during elaboration;
--------------------------
-- Cumulative_Leap_Secs --
--------------------------
procedure Cumulative_Leap_Secs
(Start_Date : Time;
End_Date : Time;
Leaps_Between : out Duration;
Next_Leap_Sec : out Time)
is
End_T : Time;
K : Positive;
Leap_Index : Positive;
Start_Tmp : Time;
Start_T : Time;
type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1;
for D_Int'Size use Duration'Size;
Small_Div : constant D_Int := D_Int (1.0 / Duration'Small);
D_As_Int : D_Int;
function To_D_As_Int is new Unchecked_Conversion (Duration, D_Int);
begin
Next_Leap_Sec := After_Last_Leap;
-- We want to throw away the fractional part of seconds. Before
-- proceding with this operation, make sure our working values
-- are non-negative.
if End_Date < 0.0 then
Leaps_Between := 0.0;
return;
end if;
if Start_Date < 0.0 then
Start_Tmp := Time (0.0);
else
Start_Tmp := Start_Date;
end if;
if Start_Date <= Leap_Second_Times (N_Leap_Secs) then
-- Manipulate the fixed point value as an integer, similar to
-- Ada.Calendar.Split in order to remove the fractional part
-- from the time we will work with, Start_T and End_T.
D_As_Int := To_D_As_Int (Duration (Start_Tmp));
D_As_Int := D_As_Int / Small_Div;
Start_T := Time (D_As_Int);
D_As_Int := To_D_As_Int (Duration (End_Date));
D_As_Int := D_As_Int / Small_Div;
End_T := Time (D_As_Int);
Leap_Index := 1;
loop
exit when Leap_Second_Times (Leap_Index) >= Start_T;
Leap_Index := Leap_Index + 1;
end loop;
K := Leap_Index;
loop
exit when K > N_Leap_Secs or else
Leap_Second_Times (K) >= End_T;
K := K + 1;
end loop;
if K <= N_Leap_Secs then
Next_Leap_Sec := Leap_Second_Times (K);
end if;
Leaps_Between := Duration (K - Leap_Index);
else
Leaps_Between := Duration (0.0);
end if;
end Cumulative_Leap_Secs;
----------------------
-- All_Leap_Seconds --
----------------------
function All_Leap_Seconds return Duration is
begin
return Duration (N_Leap_Secs);
-- Presumes each leap second is +1.0 second;
end All_Leap_Seconds;
-- Start of processing in package Leap_Sec_Ops
begin
declare
Days : Natural;
Is_Leap_Year : Boolean;
Years : Natural;
Cumulative_Days_Before_Month :
constant array (Month_Number) of Natural :=
(0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
begin
for J in 1 .. N_Leap_Secs loop
Years := Leap_Second_Dates (J).Year - Unix_Year_Min;
Days := (Years / 4) * Days_In_4_Years;
Years := Years mod 4;
Is_Leap_Year := False;
if Years = 1 then
Days := Days + 365;
elsif Years = 2 then
Is_Leap_Year := True;
-- 1972 or multiple of 4 after
Days := Days + 365 * 2;
elsif Years = 3 then
Days := Days + 365 * 3 + 1;
end if;
Days := Days + Cumulative_Days_Before_Month
(Leap_Second_Dates (J).Month);
if Is_Leap_Year
and then Leap_Second_Dates (J).Month > 2
then
Days := Days + 1;
end if;
Days := Days + Leap_Second_Dates (J).Day;
Leap_Second_Times (J) :=
Time (Days * Duration (86_400.0) + Duration (J - 1));
-- Add one to get to the leap second. Add J - 1 previous
-- leap seconds.
end loop;
end;
end Leap_Sec_Ops;
begin
System.OS_Primitives.Initialize;
end Ada.Calendar;
Reference in New Issue View Git Blame Copy Permalink