gcc/ada/a-calend.adb

   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-2001 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 ------------------------------------------------------------------------------
  33
  34 with Unchecked_Conversion;
  35
  36 with System.OS_Primitives;
  37 --  used for Clock
  38
  39 package body Ada.Calendar is
  40
  41    ------------------------------
  42    -- Use of Pragma Unsuppress --
  43    ------------------------------
  44
  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.
  52
  53    ------------------------
  54    -- Local Declarations --
  55    ------------------------
  56
  57    type Char_Pointer is access Character;
  58    subtype int  is Integer;
  59    subtype long is Long_Integer;
  60    --  Synonyms for C types. We don't want to get them from Interfaces.C
  61    --  because there is no point in loading that unit just for calendar.
  62
  63    type tm is record
  64       tm_sec    : int;           -- seconds after the minute (0 .. 60)
  65       tm_min    : int;           -- minutes after the hour (0 .. 59)
  66       tm_hour   : int;           -- hours since midnight (0 .. 24)
  67       tm_mday   : int;           -- day of the month (1 .. 31)
  68       tm_mon    : int;           -- months since January (0 .. 11)
  69       tm_year   : int;           -- years since 1900
  70       tm_wday   : int;           -- days since Sunday (0 .. 6)
  71       tm_yday   : int;           -- days since January 1 (0 .. 365)
  72       tm_isdst  : int;           -- Daylight Savings Time flag (-1 .. +1)
  73       tm_gmtoff : long;          -- offset from CUT in seconds
  74       tm_zone   : Char_Pointer;  -- timezone abbreviation
  75    end record;
  76
  77    type tm_Pointer is access all tm;
  78
  79    subtype time_t is long;
  80
  81    type time_t_Pointer is access all time_t;
  82
  83    procedure localtime_r (C : time_t_Pointer; res : tm_Pointer);
  84    pragma Import (C, localtime_r, "__gnat_localtime_r");
  85
  86    function mktime (TM : tm_Pointer) return time_t;
  87    pragma Import (C, mktime);
  88    --  mktime returns -1 in case the calendar time given by components of
  89    --  TM.all cannot be represented.
  90
  91    --  The following constants are used in adjusting Ada dates so that they
  92    --  fit into the range that can be handled by Unix (1970 - 2038). The trick
  93    --  is that the number of days in any four year period in the Ada range of
  94    --  years (1901 - 2099) has a constant number of days. This is because we
  95    --  have the special case of 2000 which, contrary to the normal exception
  96    --  for centuries, is a leap year after all.
  97
  98    Unix_Year_Min : constant := 1970;
  99    Unix_Year_Max : constant := 2038;
 100
 101    Ada_Year_Min : constant := 1901;
 102    Ada_Year_Max : constant := 2099;
 103
 104    --  Some basic constants used throughout
 105
 106    Days_In_Month : constant array (Month_Number) of Day_Number :=
 107                      (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
 108
 109    Days_In_4_Years     : constant := 365 * 3 + 366;
 110    Seconds_In_4_Years  : constant := 86_400 * Days_In_4_Years;
 111    Seconds_In_4_YearsD : constant Duration := Duration (Seconds_In_4_Years);
 112
 113    ---------
 114    -- "+" --
 115    ---------
 116
 117    function "+" (Left : Time; Right : Duration) return Time is
 118       pragma Unsuppress (Overflow_Check);
 119    begin
 120       return (Left + Time (Right));
 121
 122    exception
 123       when Constraint_Error =>
 124          raise Time_Error;
 125    end "+";
 126
 127    function "+" (Left : Duration; Right : Time) return Time is
 128       pragma Unsuppress (Overflow_Check);
 129    begin
 130       return (Time (Left) + Right);
 131
 132    exception
 133       when Constraint_Error =>
 134          raise Time_Error;
 135    end "+";
 136
 137    ---------
 138    -- "-" --
 139    ---------
 140
 141    function "-" (Left : Time; Right : Duration)  return Time is
 142       pragma Unsuppress (Overflow_Check);
 143    begin
 144       return Left - Time (Right);
 145
 146    exception
 147       when Constraint_Error =>
 148          raise Time_Error;
 149    end "-";
 150
 151    function "-" (Left : Time; Right : Time) return Duration is
 152       pragma Unsuppress (Overflow_Check);
 153    begin
 154       return Duration (Left) - Duration (Right);
 155
 156    exception
 157       when Constraint_Error =>
 158          raise Time_Error;
 159    end "-";
 160
 161    ---------
 162    -- "<" --
 163    ---------
 164
 165    function "<" (Left, Right : Time) return Boolean is
 166    begin
 167       return Duration (Left) < Duration (Right);
 168    end "<";
 169
 170    ----------
 171    -- "<=" --
 172    ----------
 173
 174    function "<=" (Left, Right : Time) return Boolean is
 175    begin
 176       return Duration (Left) <= Duration (Right);
 177    end "<=";
 178
 179    ---------
 180    -- ">" --
 181    ---------
 182
 183    function ">" (Left, Right : Time) return Boolean is
 184    begin
 185       return Duration (Left) > Duration (Right);
 186    end ">";
 187
 188    ----------
 189    -- ">=" --
 190    ----------
 191
 192    function ">=" (Left, Right : Time) return Boolean is
 193    begin
 194       return Duration (Left) >= Duration (Right);
 195    end ">=";
 196
 197    -----------
 198    -- Clock --
 199    -----------
 200
 201    function Clock return Time is
 202    begin
 203       return Time (System.OS_Primitives.Clock);
 204    end Clock;
 205
 206    ---------
 207    -- Day --
 208    ---------
 209
 210    function Day (Date : Time) return Day_Number is
 211       DY : Year_Number;
 212       DM : Month_Number;
 213       DD : Day_Number;
 214       DS : Day_Duration;
 215
 216    begin
 217       Split (Date, DY, DM, DD, DS);
 218       return DD;
 219    end Day;
 220
 221    -----------
 222    -- Month --
 223    -----------
 224
 225    function Month (Date : Time) return Month_Number is
 226       DY : Year_Number;
 227       DM : Month_Number;
 228       DD : Day_Number;
 229       DS : Day_Duration;
 230
 231    begin
 232       Split (Date, DY, DM, DD, DS);
 233       return DM;
 234    end Month;
 235
 236    -------------
 237    -- Seconds --
 238    -------------
 239
 240    function Seconds (Date : Time) return Day_Duration is
 241       DY : Year_Number;
 242       DM : Month_Number;
 243       DD : Day_Number;
 244       DS : Day_Duration;
 245
 246    begin
 247       Split (Date, DY, DM, DD, DS);
 248       return DS;
 249    end Seconds;
 250
 251    -----------
 252    -- Split --
 253    -----------
 254
 255    procedure Split
 256      (Date    : Time;
 257       Year    : out Year_Number;
 258       Month   : out Month_Number;
 259       Day     : out Day_Number;
 260       Seconds : out Day_Duration)
 261    is
 262       --  The following declare bounds for duration that are comfortably
 263       --  wider than the maximum allowed output result for the Ada range
 264       --  of representable split values. These are used for a quick check
 265       --  that the value is not wildly out of range.
 266
 267       Low  : constant := (Ada_Year_Min - Unix_Year_Min - 2) * 365 * 86_400;
 268       High : constant := (Ada_Year_Max - Unix_Year_Min + 2) * 365 * 86_400;
 269
 270       LowD  : constant Duration := Duration (Low);
 271       HighD : constant Duration := Duration (High);
 272
 273       --  The following declare the maximum duration value that can be
 274       --  successfully converted to a 32-bit integer suitable for passing
 275       --  to the localtime_r function. Note that we cannot assume that the
 276       --  localtime_r function expands to accept 64-bit input on a 64-bit
 277       --  machine, but we can count on a 32-bit range on all machines.
 278
 279       Max_Time  : constant := 2 ** 31 - 1;
 280       Max_TimeD : constant Duration := Duration (Max_Time);
 281
 282       --  Finally the actual variables used in the computation
 283
 284       D                : Duration;
 285       Frac_Sec         : Duration;
 286       Year_Val         : Integer;
 287       Adjusted_Seconds : aliased time_t;
 288       Tm_Val           : aliased tm;
 289
 290    begin
 291       --  For us a time is simply a signed duration value, so we work with
 292       --  this duration value directly. Note that it can be negative.
 293
 294       D := Duration (Date);
 295
 296       --  First of all, filter out completely ludicrous values. Remember
 297       --  that we use the full stored range of duration values, which may
 298       --  be significantly larger than the allowed range of Ada times. Note
 299       --  that these checks are wider than required to make absolutely sure
 300       --  that there are no end effects from time zone differences.
 301
 302       if D < LowD or else D > HighD then
 303          raise Time_Error;
 304       end if;
 305
 306       --  The unix localtime_r function is more or less exactly what we need
 307       --  here. The less comes from the fact that it does not support the
 308       --  required range of years (the guaranteed range available is only
 309       --  EPOCH through EPOCH + N seconds). N is in practice 2 ** 31 - 1.
 310
 311       --  If we have a value outside this range, then we first adjust it
 312       --  to be in the required range by adding multiples of four years.
 313       --  For the range we are interested in, the number of days in any
 314       --  consecutive four year period is constant. Then we do the split
 315       --  on the adjusted value, and readjust the years value accordingly.
 316
 317       Year_Val := 0;
 318
 319       while D < 0.0 loop
 320          D := D + Seconds_In_4_YearsD;
 321          Year_Val := Year_Val - 4;
 322       end loop;
 323
 324       while D > Max_TimeD loop
 325          D := D - Seconds_In_4_YearsD;
 326          Year_Val := Year_Val + 4;
 327       end loop;
 328
 329       --  Now we need to take the value D, which is now non-negative, and
 330       --  break it down into seconds (to pass to the localtime_r function)
 331       --  and fractions of seconds (for the adjustment below).
 332
 333       --  Surprisingly there is no easy way to do this in Ada, and certainly
 334       --  no easy way to do it and generate efficient code. Therefore we
 335       --  do it at a low level, knowing that it is really represented as
 336       --  an integer with units of Small
 337
 338       declare
 339          type D_Int is range 0 .. 2 ** (Duration'Size - 1) - 1;
 340          for D_Int'Size use Duration'Size;
 341
 342          Small_Div : constant D_Int := D_Int (1.0 / Duration'Small);
 343          D_As_Int  : D_Int;
 344
 345          function To_D_As_Int is new Unchecked_Conversion (Duration, D_Int);
 346          function To_Duration is new Unchecked_Conversion (D_Int, Duration);
 347
 348       begin
 349          D_As_Int := To_D_As_Int (D);
 350          Adjusted_Seconds := time_t (D_As_Int / Small_Div);
 351          Frac_Sec := To_Duration (D_As_Int rem Small_Div);
 352       end;
 353
 354       localtime_r (Adjusted_Seconds'Unchecked_Access, Tm_Val'Unchecked_Access);
 355
 356       Year_Val := Tm_Val.tm_year + 1900 + Year_Val;
 357       Month    := Tm_Val.tm_mon + 1;
 358       Day      := Tm_Val.tm_mday;
 359
 360       --  The Seconds value is a little complex. The localtime function
 361       --  returns the integral number of seconds, which is what we want,
 362       --  but we want to retain the fractional part from the original
 363       --  Time value, since this is typically stored more accurately.
 364
 365       Seconds := Duration (Tm_Val.tm_hour * 3600 +
 366                            Tm_Val.tm_min  * 60 +
 367                            Tm_Val.tm_sec)
 368                    + Frac_Sec;
 369
 370       --  Note: the above expression is pretty horrible, one of these days
 371       --  we should stop using time_of and do everything ourselves to avoid
 372       --  these unnecessary divides and multiplies???.
 373
 374       --  The Year may still be out of range, since our entry test was
 375       --  deliberately crude. Trying to make this entry test accurate is
 376       --  tricky due to time zone adjustment issues affecting the exact
 377       --  boundary. It is interesting to note that whether or not a given
 378       --  Calendar.Time value gets Time_Error when split depends on the
 379       --  current time zone setting.
 380
 381       if Year_Val not in Ada_Year_Min .. Ada_Year_Max then
 382          raise Time_Error;
 383       else
 384          Year := Year_Val;
 385       end if;
 386    end Split;
 387
 388    -------------
 389    -- Time_Of --
 390    -------------
 391
 392    function Time_Of
 393      (Year    : Year_Number;
 394       Month   : Month_Number;
 395       Day     : Day_Number;
 396       Seconds : Day_Duration := 0.0)
 397       return    Time
 398    is
 399       Result_Secs : aliased time_t;
 400       TM_Val      : aliased tm;
 401       Int_Secs    : constant Integer := Integer (Seconds);
 402
 403       Year_Val        : Integer := Year;
 404       Duration_Adjust : Duration := 0.0;
 405
 406    begin
 407       --  The following checks are redundant with respect to the constraint
 408       --  error checks that should normally be made on parameters, but we
 409       --  decide to raise Constraint_Error in any case if bad values come
 410       --  in (as a result of checks being off in the caller, or for other
 411       --  erroneous or bounded error cases).
 412
 413       if        not Year   'Valid
 414         or else not Month  'Valid
 415         or else not Day    'Valid
 416         or else not Seconds'Valid
 417       then
 418          raise Constraint_Error;
 419       end if;
 420
 421       --  Check for Day value too large (one might expect mktime to do this
 422       --  check, as well as the basi checks we did with 'Valid, but it seems
 423       --  that at least on some systems, this built-in check is too weak).
 424
 425       if Day > Days_In_Month (Month)
 426         and then (Day /= 29 or Month /= 2 or Year mod 4 /= 0)
 427       then
 428          raise Time_Error;
 429       end if;
 430
 431       TM_Val.tm_sec  := Int_Secs mod 60;
 432       TM_Val.tm_min  := (Int_Secs / 60) mod 60;
 433       TM_Val.tm_hour := (Int_Secs / 60) / 60;
 434       TM_Val.tm_mday := Day;
 435       TM_Val.tm_mon  := Month - 1;
 436
 437       --  For the year, we have to adjust it to a year that Unix can handle.
 438       --  We do this in four year steps, since the number of days in four
 439       --  years is constant, so the timezone effect on the conversion from
 440       --  local time to GMT is unaffected.
 441
 442       while Year_Val <= Unix_Year_Min loop
 443          Year_Val := Year_Val + 4;
 444          Duration_Adjust := Duration_Adjust - Seconds_In_4_YearsD;
 445       end loop;
 446
 447       while Year_Val >= Unix_Year_Max loop
 448          Year_Val := Year_Val - 4;
 449          Duration_Adjust := Duration_Adjust + Seconds_In_4_YearsD;
 450       end loop;
 451
 452       TM_Val.tm_year := Year_Val - 1900;
 453
 454       --  Since we do not have information on daylight savings,
 455       --  rely on the default information.
 456
 457       TM_Val.tm_isdst := -1;
 458       Result_Secs := mktime (TM_Val'Unchecked_Access);
 459
 460       --  That gives us the basic value in seconds. Two adjustments are
 461       --  needed. First we must undo the year adjustment carried out above.
 462       --  Second we put back the fraction seconds value since in general the
 463       --  Day_Duration value we received has additional precision which we
 464       --  do not want to lose in the constructed result.
 465
 466       return
 467         Time (Duration (Result_Secs) +
 468               Duration_Adjust +
 469               (Seconds - Duration (Int_Secs)));
 470
 471    end Time_Of;
 472
 473    ----------
 474    -- Year --
 475    ----------
 476
 477    function Year (Date : Time) return Year_Number is
 478       DY : Year_Number;
 479       DM : Month_Number;
 480       DD : Day_Number;
 481       DS : Day_Duration;
 482
 483    begin
 484       Split (Date, DY, DM, DD, DS);
 485       return DY;
 486    end Year;
 487
 488 end Ada.Calendar;