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