| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- A D A . C A L E N D A R -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2001 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, 59 Temple Place - Suite 330, Boston, -- |
| -- MA 02111-1307, 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; |
| -- 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_r (C : time_t_Pointer; res : tm_Pointer); |
| pragma Import (C, localtime_r, "__gnat_localtime_r"); |
| |
| 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 the range that can be handled by Unix (1970 - 2038). 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. |
| |
| Unix_Year_Min : constant := 1970; |
| Unix_Year_Max : constant := 2038; |
| |
| 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_4_YearsD : constant Duration := Duration (Seconds_In_4_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 |
| -- 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); |
| |
| -- The following declare the maximum duration value that can be |
| -- successfully converted to a 32-bit integer suitable for passing |
| -- to the localtime_r function. Note that we cannot assume that the |
| -- localtime_r function expands to accept 64-bit input on a 64-bit |
| -- machine, but we can count on a 32-bit range on all machines. |
| |
| Max_Time : constant := 2 ** 31 - 1; |
| Max_TimeD : constant Duration := Duration (Max_Time); |
| |
| -- Finally the actual variables used in the computation |
| |
| D : Duration; |
| Frac_Sec : Duration; |
| Year_Val : Integer; |
| Adjusted_Seconds : aliased time_t; |
| Tm_Val : aliased tm; |
| |
| 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 four years. |
| -- For the range we are interested in, the number of days in any |
| -- consecutive four 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_4_YearsD; |
| Year_Val := Year_Val - 4; |
| end loop; |
| |
| while D > Max_TimeD loop |
| D := D - Seconds_In_4_YearsD; |
| Year_Val := Year_Val + 4; |
| 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; |
| |
| 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); |
| function To_Duration is new Unchecked_Conversion (D_Int, Duration); |
| |
| begin |
| D_As_Int := To_D_As_Int (D); |
| Adjusted_Seconds := time_t (D_As_Int / Small_Div); |
| Frac_Sec := To_Duration (D_As_Int rem Small_Div); |
| end; |
| |
| localtime_r (Adjusted_Seconds'Unchecked_Access, Tm_Val'Unchecked_Access); |
| |
| Year_Val := Tm_Val.tm_year + 1900 + Year_Val; |
| Month := Tm_Val.tm_mon + 1; |
| Day := Tm_Val.tm_mday; |
| |
| -- 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; |
| |
| ------------- |
| -- 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 basi 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 four year steps, since the number of days in four |
| -- years is constant, so the timezone effect on the conversion from |
| -- local time to GMT is unaffected. |
| |
| while Year_Val <= Unix_Year_Min loop |
| Year_Val := Year_Val + 4; |
| Duration_Adjust := Duration_Adjust - Seconds_In_4_YearsD; |
| end loop; |
| |
| while Year_Val >= Unix_Year_Max loop |
| Year_Val := Year_Val - 4; |
| Duration_Adjust := Duration_Adjust + Seconds_In_4_YearsD; |
| end loop; |
| |
| TM_Val.tm_year := Year_Val - 1900; |
| |
| -- 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; |
| |
| end Ada.Calendar; |
