gcc/ada/4wcalend.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 --                                                                          --
  10 --            Copyright (C) 1997-2001 Free Software Foundation, Inc.        --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is the Windows NT/95 version.
  36
  37 with System.OS_Primitives;
  38 --  used for Clock
  39
  40 with System.OS_Interface;
  41
  42 package body Ada.Calendar is
  43
  44    use System.OS_Interface;
  45
  46    ------------------------------
  47    -- Use of Pragma Unsuppress --
  48    ------------------------------
  49
  50    --  This implementation of Calendar takes advantage of the permission in
  51    --  Ada 95 of using arithmetic overflow checks to check for out of bounds
  52    --  time values. This means that we must catch the constraint error that
  53    --  results from arithmetic overflow, so we use pragma Unsuppress to make
  54    --  sure that overflow is enabled, using software overflow checking if
  55    --  necessary. That way, compiling Calendar with options to suppress this
  56    --  checking will not affect its correctness.
  57
  58    ------------------------
  59    -- Local Declarations --
  60    ------------------------
  61
  62    Ada_Year_Min : constant := 1901;
  63    Ada_Year_Max : constant := 2099;
  64
  65    --  Win32 time constants
  66
  67    epoch_1970     : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
  68    system_time_ns : constant := 100;                    -- 100 ns per tick
  69    Sec_Unit       : constant := 10#1#E9;
  70
  71    ---------
  72    -- "+" --
  73    ---------
  74
  75    function "+" (Left : Time; Right : Duration) return Time is
  76       pragma Unsuppress (Overflow_Check);
  77    begin
  78       return (Left + Time (Right));
  79
  80    exception
  81       when Constraint_Error =>
  82          raise Time_Error;
  83    end "+";
  84
  85    function "+" (Left : Duration; Right : Time) return Time is
  86       pragma Unsuppress (Overflow_Check);
  87    begin
  88       return (Time (Left) + Right);
  89
  90    exception
  91       when Constraint_Error =>
  92          raise Time_Error;
  93    end "+";
  94
  95    ---------
  96    -- "-" --
  97    ---------
  98
  99    function "-" (Left : Time; Right : Duration)  return Time is
 100       pragma Unsuppress (Overflow_Check);
 101    begin
 102       return Left - Time (Right);
 103
 104    exception
 105       when Constraint_Error =>
 106          raise Time_Error;
 107    end "-";
 108
 109    function "-" (Left : Time; Right : Time) return Duration is
 110       pragma Unsuppress (Overflow_Check);
 111    begin
 112       return Duration (Left) - Duration (Right);
 113
 114    exception
 115       when Constraint_Error =>
 116          raise Time_Error;
 117    end "-";
 118
 119    ---------
 120    -- "<" --
 121    ---------
 122
 123    function "<" (Left, Right : Time) return Boolean is
 124    begin
 125       return Duration (Left) < Duration (Right);
 126    end "<";
 127
 128    ----------
 129    -- "<=" --
 130    ----------
 131
 132    function "<=" (Left, Right : Time) return Boolean is
 133    begin
 134       return Duration (Left) <= Duration (Right);
 135    end "<=";
 136
 137    ---------
 138    -- ">" --
 139    ---------
 140
 141    function ">" (Left, Right : Time) return Boolean is
 142    begin
 143       return Duration (Left) > Duration (Right);
 144    end ">";
 145
 146    ----------
 147    -- ">=" --
 148    ----------
 149
 150    function ">=" (Left, Right : Time) return Boolean is
 151    begin
 152       return Duration (Left) >= Duration (Right);
 153    end ">=";
 154
 155    -----------
 156    -- Clock --
 157    -----------
 158
 159    --  The Ada.Calendar.Clock function gets the time from the soft links
 160    --  interface which will call the appropriate function depending wether
 161    --  tasking is involved or not.
 162
 163    function Clock return Time is
 164    begin
 165       return Time (System.OS_Primitives.Clock);
 166    end Clock;
 167
 168    ---------
 169    -- Day --
 170    ---------
 171
 172    function Day (Date : Time) return Day_Number is
 173       DY : Year_Number;
 174       DM : Month_Number;
 175       DD : Day_Number;
 176       DS : Day_Duration;
 177
 178    begin
 179       Split (Date, DY, DM, DD, DS);
 180       return DD;
 181    end Day;
 182
 183    -----------
 184    -- Month --
 185    -----------
 186
 187    function Month (Date : Time) return Month_Number is
 188       DY : Year_Number;
 189       DM : Month_Number;
 190       DD : Day_Number;
 191       DS : Day_Duration;
 192
 193    begin
 194       Split (Date, DY, DM, DD, DS);
 195       return DM;
 196    end Month;
 197
 198    -------------
 199    -- Seconds --
 200    -------------
 201
 202    function Seconds (Date : Time) return Day_Duration is
 203       DY : Year_Number;
 204       DM : Month_Number;
 205       DD : Day_Number;
 206       DS : Day_Duration;
 207
 208    begin
 209       Split (Date, DY, DM, DD, DS);
 210       return DS;
 211    end Seconds;
 212
 213    -----------
 214    -- Split --
 215    -----------
 216
 217    procedure Split
 218      (Date    : Time;
 219       Year    : out Year_Number;
 220       Month   : out Month_Number;
 221       Day     : out Day_Number;
 222       Seconds : out Day_Duration)
 223    is
 224
 225       Date_Int    : aliased Long_Long_Integer;
 226       Date_Loc    : aliased Long_Long_Integer;
 227       Timbuf      : aliased SYSTEMTIME;
 228       Int_Date    : Long_Long_Integer;
 229       Sub_Seconds : Duration;
 230
 231    begin
 232       --  We take the sub-seconds (decimal part) of Date and this is added
 233       --  to compute the Seconds. This way we keep the precision of the
 234       --  high-precision clock that was lost with the Win32 API calls
 235       --  below.
 236
 237       if Date < 0.0 then
 238
 239          --  this is a Date before Epoch (January 1st, 1970)
 240
 241          Sub_Seconds := Duration (Date) -
 242            Duration (Long_Long_Integer (Date + Duration'(0.5)));
 243
 244          Int_Date := Long_Long_Integer (Date - Sub_Seconds);
 245
 246          --  For Date = -86400.1 we are 2 days before Epoch at 0.1 seconds
 247          --  from day 1 before Epoch. It means that it is 23h 59m 59.9s.
 248          --  here we adjust for that.
 249
 250          if Sub_Seconds < 0.0 then
 251             Int_Date    := Int_Date - 1;
 252             Sub_Seconds := 1.0 + Sub_Seconds;
 253          end if;
 254
 255       else
 256
 257          --  this is a Date after Epoch (January 1st, 1970)
 258
 259          Sub_Seconds := Duration (Date) -
 260            Duration (Long_Long_Integer (Date - Duration'(0.5)));
 261
 262          Int_Date := Long_Long_Integer (Date - Sub_Seconds);
 263
 264       end if;
 265
 266       --  Date_Int is the number of seconds from Epoch.
 267
 268       Date_Int := Long_Long_Integer
 269         (Int_Date * Sec_Unit / system_time_ns) + epoch_1970;
 270
 271       if not FileTimeToLocalFileTime (Date_Int'Access, Date_Loc'Access) then
 272          raise Time_Error;
 273       end if;
 274
 275       if not FileTimeToSystemTime (Date_Loc'Access, Timbuf'Access) then
 276          raise Time_Error;
 277       end if;
 278
 279       if Timbuf.wYear not in Ada_Year_Min .. Ada_Year_Max then
 280          raise Time_Error;
 281       end if;
 282
 283       Seconds :=
 284         Duration (Timbuf.wHour) * 3_600.0 +
 285         Duration (Timbuf.wMinute) * 60.0 +
 286         Duration (Timbuf.wSecond) +
 287         Sub_Seconds;
 288
 289       Day       := Integer (Timbuf.wDay);
 290       Month     := Integer (Timbuf.wMonth);
 291       Year      := Integer (Timbuf.wYear);
 292    end Split;
 293
 294    -------------
 295    -- Time_Of --
 296    -------------
 297
 298    function Time_Of
 299      (Year    : Year_Number;
 300       Month   : Month_Number;
 301       Day     : Day_Number;
 302       Seconds : Day_Duration := 0.0)
 303       return    Time
 304    is
 305
 306       Timbuf      : aliased SYSTEMTIME;
 307       Now         : aliased Long_Long_Integer;
 308       Loc         : aliased Long_Long_Integer;
 309       Int_Secs    : Integer;
 310       Secs        : Integer;
 311       Add_One_Day : Boolean := False;
 312       Date        : Time;
 313
 314    begin
 315       --  The following checks are redundant with respect to the constraint
 316       --  error checks that should normally be made on parameters, but we
 317       --  decide to raise Constraint_Error in any case if bad values come
 318       --  in (as a result of checks being off in the caller, or for other
 319       --  erroneous or bounded error cases).
 320
 321       if        not Year   'Valid
 322         or else not Month  'Valid
 323         or else not Day    'Valid
 324         or else not Seconds'Valid
 325       then
 326          raise Constraint_Error;
 327       end if;
 328
 329       if Seconds = 0.0 then
 330          Int_Secs := 0;
 331       else
 332          Int_Secs := Integer (Seconds - 0.5);
 333       end if;
 334
 335       --  Timbuf.wMillisec is to keep the msec. We can't use that because the
 336       --  high-resolution clock has a precision of 1 Microsecond.
 337       --  Anyway the sub-seconds part is not needed to compute the number
 338       --  of seconds in UTC.
 339
 340       if Int_Secs = 86_400 then
 341          Secs := 0;
 342          Add_One_Day := True;
 343       else
 344          Secs := Int_Secs;
 345       end if;
 346
 347       Timbuf.wMilliseconds := 0;
 348       Timbuf.wSecond       := WORD (Secs mod 60);
 349       Timbuf.wMinute       := WORD ((Secs / 60) mod 60);
 350       Timbuf.wHour         := WORD (Secs / 3600);
 351       Timbuf.wDay          := WORD (Day);
 352       Timbuf.wMonth        := WORD (Month);
 353       Timbuf.wYear         := WORD (Year);
 354
 355       if not SystemTimeToFileTime (Timbuf'Access, Loc'Access) then
 356          raise Time_Error;
 357       end if;
 358
 359       if not LocalFileTimeToFileTime (Loc'Access, Now'Access) then
 360          raise Time_Error;
 361       end if;
 362
 363       --  Here we have the UTC now translate UTC to Epoch time (UNIX style
 364       --  time based on 1 january 1970) and add there the sub-seconds part.
 365
 366       declare
 367          Sub_Sec  : Duration := Seconds - Duration (Int_Secs);
 368       begin
 369          Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) +
 370            Sub_Sec;
 371       end;
 372
 373       if Add_One_Day then
 374          Date := Date + Duration (86400.0);
 375       end if;
 376
 377       return Date;
 378    end Time_Of;
 379
 380    ----------
 381    -- Year --
 382    ----------
 383
 384    function Year (Date : Time) return Year_Number is
 385       DY : Year_Number;
 386       DM : Month_Number;
 387       DD : Day_Number;
 388       DS : Day_Duration;
 389
 390    begin
 391       Split (Date, DY, DM, DD, DS);
 392       return DY;
 393    end Year;
 394
 395 end Ada.Calendar;