old-autovect-branch/gcc/ada/a-calend-mingw.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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 --  Why do we need separate version ???
  37 --  Do we need *this* much code duplication???
  38
  39 with System.OS_Primitives;
  40 --  used for Clock
  41
  42 with System.OS_Interface;
  43
  44 package body Ada.Calendar is
  45
  46    use System.OS_Interface;
  47
  48    ------------------------------
  49    -- Use of Pragma Unsuppress --
  50    ------------------------------
  51
  52    --  This implementation of Calendar takes advantage of the permission in
  53    --  Ada 95 of using arithmetic overflow checks to check for out of bounds
  54    --  time values. This means that we must catch the constraint error that
  55    --  results from arithmetic overflow, so we use pragma Unsuppress to make
  56    --  sure that overflow is enabled, using software overflow checking if
  57    --  necessary. That way, compiling Calendar with options to suppress this
  58    --  checking will not affect its correctness.
  59
  60    ------------------------
  61    -- Local Declarations --
  62    ------------------------
  63
  64    Ada_Year_Min : constant := 1901;
  65    Ada_Year_Max : constant := 2099;
  66
  67    --  Win32 time constants
  68
  69    epoch_1970     : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
  70    system_time_ns : constant := 100;                    -- 100 ns per tick
  71    Sec_Unit       : constant := 10#1#E9;
  72
  73    ---------
  74    -- "+" --
  75    ---------
  76
  77    function "+" (Left : Time; Right : Duration) return Time is
  78       pragma Unsuppress (Overflow_Check);
  79    begin
  80       return (Left + Time (Right));
  81
  82    exception
  83       when Constraint_Error =>
  84          raise Time_Error;
  85    end "+";
  86
  87    function "+" (Left : Duration; Right : Time) return Time is
  88       pragma Unsuppress (Overflow_Check);
  89    begin
  90       return (Time (Left) + Right);
  91
  92    exception
  93       when Constraint_Error =>
  94          raise Time_Error;
  95    end "+";
  96
  97    ---------
  98    -- "-" --
  99    ---------
 100
 101    function "-" (Left : Time; Right : Duration)  return Time is
 102       pragma Unsuppress (Overflow_Check);
 103    begin
 104       return Left - Time (Right);
 105
 106    exception
 107       when Constraint_Error =>
 108          raise Time_Error;
 109    end "-";
 110
 111    function "-" (Left : Time; Right : Time) return Duration is
 112       pragma Unsuppress (Overflow_Check);
 113    begin
 114       return Duration (Left) - Duration (Right);
 115
 116    exception
 117       when Constraint_Error =>
 118          raise Time_Error;
 119    end "-";
 120
 121    ---------
 122    -- "<" --
 123    ---------
 124
 125    function "<" (Left, Right : Time) return Boolean is
 126    begin
 127       return Duration (Left) < Duration (Right);
 128    end "<";
 129
 130    ----------
 131    -- "<=" --
 132    ----------
 133
 134    function "<=" (Left, Right : Time) return Boolean is
 135    begin
 136       return Duration (Left) <= Duration (Right);
 137    end "<=";
 138
 139    ---------
 140    -- ">" --
 141    ---------
 142
 143    function ">" (Left, Right : Time) return Boolean is
 144    begin
 145       return Duration (Left) > Duration (Right);
 146    end ">";
 147
 148    ----------
 149    -- ">=" --
 150    ----------
 151
 152    function ">=" (Left, Right : Time) return Boolean is
 153    begin
 154       return Duration (Left) >= Duration (Right);
 155    end ">=";
 156
 157    -----------
 158    -- Clock --
 159    -----------
 160
 161    --  The Ada.Calendar.Clock function gets the time from the soft links
 162    --  interface which will call the appropriate function depending wether
 163    --  tasking is involved or not.
 164
 165    function Clock return Time is
 166    begin
 167       return Time (System.OS_Primitives.Clock);
 168    end Clock;
 169
 170    ---------
 171    -- Day --
 172    ---------
 173
 174    function Day (Date : Time) return Day_Number is
 175       DY : Year_Number;
 176       DM : Month_Number;
 177       DD : Day_Number;
 178       DS : Day_Duration;
 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    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 : constant 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 begin
 396    System.OS_Primitives.Initialize;
 397 end Ada.Calendar;