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          if Leap_Sec then
 925             tm_sec := 60;
 926          else
 927             tm_sec := Second;
 928          end if;
 929       end To_Struct_Tm;
 930
 931       ------------------
 932       -- To_Unix_Time --
 933       ------------------
 934
 935       function To_Unix_Time (Ada_Time : Time) return Long_Integer is
 936          pragma Unsuppress (Overflow_Check);
 937          Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time);
 938       begin
 939          return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili);
 940       exception
 941          when Constraint_Error =>
 942             raise Time_Error;
 943       end To_Unix_Time;
 944    end Conversion_Operations;
 945
 946    ---------------------------
 947    -- Formatting_Operations --
 948    ---------------------------
 949
 950    package body Formatting_Operations is
 951
 952       -----------------
 953       -- Day_Of_Week --
 954       -----------------
 955
 956       function Day_Of_Week (Date : Time) return Integer is
 957          Y : Year_Number;
 958          M : Month_Number;
 959          D : Day_Number;
 960          S : Day_Duration;
 961
 962          Day_Count     : Long_Integer;
 963          Midday_Date_S : Time;
 964
 965       begin
 966          Split (Date, Y, M, D, S);
 967
 968          --  Build a time value in the middle of the same day and convert the
 969          --  time value to seconds.
 970
 971          Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili;
 972
 973          --  Count the number of days since the start of VMS time. 1858-11-17
 974          --  was a Wednesday.
 975
 976          Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2;
 977
 978          return Integer (Day_Count mod 7);
 979       end Day_Of_Week;
 980
 981       -----------
 982       -- Split --
 983       -----------
 984
 985       procedure Split
 986         (Date      : Time;
 987          Year      : out Year_Number;
 988          Month     : out Month_Number;
 989          Day       : out Day_Number;
 990          Day_Secs  : out Day_Duration;
 991          Hour      : out Integer;
 992          Minute    : out Integer;
 993          Second    : out Integer;
 994          Sub_Sec   : out Duration;
 995          Leap_Sec  : out Boolean;
 996          Is_Ada_05 : Boolean;
 997          Time_Zone : Long_Integer)
 998       is
 999          --  The flag Is_Ada_05 is present for interfacing purposes
