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