gcc/ada/a-calend-vms.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-2009, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is the Alpha/VMS version
  33
  34 with Ada.Unchecked_Conversion;
  35
  36 with System.Aux_DEC;       use System.Aux_DEC;
  37 with System.OS_Primitives; use System.OS_Primitives;
  38
  39 package body Ada.Calendar is
  40
  41    --------------------------
  42    -- Implementation Notes --
  43    --------------------------
  44
  45    --  Variables of type Ada.Calendar.Time have suffix _S or _M to denote
  46    --  units of seconds or milis.
  47
  48    --  Because time is measured in different units and from different origins
  49    --  on various targets, a system independent model is incorporated into
  50    --  Ada.Calendar. The idea behind the design is to encapsulate all target
  51    --  dependent machinery in a single package, thus providing a uniform
  52    --  interface to all existing and any potential children.
  53
  54    --     package Ada.Calendar
  55    --        procedure Split (5 parameters) -------+
  56    --                                              | Call from local routine
  57    --     private                                  |
  58    --        package Formatting_Operations         |
  59    --           procedure Split (11 parameters) <--+
  60    --        end Formatting_Operations             |
  61    --     end Ada.Calendar                         |
  62    --                                              |
  63    --     package Ada.Calendar.Formatting          | Call from child routine
  64    --        procedure Split (9 or 10 parameters) -+
  65    --     end Ada.Calendar.Formatting
  66
  67    --  The behaviour of the interfacing routines is controlled via various
  68    --  flags. All new Ada 2005 types from children of Ada.Calendar are
  69    --  emulated by a similar type. For instance, type Day_Number is replaced
  70    --  by Integer in various routines. One ramification of this model is that
  71    --  the caller site must perform validity checks on returned results.
  72    --  The end result of this model is the lack of target specific files per
  73    --  child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc).
  74
  75    -----------------------
  76    -- Local Subprograms --
  77    -----------------------
  78
  79    procedure Check_Within_Time_Bounds (T : OS_Time);
  80    --  Ensure that a time representation value falls withing the bounds of Ada
  81    --  time. Leap seconds support is taken into account.
  82
  83    procedure Cumulative_Leap_Seconds
  84      (Start_Date    : OS_Time;
  85       End_Date      : OS_Time;
  86       Elapsed_Leaps : out Natural;
  87       Next_Leap_Sec : out OS_Time);
  88    --  Elapsed_Leaps is the sum of the leap seconds that have occurred on or
  89    --  after Start_Date and before (strictly before) End_Date. Next_Leap_Sec
  90    --  represents the next leap second occurrence on or after End_Date. If
  91    --  there are no leaps seconds after End_Date, End_Of_Time is returned.
  92    --  End_Of_Time can be used as End_Date to count all the leap seconds that
  93    --  have occurred on or after Start_Date.
  94    --
  95    --  Note: Any sub seconds of Start_Date and End_Date are discarded before
  96    --  the calculations are done. For instance: if 113 seconds is a leap
  97    --  second (it isn't) and 113.5 is input as an End_Date, the leap second
  98    --  at 113 will not be counted in Leaps_Between, but it will be returned
  99    --  as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is
 100    --  a leap second, the comparison should be:
 101    --
 102    --     End_Date >= Next_Leap_Sec;
 103    --
 104    --  After_Last_Leap is designed so that this comparison works without
 105    --  having to first check if Next_Leap_Sec is a valid leap second.
 106
 107    function To_Duration (T : Time) return Duration;
 108    function To_Relative_Time (D : Duration) return Time;
 109    --  It is important to note that duration's fractional part denotes nano
 110    --  seconds while the units of Time are 100 nanoseconds. If a regular
 111    --  Unchecked_Conversion was employed, the resulting values would be off
 112    --  by 100.
 113
 114    --------------------------
 115    -- Leap seconds control --
 116    --------------------------
 117
 118    Flag : Integer;
 119    pragma Import (C, Flag, "__gl_leap_seconds_support");
 120    --  This imported value is used to determine whether the compilation had
 121    --  binder flag "-y" present which enables leap seconds. A value of zero
 122    --  signifies no leap seconds support while a value of one enables the
 123    --  support.
 124
 125    Leap_Support : constant Boolean := Flag = 1;
 126    --  The above flag controls the usage of leap seconds in all Ada.Calendar
 127    --  routines.
 128
 129    Leap_Seconds_Count : constant Natural := 23;
 130
 131    ---------------------
 132    -- Local Constants --
 133    ---------------------
 134
 135    --  The range of Ada time expressed as milis since the VMS Epoch
 136
 137    Ada_Low  : constant OS_Time :=  (10 * 366 +  32 * 365 + 45) * Milis_In_Day;
 138    Ada_High : constant OS_Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day;
 139
 140    --  Even though the upper bound of time is 2399-12-31 23:59:59.9999999
 141    --  UTC, it must be increased to include all leap seconds.
 142
 143    Ada_High_And_Leaps : constant OS_Time :=
 144                           Ada_High + OS_Time (Leap_Seconds_Count) * Mili;
 145
 146    --  Two constants used in the calculations of elapsed leap seconds.
 147    --  End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time
 148    --  is earlier than Ada_Low in time zone +28.
 149
 150    End_Of_Time   : constant OS_Time := Ada_High + OS_Time (3) * Milis_In_Day;
 151    Start_Of_Time : constant OS_Time := Ada_Low  - OS_Time (3) * Milis_In_Day;
 152
 153    --  The following table contains the hard time values of all existing leap
 154    --  seconds. The values are produced by the utility program xleaps.adb.
 155
 156    Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of OS_Time :=
 157      (35855136000000000,
 158       36014112010000000,
 159       36329472020000000,
 160       36644832030000000,
 161       36960192040000000,
 162       37276416050000000,
 163       37591776060000000,
 164       37907136070000000,
 165       38222496080000000,
 166       38695104090000000,
 167       39010464100000000,
 168       39325824110000000,
 169       39957408120000000,
 170       40747104130000000,
 171       41378688140000000,
 172       41694048150000000,
 173       42166656160000000,
 174       42482016170000000,
 175       42797376180000000,
 176       43271712190000000,
 177       43744320200000000,
 178       44218656210000000,
 179       46427904220000000);
 180
 181    ---------
 182    -- "+" --
 183    ---------
 184
 185    function "+" (Left : Time; Right : Duration) return Time is
 186       pragma Unsuppress (Overflow_Check);
 187    begin
 188       return Left + To_Relative_Time (Right);
 189    exception
 190       when Constraint_Error =>
 191          raise Time_Error;
 192    end "+";
 193
 194    function "+" (Left : Duration; Right : Time) return Time is
 195       pragma Unsuppress (Overflow_Check);
 196    begin
 197       return Right + Left;
 198    exception
 199       when Constraint_Error =>
 200          raise Time_Error;
 201    end "+";
 202
 203    ---------
 204    -- "-" --
 205    ---------
 206
 207    function "-" (Left : Time; Right : Duration) return Time is
 208       pragma Unsuppress (Overflow_Check);
 209    begin
 210       return Left - To_Relative_Time (Right);
 211    exception
 212       when Constraint_Error =>
 213          raise Time_Error;
 214    end "-";
 215
 216    function "-" (Left : Time; Right : Time) return Duration is
 217       pragma Unsuppress (Overflow_Check);
 218
 219       --  The bound of type Duration expressed as time
 220
 221       Dur_High : constant OS_Time :=
 222                    OS_Time (To_Relative_Time (Duration'Last));
 223       Dur_Low  : constant OS_Time :=
 224                    OS_Time (To_Relative_Time (Duration'First));
 225
 226       Res_M : OS_Time;
 227
 228    begin
 229       Res_M := OS_Time (Left) - OS_Time (Right);
 230
 231       --  Due to the extended range of Ada time, "-" is capable of producing
 232       --  results which may exceed the range of Duration. In order to prevent
 233       --  the generation of bogus values by the Unchecked_Conversion, we apply
 234       --  the following check.
 235
 236       if Res_M < Dur_Low
 237         or else Res_M >= Dur_High
 238       then
 239          raise Time_Error;
 240
 241       --  Normal case, result fits
 242
 243       else
 244          return To_Duration (Time (Res_M));
 245       end if;
 246
 247    exception
 248       when Constraint_Error =>
 249          raise Time_Error;
 250    end "-";
 251
 252    ---------
 253    -- "<" --
 254    ---------
 255
 256    function "<" (Left, Right : Time) return Boolean is
 257    begin
 258       return OS_Time (Left) < OS_Time (Right);
 259    end "<";
 260
 261    ----------
 262    -- "<=" --
 263    ----------
 264
 265    function "<=" (Left, Right : Time) return Boolean is
 266    begin
 267       return OS_Time (Left) <= OS_Time (Right);
 268    end "<=";
 269
 270    ---------
 271    -- ">" --
 272    ---------
 273
 274    function ">" (Left, Right : Time) return Boolean is
 275    begin
 276       return OS_Time (Left) > OS_Time (Right);
 277    end ">";
 278
 279    ----------
 280    -- ">=" --
 281    ----------
 282
 283    function ">=" (Left, Right : Time) return Boolean is
 284    begin
 285       return OS_Time (Left) >= OS_Time (Right);
 286    end ">=";
 287
 288    ------------------------------
 289    -- Check_Within_Time_Bounds --
 290    ------------------------------
 291
 292    procedure Check_Within_Time_Bounds (T : OS_Time) is
 293    begin
 294       if Leap_Support then
 295          if T < Ada_Low or else T > Ada_High_And_Leaps then
 296             raise Time_Error;
 297          end if;
 298       else
 299          if T < Ada_Low or else T > Ada_High then
 300             raise Time_Error;
 301          end if;
 302       end if;
 303    end Check_Within_Time_Bounds;
 304
 305    -----------
 306    -- Clock --
 307    -----------
 308
 309    function Clock return Time is
 310       Elapsed_Leaps : Natural;
 311       Next_Leap_M   : OS_Time;
 312       Res_M         : constant OS_Time := OS_Clock;
 313
 314    begin
 315       --  Note that on other targets a soft-link is used to get a different
 316       --  clock depending whether tasking is used or not. On VMS this isn't
 317       --  needed since all clock calls end up using SYS$GETTIM, so call the
 318       --  OS_Primitives version for efficiency.
 319
 320       --  If the target supports leap seconds, determine the number of leap
 321       --  seconds elapsed until this moment.
 322
 323       if Leap_Support then
 324          Cumulative_Leap_Seconds
 325            (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M);
 326
 327          --  The system clock may fall exactly on a leap second
 328
 329          if Res_M >= Next_Leap_M then
 330             Elapsed_Leaps := Elapsed_Leaps + 1;
 331          end if;
 332
 333       --  The target does not support leap seconds
 334
 335       else
 336          Elapsed_Leaps := 0;
 337       end if;
 338
 339       return Time (Res_M + OS_Time (Elapsed_Leaps) * Mili);
 340    end Clock;
 341
 342    -----------------------------
 343    -- Cumulative_Leap_Seconds --
 344    -----------------------------
 345
 346    procedure Cumulative_Leap_Seconds
 347      (Start_Date    : OS_Time;
 348       End_Date      : OS_Time;
 349       Elapsed_Leaps : out Natural;
 350       Next_Leap_Sec : out OS_Time)
 351    is
 352       End_Index   : Positive;
 353       End_T       : OS_Time := End_Date;
 354       Start_Index : Positive;
 355       Start_T     : OS_Time := Start_Date;
 356
 357    begin
 358       pragma Assert (Leap_Support and then End_Date >= Start_Date);
 359
 360       Next_Leap_Sec := End_Of_Time;
 361
 362       --  Make sure that the end date does not exceed the upper bound
 363       --  of Ada time.
 364
 365       if End_Date > Ada_High then
 366          End_T := Ada_High;
 367       end if;
 368
 369       --  Remove the sub seconds from both dates
 370
 371       Start_T := Start_T - (Start_T mod Mili);
 372       End_T   := End_T   - (End_T   mod Mili);
 373
 374       --  Some trivial cases:
 375       --                     Leap 1 . . . Leap N
 376       --  ---+========+------+############+-------+========+-----
 377       --     Start_T  End_T                       Start_T  End_T
 378
 379       if End_T < Leap_Second_Times (1) then
 380          Elapsed_Leaps := 0;
 381          Next_Leap_Sec := Leap_Second_Times (1);
 382          return;
 383
 384       elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then
 385          Elapsed_Leaps := 0;
 386          Next_Leap_Sec := End_Of_Time;
 387          return;
 388       end if;
 389
 390       --  Perform the calculations only if the start date is within the leap
 391       --  second occurrences table.
 392
 393       if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then
 394
 395          --    1    2                  N - 1   N
 396          --  +----+----+--  . . .  --+-------+---+
 397          --  | T1 | T2 |             | N - 1 | N |
 398          --  +----+----+--  . . .  --+-------+---+
 399          --         ^                   ^
 400          --         | Start_Index       | End_Index
 401          --         +-------------------+
 402          --             Leaps_Between
 403
 404          --  The idea behind the algorithm is to iterate and find two closest
 405          --  dates which are after Start_T and End_T. Their corresponding
 406          --  index difference denotes the number of leap seconds elapsed.
 407
 408          Start_Index := 1;
 409          loop
 410             exit when Leap_Second_Times (Start_Index) >= Start_T;
 411             Start_Index := Start_Index + 1;
 412          end loop;
 413
 414          End_Index := Start_Index;
 415          loop
 416             exit when End_Index > Leap_Seconds_Count
 417               or else Leap_Second_Times (End_Index) >= End_T;
 418             End_Index := End_Index + 1;
 419          end loop;
 420
 421          if End_Index <= Leap_Seconds_Count then
 422             Next_Leap_Sec := Leap_Second_Times (End_Index);
 423          end if;
 424
 425          Elapsed_Leaps := End_Index - Start_Index;
 426
 427       else
 428          Elapsed_Leaps := 0;
 429       end if;
 430    end Cumulative_Leap_Seconds;
 431
 432    ---------
 433    -- Day --
 434    ---------
 435
 436    function Day (Date : Time) return Day_Number is
 437       Y : Year_Number;
 438       M : Month_Number;
 439       D : Day_Number;
 440       S : Day_Duration;
 441       pragma Unreferenced (Y, M, S);
 442    begin
 443       Split (Date, Y, M, D, S);
 444       return D;
 445    end Day;
 446
 447    -------------
 448    -- Is_Leap --
 449    -------------
 450
 451    function Is_Leap (Year : Year_Number) return Boolean is
 452    begin
 453       --  Leap centennial years
 454
 455       if Year mod 400 = 0 then
 456          return True;
 457
 458       --  Non-leap centennial years
 459
 460       elsif Year mod 100 = 0 then
 461          return False;
 462
 463       --  Regular years
 464
 465       else
 466          return Year mod 4 = 0;
 467       end if;
 468    end Is_Leap;
 469
 470    -----------
 471    -- Month --
 472    -----------
 473
 474    function Month (Date : Time) return Month_Number is
 475       Y : Year_Number;
 476       M : Month_Number;
 477       D : Day_Number;
 478       S : Day_Duration;
 479       pragma Unreferenced (Y, D, S);
 480    begin
 481       Split (Date, Y, M, D, S);
 482       return M;
 483    end Month;
 484
 485    -------------
 486    -- Seconds --
 487    -------------
 488
 489    function Seconds (Date : Time) return Day_Duration is
 490       Y : Year_Number;
 491       M : Month_Number;
 492       D : Day_Number;
 493       S : Day_Duration;
 494       pragma Unreferenced (Y, M, D);
 495    begin
 496       Split (Date, Y, M, D, S);
 497       return S;
 498    end Seconds;
 499
 500    -----------
 501    -- Split --
 502    -----------
 503
 504    procedure Split
 505      (Date    : Time;
 506       Year    : out Year_Number;
 507       Month   : out Month_Number;
 508       Day     : out Day_Number;
 509       Seconds : out Day_Duration)
 510    is
 511       H  : Integer;
 512       M  : Integer;
 513       Se : Integer;
 514       Ss : Duration;
 515       Le : Boolean;
 516
 517    begin
 518       --  Use UTC as the local time zone on VMS, the status of flag Is_Ada_05
 519       --  is irrelevant in this case.
 520
 521       Formatting_Operations.Split
 522         (Date      => Date,
 523          Year      => Year,
 524          Month     => Month,
 525          Day       => Day,
 526          Day_Secs  => Seconds,
 527          Hour      => H,
 528          Minute    => M,
 529          Second    => Se,
 530          Sub_Sec   => Ss,
 531          Leap_Sec  => Le,
 532          Is_Ada_05 => False,
 533          Time_Zone => 0);
 534
 535       --  Validity checks
 536
 537       if not Year'Valid
 538         or else not Month'Valid
 539         or else not Day'Valid
 540         or else not Seconds'Valid
 541       then
 542          raise Time_Error;
 543       end if;
 544    end Split;
 545
 546    -------------
 547    -- Time_Of --
 548    -------------
 549
 550    function Time_Of
 551      (Year    : Year_Number;
 552       Month   : Month_Number;
 553       Day     : Day_Number;
 554       Seconds : Day_Duration := 0.0) return Time
 555    is
 556       --  The values in the following constants are irrelevant, they are just
 557       --  placeholders; the choice of constructing a Day_Duration value is
 558       --  controlled by the Use_Day_Secs flag.
 559
 560       H  : constant Integer := 1;
 561       M  : constant Integer := 1;
 562       Se : constant Integer := 1;
 563       Ss : constant Duration := 0.1;
 564
 565    begin
 566       if not Year'Valid
 567         or else not Month'Valid
 568         or else not Day'Valid
 569         or else not Seconds'Valid
 570       then
 571          raise Time_Error;
 572       end if;
 573
 574       --  Use UTC as the local time zone on VMS, the status of flag Is_Ada_05
 575       --  is irrelevant in this case.
 576
 577       return
 578         Formatting_Operations.Time_Of
 579           (Year         => Year,
 580            Month        => Month,
 581            Day          => Day,
 582            Day_Secs     => Seconds,
 583            Hour         => H,
 584            Minute       => M,
 585            Second       => Se,
 586            Sub_Sec      => Ss,
 587            Leap_Sec     => False,
 588            Use_Day_Secs => True,
 589            Is_Ada_05    => False,
 590            Time_Zone    => 0);
 591    end Time_Of;
 592
 593    -----------------
 594    -- To_Duration --
 595    -----------------
 596
 597    function To_Duration (T : Time) return Duration is
 598       function Time_To_Duration is
 599         new Ada.Unchecked_Conversion (Time, Duration);
 600    begin
 601       return Time_To_Duration (T * 100);
 602    end To_Duration;
 603
 604    ----------------------
 605    -- To_Relative_Time --
 606    ----------------------
 607
 608    function To_Relative_Time (D : Duration) return Time is
 609       function Duration_To_Time is
 610         new Ada.Unchecked_Conversion (Duration, Time);
 611    begin
 612       return Duration_To_Time (D / 100.0);
 613    end To_Relative_Time;
 614
 615    ----------
 616    -- Year --
 617    ----------
 618
 619    function Year (Date : Time) return Year_Number is
 620       Y : Year_Number;
 621       M : Month_Number;
 622       D : Day_Number;
 623       S : Day_Duration;
 624       pragma Unreferenced (M, D, S);
 625    begin
 626       Split (Date, Y, M, D, S);
 627       return Y;
 628    end Year;
 629
 630    --  The following packages assume that Time is a Long_Integer, the units
 631    --  are 100 nanoseconds and the starting point in the VMS Epoch.
 632
 633    ---------------------------
 634    -- Arithmetic_Operations --
 635    ---------------------------
 636
 637    package body Arithmetic_Operations is
 638
 639       ---------
 640       -- Add --
 641       ---------
 642
 643       function Add (Date : Time; Days : Long_Integer) return Time is
 644          pragma Unsuppress (Overflow_Check);
 645          Date_M : constant OS_Time := OS_Time (Date);
 646       begin
 647          return Time (Date_M + OS_Time (Days) * Milis_In_Day);
 648       exception
 649          when Constraint_Error =>
 650             raise Time_Error;
 651       end Add;
 652
 653       ----------------
 654       -- Difference --
 655       ----------------
 656
 657       procedure Difference
 658         (Left         : Time;
 659          Right        : Time;
 660          Days         : out Long_Integer;
 661          Seconds      : out Duration;
 662          Leap_Seconds : out Integer)
 663       is
 664          Diff_M        : OS_Time;
 665          Diff_S        : OS_Time;
 666          Earlier       : OS_Time;
 667          Elapsed_Leaps : Natural;
 668          Later         : OS_Time;
 669          Negate        : Boolean := False;
 670          Next_Leap     : OS_Time;
 671          Sub_Seconds   : Duration;
 672
 673       begin
 674          --  This classification is necessary in order to avoid a Time_Error
 675          --  being raised by the arithmetic operators in Ada.Calendar.
 676
 677          if Left >= Right then
 678             Later   := OS_Time (Left);
 679             Earlier := OS_Time (Right);
 680          else
 681             Later   := OS_Time (Right);
 682             Earlier := OS_Time (Left);
 683             Negate  := True;
 684          end if;
 685
 686          --  If the target supports leap seconds, process them
 687
 688          if Leap_Support then
 689             Cumulative_Leap_Seconds
 690               (Earlier, Later, Elapsed_Leaps, Next_Leap);
 691
 692             if Later >= Next_Leap then
 693                Elapsed_Leaps := Elapsed_Leaps + 1;
 694             end if;
 695
 696          --  The target does not support leap seconds
 697
 698          else
 699             Elapsed_Leaps := 0;
 700          end if;
 701
 702          Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili;
 703
 704          --  Sub second processing
 705
 706          Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F;
 707
 708          --  Convert to seconds. Note that his action eliminates the sub
 709          --  seconds automatically.
 710
 711          Diff_S := Diff_M / Mili;
 712
 713          Days := Long_Integer (Diff_S / Secs_In_Day);
 714          Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds;
 715          Leap_Seconds := Integer (Elapsed_Leaps);
 716
 717          if Negate then
 718             Days    := -Days;
 719             Seconds := -Seconds;
 720
 721             if Leap_Seconds /= 0 then
 722                Leap_Seconds := -Leap_Seconds;
 723             end if;
 724          end if;
 725       end Difference;
 726
 727       --------------
 728       -- Subtract --
 729       --------------
 730
 731       function Subtract (Date : Time; Days : Long_Integer) return Time is
 732          pragma Unsuppress (Overflow_Check);
 733          Date_M : constant OS_Time := OS_Time (Date);
 734       begin
 735          return Time (Date_M - OS_Time (Days) * Milis_In_Day);
 736       exception
 737          when Constraint_Error =>
 738             raise Time_Error;
 739       end Subtract;
 740    end Arithmetic_Operations;
 741
 742    ---------------------------
 743    -- Conversion_Operations --
 744    ---------------------------
 745
 746    package body Conversion_Operations is
 747
 748       Epoch_Offset : constant OS_Time := 35067168000000000;
 749       --  The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in
 750       --  100 nanoseconds.
 751
 752       -----------------
 753       -- To_Ada_Time --
 754       -----------------
 755
 756       function To_Ada_Time (Unix_Time : Long_Integer) return Time is
 757          pragma Unsuppress (Overflow_Check);
 758          Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili;
 759       begin
 760          return Time (Unix_Rep + Epoch_Offset);
 761       exception
 762          when Constraint_Error =>
 763             raise Time_Error;
 764       end To_Ada_Time;
 765
 766       -----------------
 767       -- To_Ada_Time --
 768       -----------------
 769
 770       function To_Ada_Time
 771         (tm_year  : Integer;
 772          tm_mon   : Integer;
 773          tm_day   : Integer;
 774          tm_hour  : Integer;
 775          tm_min   : Integer;
 776          tm_sec   : Integer;
 777          tm_isdst : Integer) return Time
 778       is
 779          pragma Unsuppress (Overflow_Check);
 780
 781          Year_Shift  : constant Integer := 1900;
 782          Month_Shift : constant Integer := 1;
 783
 784          Year   : Year_Number;
 785          Month  : Month_Number;
 786          Day    : Day_Number;
 787          Second : Integer;
 788          Leap   : Boolean;
 789          Result : OS_Time;
 790
 791       begin
 792          --  Input processing
 793
 794          Year  := Year_Number (Year_Shift + tm_year);
 795          Month := Month_Number (Month_Shift + tm_mon);
 796          Day   := Day_Number (tm_day);
 797
 798          --  Step 1: Validity checks of input values
 799
 800          if not Year'Valid
 801            or else not Month'Valid
 802            or else not Day'Valid
 803            or else tm_hour not in 0 .. 24
 804            or else tm_min not in 0 .. 59
 805            or else tm_sec not in 0 .. 60
 806            or else tm_isdst not in -1 .. 1
 807          then
 808             raise Time_Error;
 809          end if;
 810
 811          --  Step 2: Potential leap second
 812
 813          if tm_sec = 60 then
 814             Leap   := True;
 815             Second := 59;
 816          else
 817             Leap   := False;
 818             Second := tm_sec;
 819          end if;
 820
 821          --  Step 3: Calculate the time value
 822
 823          Result :=
 824            OS_Time
 825              (Formatting_Operations.Time_Of
 826                (Year         => Year,
 827                 Month        => Month,
 828                 Day          => Day,
 829                 Day_Secs     => 0.0,      --  Time is given in h:m:s
 830                 Hour         => tm_hour,
 831                 Minute       => tm_min,
 832                 Second       => Second,
 833                 Sub_Sec      => 0.0,      --  No precise sub second given
 834                 Leap_Sec     => Leap,
 835                 Use_Day_Secs => False,    --  Time is given in h:m:s
 836                 Is_Ada_05    => True,     --  Force usage of explicit time zone
 837                 Time_Zone    => 0));      --  Place the value in UTC
 838          --  Step 4: Daylight Savings Time
 839
 840          if tm_isdst = 1 then
 841             Result := Result + OS_Time (3_600) * Mili;
 842          end if;
 843
 844          return Time (Result);
 845       exception
 846          when Constraint_Error =>
 847             raise Time_Error;
 848       end To_Ada_Time;
 849
 850       -----------------
 851       -- To_Duration --
 852       -----------------
 853
 854       function To_Duration
 855         (tv_sec  : Long_Integer;
 856          tv_nsec : Long_Integer) return Duration
 857       is
 858          pragma Unsuppress (Overflow_Check);
 859       begin
 860          return Duration (tv_sec) + Duration (tv_nsec) / Mili_F;
 861       end To_Duration;
 862
 863       ------------------------
 864       -- To_Struct_Timespec --
 865       ------------------------
 866
 867       procedure To_Struct_Timespec
 868         (D       : Duration;
 869          tv_sec  : out Long_Integer;
 870          tv_nsec : out Long_Integer)
 871       is
 872          pragma Unsuppress (Overflow_Check);
 873          Secs      : Duration;
 874          Nano_Secs : Duration;
 875
 876       begin
 877          --  Seconds extraction, avoid potential rounding errors
 878
 879          Secs   := D - 0.5;
 880          tv_sec := Long_Integer (Secs);
 881
 882          --  100 Nanoseconds extraction
 883
 884          Nano_Secs := D - Duration (tv_sec);
 885          tv_nsec := Long_Integer (Nano_Secs * Mili);
 886       end To_Struct_Timespec;
 887
 888       ------------------
 889       -- To_Struct_Tm --
 890       ------------------
 891
 892       procedure To_Struct_Tm
 893         (T       : Time;
 894          tm_year : out Integer;
 895          tm_mon  : out Integer;
 896          tm_day  : out Integer;
 897          tm_hour : out Integer;
 898          tm_min  : out Integer;
 899          tm_sec  : out Integer)
 900       is
 901          pragma Unsuppress (Overflow_Check);
 902          Year      : Year_Number;
 903          Month     : Month_Number;
 904          Second    : Integer;
 905          Day_Secs  : Day_Duration;
 906          Sub_Sec   : Duration;
 907          Leap_Sec  : Boolean;
 908
 909       begin
 910          --  Step 1: Split the input time
 911
 912          Formatting_Operations.Split
 913            (T, Year, Month, tm_day, Day_Secs,
 914             tm_hour, tm_min, Second, Sub_Sec, Leap_Sec, True, 0);
 915
 916          --  Step 2: Correct the year and month
 917
 918          tm_year := Year - 1900;
 919          tm_mon  := Month - 1;
 920
 921          --  Step 3: Handle leap second occurrences
 922
 923          if Leap_Sec then
 924             tm_sec := 60;
 925          else
 926             tm_sec := Second;
 927          end if;
 928       end To_Struct_Tm;
 929
 930       ------------------
 931       -- To_Unix_Time --
 932       ------------------
 933
 934       function To_Unix_Time (Ada_Time : Time) return Long_Integer is
 935          pragma Unsuppress (Overflow_Check);
 936          Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time);
 937       begin
 938          return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili);
 939       exception
 940          when Constraint_Error =>
 941             raise Time_Error;
 942       end To_Unix_Time;
 943    end Conversion_Operations;
 944
 945    ---------------------------
 946    -- Formatting_Operations --
 947    ---------------------------
 948
 949    package body Formatting_Operations is
 950
 951       -----------------
 952       -- Day_Of_Week --
 953       -----------------
 954
 955       function Day_Of_Week (Date : Time) return Integer is
 956          Y : Year_Number;
 957          M : Month_Number;
 958          D : Day_Number;
 959          S : Day_Duration;
 960
 961          Day_Count     : Long_Integer;
 962          Midday_Date_S : Time;
 963
 964       begin
 965          Split (Date, Y, M, D, S);
 966
 967          --  Build a time value in the middle of the same day and convert the
 968          --  time value to seconds.
 969
 970          Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili;
 971
 972          --  Count the number of days since the start of VMS time. 1858-11-17
 973          --  was a Wednesday.
 974
 975          Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2;
 976
 977          return Integer (Day_Count mod 7);
 978       end Day_Of_Week;
 979
 980       -----------
 981       -- Split --
 982       -----------
 983
 984       procedure Split
 985         (Date      : Time;
 986          Year      : out Year_Number;
 987          Month     : out Month_Number;
 988          Day       : out Day_Number;
 989          Day_Secs  : out Day_Duration;
 990          Hour      : out Integer;
 991          Minute    : out Integer;
 992          Second    : out Integer;
 993          Sub_Sec   : out Duration;
 994          Leap_Sec  : out Boolean;
 995          Is_Ada_05 : Boolean;
 996          Time_Zone : Long_Integer)
 997       is
 998          --  The flag Is_Ada_05 is present for interfacing purposes
 999
1000          pragma Unreferenced (Is_Ada_05);
1001
1002          procedure Numtim
1003            (Status : out Unsigned_Longword;
1004             Timbuf : out Unsigned_Word_Array;
1005             Timadr : Time);
1006
1007          pragma Interface (External, Numtim);
1008
1009          pragma Import_Valued_Procedure
1010            (Numtim, "SYS$NUMTIM",
1011            (Unsigned_Longword, Unsigned_Word_Array, Time),
1012            (Value, Reference, Reference));
1013
1014          Status : Unsigned_Longword;
1015          Timbuf : Unsigned_Word_Array (1 .. 7);
1016
1017          Ada_Min_Year : constant := 1901;
1018          Ada_Max_Year : constant := 2399;
1019
1020          Date_M        : OS_Time;
1021          Elapsed_Leaps : Natural;
1022          Next_Leap_M   : OS_Time;
1023
1024       begin
1025          Date_M := OS_Time (Date);
1026
1027          --  Step 1: Leap seconds processing
1028
1029          if Leap_Support then
1030             Cumulative_Leap_Seconds
1031               (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M);
1032
1033             Leap_Sec := Date_M >= Next_Leap_M;
1034
1035             if Leap_Sec then
1036                Elapsed_Leaps := Elapsed_Leaps + 1;
1037             end if;
1038
1039          --  The target does not support leap seconds
1040
1041          else
1042             Elapsed_Leaps := 0;
1043             Leap_Sec      := False;
1044          end if;
1045
1046          Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili;
1047
1048          --  Step 2: Time zone processing
1049
1050          if Time_Zone /= 0 then
1051             Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili;
1052          end if;
1053
1054          --  After the leap seconds and time zone have been accounted for,
1055          --  the date should be within the bounds of Ada time.
1056
1057          if Date_M < Ada_Low
1058            or else Date_M > Ada_High
1059          then
1060             raise Time_Error;
1061          end if;
1062
1063          --  Step 3: Sub second processing
1064
1065          Sub_Sec := Duration (Date_M mod Mili) / Mili_F;
1066
1067          --  Drop the sub seconds
1068
1069          Date_M := Date_M - (Date_M mod Mili);
1070
1071          --  Step 4: VMS system call
1072
1073          Numtim (Status, Timbuf, Time (Date_M));
1074
1075          if Status mod 2 /= 1
1076            or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year
1077          then
1078             raise Time_Error;
1079          end if;
1080
1081          --  Step 5: Time components processing
1082
1083          Year   := Year_Number (Timbuf (1));
1084          Month  := Month_Number (Timbuf (2));
1085          Day    := Day_Number (Timbuf (3));
1086          Hour   := Integer (Timbuf (4));
1087          Minute := Integer (Timbuf (5));
1088          Second := Integer (Timbuf (6));
1089
1090          Day_Secs := Day_Duration (Hour   * 3_600) +
1091                      Day_Duration (Minute *    60) +
1092                      Day_Duration (Second)         +
1093                                    Sub_Sec;
1094       end Split;
1095
1096       -------------
1097       -- Time_Of --
1098       -------------
1099
1100       function Time_Of
1101         (Year         : Year_Number;
1102          Month        : Month_Number;
1103          Day          : Day_Number;
1104          Day_Secs     : Day_Duration;
1105          Hour         : Integer;
1106          Minute       : Integer;
1107          Second       : Integer;
1108          Sub_Sec      : Duration;
1109          Leap_Sec     : Boolean := False;
1110          Use_Day_Secs : Boolean := False;
1111          Is_Ada_05    : Boolean := False;
1112          Time_Zone    : Long_Integer := 0) return Time
1113       is
1114          procedure Cvt_Vectim
1115            (Status         : out Unsigned_Longword;
1116             Input_Time     : Unsigned_Word_Array;
1117             Resultant_Time : out Time);
1118
1119          pragma Interface (External, Cvt_Vectim);
1120
1121          pragma Import_Valued_Procedure
1122            (Cvt_Vectim, "LIB$CVT_VECTIM",
1123            (Unsigned_Longword, Unsigned_Word_Array, Time),
1124            (Value, Reference, Reference));
1125
1126          Status : Unsigned_Longword;
1127          Timbuf : Unsigned_Word_Array (1 .. 7);
1128
1129          Y  : Year_Number  := Year;
1130          Mo : Month_Number := Month;
1131          D  : Day_Number   := Day;
1132          H  : Integer      := Hour;
1133          Mi : Integer      := Minute;
1134          Se : Integer      := Second;
1135          Su : Duration     := Sub_Sec;
1136
1137          Elapsed_Leaps : Natural;
1138          Int_Day_Secs  : Integer;
1139          Next_Leap_M   : OS_Time;
1140          Res           : Time;
1141          Res_M         : OS_Time;
1142          Rounded_Res_M : OS_Time;
1143
1144       begin
1145          --  No validity checks are performed on the input values since it is
1146          --  assumed that the called has already performed them.
1147
1148          --  Step 1: Hour, minute, second and sub second processing
1149
1150          if Use_Day_Secs then
1151
1152             --  A day seconds value of 86_400 designates a new day
1153
1154             if Day_Secs = 86_400.0 then
1155                declare
1156                   Adj_Year  : Year_Number := Year;
1157                   Adj_Month : Month_Number := Month;
1158                   Adj_Day   : Day_Number   := Day;
1159
1160                begin
1161                   if Day < Days_In_Month (Month)
1162                     or else (Month = 2
1163                                and then Is_Leap (Year))
1164                   then
1165                      Adj_Day := Day + 1;
1166
1167                   --  The day adjustment moves the date to a new month
1168
1169                   else
1170                      Adj_Day := 1;
1171
1172                      if Month < 12 then
1173                         Adj_Month := Month + 1;
1174
1175                      --  The month adjustment moves the date to a new year
1176
1177                      else
1178                         Adj_Month := 1;
1179                         Adj_Year  := Year + 1;
1180                      end if;
1181                   end if;
1182
1183                   Y  := Adj_Year;
1184                   Mo := Adj_Month;
1185                   D  := Adj_Day;
1186                   H  := 0;
1187                   Mi := 0;
1188                   Se := 0;
1189                   Su := 0.0;
1190                end;
1191
1192             --  Normal case (not exactly one day)
1193
1194             else
1195                --  Sub second extraction
1196
1197                if Day_Secs > 0.0 then
1198                   Int_Day_Secs := Integer (Day_Secs - 0.5);
1199                else
1200                   Int_Day_Secs := Integer (Day_Secs);
1201                end if;
1202
1203                H  := Int_Day_Secs / 3_600;
1204                Mi := (Int_Day_Secs / 60) mod 60;
1205                Se := Int_Day_Secs mod 60;
1206                Su := Day_Secs - Duration (Int_Day_Secs);
1207             end if;
1208          end if;
1209
1210          --  Step 2: System call to VMS
1211
1212          Timbuf (1) := Unsigned_Word (Y);
1213          Timbuf (2) := Unsigned_Word (Mo);
1214          Timbuf (3) := Unsigned_Word (D);
1215          Timbuf (4) := Unsigned_Word (H);
1216          Timbuf (5) := Unsigned_Word (Mi);
1217          Timbuf (6) := Unsigned_Word (Se);
1218          Timbuf (7) := 0;
1219
1220          Cvt_Vectim (Status, Timbuf, Res);
1221
1222          if Status mod 2 /= 1 then
1223             raise Time_Error;
1224          end if;
1225
1226          --  Step 3: Sub second adjustment
1227
1228          Res_M := OS_Time (Res) + OS_Time (Su * Mili_F);
1229
1230          --  Step 4: Bounds check
1231
1232          Check_Within_Time_Bounds (Res_M);
1233
1234          --  Step 5: Time zone processing
1235
1236          if Time_Zone /= 0 then
1237             Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili;
1238          end if;
1239
1240          --  Step 6: Leap seconds processing
1241
1242          if Leap_Support then
1243             Cumulative_Leap_Seconds
1244               (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M);
1245
1246             Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili;
1247
1248             --  An Ada 2005 caller requesting an explicit leap second or an
1249             --  Ada 95 caller accounting for an invisible leap second.
1250
1251             if Leap_Sec
1252               or else Res_M >= Next_Leap_M
1253             then
1254                Res_M := Res_M + OS_Time (1) * Mili;
1255             end if;
1256
1257             --  Leap second validity check
1258
1259             Rounded_Res_M := Res_M - (Res_M mod Mili);
1260
1261             if Is_Ada_05
1262               and then Leap_Sec
1263               and then Rounded_Res_M /= Next_Leap_M
1264             then
1265                raise Time_Error;
1266             end if;
1267          end if;
1268
1269          return Time (Res_M);
1270       end Time_Of;
1271    end Formatting_Operations;
1272
1273    ---------------------------
1274    -- Time_Zones_Operations --
1275    ---------------------------
1276
1277    package body Time_Zones_Operations is
1278
1279       ---------------------
1280       -- UTC_Time_Offset --
1281       ---------------------
1282
1283       function UTC_Time_Offset (Date : Time) return Long_Integer is
1284          --  Formal parameter Date is here for interfacing, but is never
1285          --  actually used.
1286
1287          pragma Unreferenced (Date);
1288
1289          function get_gmtoff return Long_Integer;
1290          pragma Import (C, get_gmtoff, "get_gmtoff");
1291
1292       begin
1293          --  VMS is not capable of determining the time zone in some past or
1294          --  future point in time denoted by Date, thus the current time zone
1295          --  is retrieved.
1296
1297          return get_gmtoff;
1298       end UTC_Time_Offset;
1299    end Time_Zones_Operations;
1300 end Ada.Calendar;