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