1000
1001          pragma Unreferenced (Is_Ada_05);
1002
1003          procedure Numtim
1004            (Status : out Unsigned_Longword;
1005             Timbuf : out Unsigned_Word_Array;
1006             Timadr : Time);
1007
1008          pragma Interface (External, Numtim);
1009
1010          pragma Import_Valued_Procedure
1011            (Numtim, "SYS$NUMTIM",
1012            (Unsigned_Longword, Unsigned_Word_Array, Time),
1013            (Value, Reference, Reference));
1014
1015          Status : Unsigned_Longword;
1016          Timbuf : Unsigned_Word_Array (1 .. 7);
1017
1018          Ada_Min_Year : constant := 1901;
1019          Ada_Max_Year : constant := 2399;
1020
1021          Date_M        : OS_Time;
1022          Elapsed_Leaps : Natural;
1023          Next_Leap_M   : OS_Time;
1024
1025       begin
1026          Date_M := OS_Time (Date);
1027
1028          --  Step 1: Leap seconds processing
1029
1030          if Leap_Support then
1031             Cumulative_Leap_Seconds
1032               (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M);
1033
1034             Leap_Sec := Date_M >= Next_Leap_M;
1035
1036             if Leap_Sec then
1037                Elapsed_Leaps := Elapsed_Leaps + 1;
1038             end if;
1039
1040          --  The target does not support leap seconds
1041
1042          else
1043             Elapsed_Leaps := 0;
1044             Leap_Sec      := False;
1045          end if;
1046
1047          Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili;
1048
1049          --  Step 2: Time zone processing
1050
1051          if Time_Zone /= 0 then
1052             Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili;
1053          end if;
1054
1055          --  After the leap seconds and time zone have been accounted for,
1056          --  the date should be within the bounds of Ada time.
1057
1058          if Date_M < Ada_Low
1059            or else Date_M > Ada_High
1060          then
1061             raise Time_Error;
1062          end if;
1063
1064          --  Step 3: Sub second processing
1065
1066          Sub_Sec := Duration (Date_M mod Mili) / Mili_F;
1067
1068          --  Drop the sub seconds
1069
1070          Date_M := Date_M - (Date_M mod Mili);
1071
1072          --  Step 4: VMS system call
1073
1074          Numtim (Status, Timbuf, Time (Date_M));
1075
1076          if Status mod 2 /= 1
1077            or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year
1078          then
1079             raise Time_Error;
1080          end if;
1081
1082          --  Step 5: Time components processing
1083
1084          Year   := Year_Number (Timbuf (1));
1085          Month  := Month_Number (Timbuf (2));
1086          Day    := Day_Number (Timbuf (3));
1087          Hour   := Integer (Timbuf (4));
1088          Minute := Integer (Timbuf (5));
1089          Second := Integer (Timbuf (6));
1090
1091          Day_Secs := Day_Duration (Hour   * 3_600) +
1092                      Day_Duration (Minute *    60) +
1093                      Day_Duration (Second)         +
1094                                    Sub_Sec;
1095       end Split;
1096
1097       -------------
1098       -- Time_Of --
1099       -------------
1100
1101       function Time_Of
1102         (Year         : Year_Number;
1103          Month        : Month_Number;
1104          Day          : Day_Number;
1105          Day_Secs     : Day_Duration;
1106          Hour         : Integer;
1107          Minute       : Integer;
1108          Second       : Integer;
1109          Sub_Sec      : Duration;
1110          Leap_Sec     : Boolean := False;
1111          Use_Day_Secs : Boolean := False;
1112          Is_Ada_05    : Boolean := False;
1113          Time_Zone    : Long_Integer := 0) return Time
1114       is
1115          procedure Cvt_Vectim
1116            (Status         : out Unsigned_Longword;
1117             Input_Time     : Unsigned_Word_Array;
1118             Resultant_Time : out Time);
1119
1120          pragma Interface (External, Cvt_Vectim);
1121
1122          pragma Import_Valued_Procedure
1123            (Cvt_Vectim, "LIB$CVT_VECTIM",
1124            (Unsigned_Longword, Unsigned_Word_Array, Time),
1125            (Value, Reference, Reference));
1126
1127          Status : Unsigned_Longword;
1128          Timbuf : Unsigned_Word_Array (1 .. 7);
1129
1130          Y  : Year_Number  := Year;
1131          Mo : Month_Number := Month;
1132          D  : Day_Number   := Day;
1133          H  : Integer      := Hour;
1134          Mi : Integer      := Minute;
1135          Se : Integer      := Second;
1136          Su : Duration     := Sub_Sec;
1137
1138          Elapsed_Leaps : Natural;
1139          Int_Day_Secs  : Integer;
1140          Next_Leap_M   : OS_Time;
1141          Res           : Time;
1142          Res_M         : OS_Time;
1143          Rounded_Res_M : OS_Time;
1144
1145       begin
1146          --  No validity checks are performed on the input values since it is
1147          --  assumed that the called has already performed them.
1148
1149          --  Step 1: Hour, minute, second and sub second processing
1150
1151          if Use_Day_Secs then
1152
1153             --  A day seconds value of 86_400 designates a new day
1154
1155             if Day_Secs = 86_400.0 then
1156                declare
1157                   Adj_Year  : Year_Number := Year;
1158                   Adj_Month : Month_Number := Month;
1159                   Adj_Day   : Day_Number   := Day;
1160
1161                begin
1162                   if Day < Days_In_Month (Month)
1163                     or else (Month = 2
1164                                and then Is_Leap (Year))
1165                   then
1166                      Adj_Day := Day + 1;
1167
1168                   --  The day adjustment moves the date to a new month
1169
1170                   else
1171                      Adj_Day := 1;
1172
1173                      if Month < 12 then
1174                         Adj_Month := Month + 1;
1175
1176                      --  The month adjustment moves the date to a new year
1177
1178                      else
1179                         Adj_Month := 1;
1180                         Adj_Year  := Year + 1;
1181                      end if;
1182                   end if;
1183
1184                   Y  := Adj_Year;
1185                   Mo := Adj_Month;
1186                   D  := Adj_Day;
1187                   H  := 0;
1188                   Mi := 0;
1189                   Se := 0;
1190                   Su := 0.0;
1191                end;
1192
1193             --  Normal case (not exactly one day)
1194
1195             else
1196                --  Sub second extraction
1197
1198                if Day_Secs > 0.0 then
1199                   Int_Day_Secs := Integer (Day_Secs - 0.5);
1200                else
1201                   Int_Day_Secs := Integer (Day_Secs);
1202                end if;
1203
1204                H  := Int_Day_Secs / 3_600;
1205                Mi := (Int_Day_Secs / 60) mod 60;
1206                Se := Int_Day_Secs mod 60;
1207                Su := Day_Secs - Duration (Int_Day_Secs);
1208             end if;
1209          end if;
1210
1211          --  Step 2: System call to VMS
1212
1213          Timbuf (1) := Unsigned_Word (Y);
1214          Timbuf (2) := Unsigned_Word (Mo);
1215          Timbuf (3) := Unsigned_Word (D);
1216          Timbuf (4) := Unsigned_Word (H);
1217          Timbuf (5) := Unsigned_Word (Mi);
1218          Timbuf (6) := Unsigned_Word (Se);
1219          Timbuf (7) := 0;
1220
1221          Cvt_Vectim (Status, Timbuf, Res);
1222
1223          if Status mod 2 /= 1 then
1224             raise Time_Error;
1225          end if;
1226
1227          --  Step 3: Sub second adjustment
1228
1229          Res_M := OS_Time (Res) + OS_Time (Su * Mili_F);
1230
1231          --  Step 4: Bounds check
1232
1233          Check_Within_Time_Bounds (Res_M);
1234
1235          --  Step 5: Time zone processing
1236
1237          if Time_Zone /= 0 then
1238             Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili;
1239          end if;
1240
1241          --  Step 6: Leap seconds processing
1242
1243          if Leap_Support then
1244             Cumulative_Leap_Seconds
1245               (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M);
1246
1247             Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili;
1248
1249             --  An Ada 2005 caller requesting an explicit leap second or an
1250             --  Ada 95 caller accounting for an invisible leap second.
1251
1252             if Leap_Sec
1253               or else Res_M >= Next_Leap_M
1254             then
1255                Res_M := Res_M + OS_Time (1) * Mili;
1256             end if;
1257
1258             --  Leap second validity check
1259
1260             Rounded_Res_M := Res_M - (Res_M mod Mili);
1261
1262             if Is_Ada_05
1263               and then Leap_Sec
1264               and then Rounded_Res_M /= Next_Leap_M
1265             then
1266                raise Time_Error;
1267             end if;
1268          end if;
1269
1270          return Time (Res_M);
1271       end Time_Of;
1272    end Formatting_Operations;
1273
1274    ---------------------------
1275    -- Time_Zones_Operations --
1276    ---------------------------
1277
1278    package body Time_Zones_Operations is
1279
1280       ---------------------
1281       -- UTC_Time_Offset --
1282       ---------------------
1283
1284       function UTC_Time_Offset (Date : Time) return Long_Integer is
1285          --  Formal parameter Date is here for interfacing, but is never
1286          --  actually used.
1287
1288          pragma Unreferenced (Date);
1289
1290          function get_gmtoff return Long_Integer;
1291          pragma Import (C, get_gmtoff, "get_gmtoff");
1292
1293       begin
1294          --  VMS is not capable of determining the time zone in some past or
1295          --  future point in time denoted by Date, thus the current time zone
1296          --  is retrieved.
1297
1298          return get_gmtoff;
1299       end UTC_Time_Offset;
1300    end Time_Zones_Operations;
1301 end Ada.Calendar;