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