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 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 Use_TZ is
 521       --  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          Use_TZ      => False,
 535          Is_Historic => True,
 536          Time_Zone   => 0);
 537
 538       --  Validity checks
 539
 540       if not Year'Valid
 541         or else not Month'Valid
 542         or else not Day'Valid
 543         or else not Seconds'Valid
 544       then
 545          raise Time_Error;
 546       end if;
 547    end Split;
 548
 549    -------------
 550    -- Time_Of --
 551    -------------
 552
 553    function Time_Of
 554      (Year    : Year_Number;
 555       Month   : Month_Number;
 556       Day     : Day_Number;
 557       Seconds : Day_Duration := 0.0) return Time
 558    is
 559       --  The values in the following constants are irrelevant, they are just
 560       --  placeholders; the choice of constructing a Day_Duration value is
 561       --  controlled by the Use_Day_Secs flag.
 562
 563       H  : constant Integer := 1;
 564       M  : constant Integer := 1;
 565       Se : constant Integer := 1;
 566       Ss : constant Duration := 0.1;
 567
 568    begin
 569       if not Year'Valid
 570         or else not Month'Valid
 571         or else not Day'Valid
 572         or else not Seconds'Valid
 573       then
 574          raise Time_Error;
 575       end if;
 576
 577       --  Use UTC as the local time zone on VMS, the status of flag Use_TZ is
 578       --  irrelevant in this case.
 579
 580       return
 581         Formatting_Operations.Time_Of
 582           (Year         => Year,
 583            Month        => Month,
 584            Day          => Day,
 585            Day_Secs     => Seconds,
 586            Hour         => H,
 587            Minute       => M,
 588            Second       => Se,
 589            Sub_Sec      => Ss,
 590            Leap_Sec     => False,
 591            Use_Day_Secs => True,
 592            Use_TZ       => False,
 593            Is_Historic  => True,
 594            Time_Zone    => 0);
 595    end Time_Of;
 596
 597    -----------------
 598    -- To_Duration --
 599    -----------------
 600
 601    function To_Duration (T : Time) return Duration is
 602       function Time_To_Duration is
 603         new Ada.Unchecked_Conversion (Time, Duration);
 604    begin
 605       return Time_To_Duration (T * 100);
 606    end To_Duration;
 607
 608    ----------------------
 609    -- To_Relative_Time --
 610    ----------------------
 611
 612    function To_Relative_Time (D : Duration) return Time is
 613       function Duration_To_Time is
 614         new Ada.Unchecked_Conversion (Duration, Time);
 615    begin
 616       return Duration_To_Time (D / 100.0);
 617    end To_Relative_Time;
 618
 619    ----------
 620    -- Year --
 621    ----------
 622
 623    function Year (Date : Time) return Year_Number is
 624       Y : Year_Number;
 625       M : Month_Number;
 626       D : Day_Number;
 627       S : Day_Duration;
 628       pragma Unreferenced (M, D, S);
 629    begin
 630       Split (Date, Y, M, D, S);
 631       return Y;
 632    end Year;
 633
 634    --  The following packages assume that Time is a Long_Integer, the units
 635    --  are 100 nanoseconds and the starting point in the VMS Epoch.
 636
 637    ---------------------------
 638    -- Arithmetic_Operations --
 639    ---------------------------
 640
 641    package body Arithmetic_Operations is
 642
 643       ---------
 644       -- Add --
 645       ---------
 646
 647       function Add (Date : Time; Days : Long_Integer) return Time is
 648          pragma Unsuppress (Overflow_Check);
 649          Date_M : constant OS_Time := OS_Time (Date);
 650       begin
 651          return Time (Date_M + OS_Time (Days) * Milis_In_Day);
 652       exception
 653          when Constraint_Error =>
 654             raise Time_Error;
 655       end Add;
 656
 657       ----------------
 658       -- Difference --
 659       ----------------
 660
 661       procedure Difference
 662         (Left         : Time;
 663          Right        : Time;
 664          Days         : out Long_Integer;
 665          Seconds      : out Duration;
 666          Leap_Seconds : out Integer)
 667       is
 668          Diff_M        : OS_Time;
 669          Diff_S        : OS_Time;
 670          Earlier       : OS_Time;
 671          Elapsed_Leaps : Natural;
 672          Later         : OS_Time;
 673          Negate        : Boolean := False;
 674          Next_Leap     : OS_Time;
 675          Sub_Seconds   : Duration;
 676
 677       begin
 678          --  This classification is necessary in order to avoid a Time_Error
 679          --  being raised by the arithmetic operators in Ada.Calendar.
 680
 681          if Left >= Right then
 682             Later   := OS_Time (Left);
 683             Earlier := OS_Time (Right);
 684          else
 685             Later   := OS_Time (Right);
 686             Earlier := OS_Time (Left);
 687             Negate  := True;
 688          end if;
 689
 690          --  If the target supports leap seconds, process them
 691
 692          if Leap_Support then
 693             Cumulative_Leap_Seconds
 694               (Earlier, Later, Elapsed_Leaps, Next_Leap);
 695
 696             if Later >= Next_Leap then
 697                Elapsed_Leaps := Elapsed_Leaps + 1;
 698             end if;
 699
 700          --  The target does not support leap seconds
 701
 702          else
 703             Elapsed_Leaps := 0;
 704          end if;
 705
 706          Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili;
 707
 708          --  Sub second processing
 709
 710          Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F;
 711
 712          --  Convert to seconds. Note that his action eliminates the sub
 713          --  seconds automatically.
 714
 715          Diff_S := Diff_M / Mili;
 716
 717          Days := Long_Integer (Diff_S / Secs_In_Day);
 718          Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds;
 719          Leap_Seconds := Integer (Elapsed_Leaps);
 720
 721          if Negate then
 722             Days    := -Days;
 723             Seconds := -Seconds;
 724
 725             if Leap_Seconds /= 0 then
 726                Leap_Seconds := -Leap_Seconds;
 727             end if;
 728          end if;
 729       end Difference;
 730
 731       --------------
 732       -- Subtract --
 733       --------------
 734
 735       function Subtract (Date : Time; Days : Long_Integer) return Time is
 736          pragma Unsuppress (Overflow_Check);
 737          Date_M : constant OS_Time := OS_Time (Date);
 738       begin
 739          return Time (Date_M - OS_Time (Days) * Milis_In_Day);
 740       exception
 741          when Constraint_Error =>
 742             raise Time_Error;
 743       end Subtract;
 744    end Arithmetic_Operations;
 745
 746    ---------------------------
 747    -- Conversion_Operations --
 748    ---------------------------
 749
 750    package body Conversion_Operations is
 751
 752       Epoch_Offset : constant OS_Time := 35067168000000000;
 753       --  The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in
 754       --  100 nanoseconds.
 755
 756       -----------------
 757       -- To_Ada_Time --
 758       -----------------
 759
 760       function To_Ada_Time (Unix_Time : Long_Integer) return Time is
 761          pragma Unsuppress (Overflow_Check);
 762          Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili;
 763       begin
 764          return Time (Unix_Rep + Epoch_Offset);
 765       exception
 766          when Constraint_Error =>
 767             raise Time_Error;
 768       end To_Ada_Time;
 769
 770       -----------------
 771       -- To_Ada_Time --
 772       -----------------
 773
 774       function To_Ada_Time
 775         (tm_year  : Integer;
 776          tm_mon   : Integer;
 777          tm_day   : Integer;
 778          tm_hour  : Integer;
 779          tm_min   : Integer;
 780          tm_sec   : Integer;
 781          tm_isdst : Integer) return Time
 782       is
 783          pragma Unsuppress (Overflow_Check);
 784
 785          Year_Shift  : constant Integer := 1900;
 786          Month_Shift : constant Integer := 1;
 787
 788          Year   : Year_Number;
 789          Month  : Month_Number;
 790          Day    : Day_Number;
 791          Second : Integer;
 792          Leap   : Boolean;
 793          Result : OS_Time;
 794
 795       begin
 796          --  Input processing
 797
 798          Year  := Year_Number (Year_Shift + tm_year);
 799          Month := Month_Number (Month_Shift + tm_mon);
 800          Day   := Day_Number (tm_day);
 801
 802          --  Step 1: Validity checks of input values
 803
 804          if not Year'Valid
 805            or else not Month'Valid
 806            or else not Day'Valid
 807            or else tm_hour not in 0 .. 24
 808            or else tm_min not in 0 .. 59
 809            or else tm_sec not in 0 .. 60
 810            or else tm_isdst not in -1 .. 1
 811          then
 812             raise Time_Error;
 813          end if;
 814
 815          --  Step 2: Potential leap second
 816
 817          if tm_sec = 60 then
 818             Leap   := True;
 819             Second := 59;
 820          else
 821             Leap   := False;
 822             Second := tm_sec;
 823          end if;
 824
 825          --  Step 3: Calculate the time value
 826
 827          Result :=
 828            OS_Time
 829              (Formatting_Operations.Time_Of
 830                (Year         => Year,
 831                 Month        => Month,
 832                 Day          => Day,
 833                 Day_Secs     => 0.0,      --  Time is given in h:m:s
 834                 Hour         => tm_hour,
 835                 Minute       => tm_min,
 836                 Second       => Second,
 837                 Sub_Sec      => 0.0,      --  No precise sub second given
 838                 Leap_Sec     => Leap,
 839                 Use_Day_Secs => False,    --  Time is given in h:m:s
 840                 Use_TZ       => True,     --  Force usage of explicit time zone
 841                 Is_Historic  => True,
 842                 Time_Zone    => 0));      --  Place the value in UTC
 843          --  Step 4: Daylight Savings Time
 844
 845          if tm_isdst = 1 then
 846             Result := Result + OS_Time (3_600) * Mili;
 847          end if;
 848
 849          return Time (Result);
 850       exception
 851          when Constraint_Error =>
 852             raise Time_Error;
 853       end To_Ada_Time;
 854
 855       -----------------
 856       -- To_Duration --
 857       -----------------
 858
 859       function To_Duration
 860         (tv_sec  : Long_Integer;
 861          tv_nsec : Long_Integer) return Duration
 862       is
 863          pragma Unsuppress (Overflow_Check);
 864       begin
 865          return Duration (tv_sec) + Duration (tv_nsec) / Mili_F;
 866       end To_Duration;
 867
 868       ------------------------
 869       -- To_Struct_Timespec --
 870       ------------------------
 871
 872       procedure To_Struct_Timespec
 873         (D       : Duration;
 874          tv_sec  : out Long_Integer;
 875          tv_nsec : out Long_Integer)
 876       is
 877          pragma Unsuppress (Overflow_Check);
 878          Secs      : Duration;
 879          Nano_Secs : Duration;
 880
 881       begin
 882          --  Seconds extraction, avoid potential rounding errors
 883
 884          Secs   := D - 0.5;
 885          tv_sec := Long_Integer (Secs);
 886
 887          --  100 Nanoseconds extraction
 888
 889          Nano_Secs := D - Duration (tv_sec);
 890          tv_nsec := Long_Integer (Nano_Secs * Mili);
 891       end To_Struct_Timespec;
 892
 893       ------------------
 894       -- To_Struct_Tm --
 895       ------------------
 896
 897       procedure To_Struct_Tm
 898         (T       : Time;
 899          tm_year : out Integer;
 900          tm_mon  : out Integer;
 901          tm_day  : out Integer;
 902          tm_hour : out Integer;
 903          tm_min  : out Integer;
 904          tm_sec  : out Integer)
 905       is
 906          pragma Unsuppress (Overflow_Check);
 907          Year      : Year_Number;
 908          Month     : Month_Number;
 909          Second    : Integer;
 910          Day_Secs  : Day_Duration;
 911          Sub_Sec   : Duration;
 912          Leap_Sec  : Boolean;
 913
 914       begin
 915          --  Step 1: Split the input time
 916
 917          Formatting_Operations.Split
 918            (Date        => T,
 919             Year        => Year,
 920             Month       => Month,
 921             Day         => tm_day,
 922             Day_Secs    => Day_Secs,
 923             Hour        => tm_hour,
 924             Minute      => tm_min,
 925             Second      => Second,
 926             Sub_Sec     => Sub_Sec,
 927             Leap_Sec    => Leap_Sec,
 928             Use_TZ      => True,
 929             Is_Historic => False,
 930             Time_Zone   => 0);
 931
 932          --  Step 2: Correct the year and month
 933
 934          tm_year := Year - 1900;
 935          tm_mon  := Month - 1;
 936
 937          --  Step 3: Handle leap second occurrences
 938
 939          tm_sec := (if Leap_Sec then 60 else Second);
 940       end To_Struct_Tm;
 941
 942       ------------------
 943       -- To_Unix_Time --
 944       ------------------
 945
 946       function To_Unix_Time (Ada_Time : Time) return Long_Integer is
 947          pragma Unsuppress (Overflow_Check);
 948          Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time);
 949       begin
 950          return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili);
 951       exception
 952          when Constraint_Error =>
 953             raise Time_Error;
 954       end To_Unix_Time;
 955    end Conversion_Operations;
 956
 957    ---------------------------
 958    -- Formatting_Operations --
 959    ---------------------------
 960
 961    package body Formatting_Operations is
 962
 963       -----------------
 964       -- Day_Of_Week --
 965       -----------------
 966
 967       function Day_Of_Week (Date : Time) return Integer is
 968          Y : Year_Number;
 969          M : Month_Number;
 970          D : Day_Number;
 971          S : Day_Duration;
 972
 973          Day_Count     : Long_Integer;
 974          Midday_Date_S : Time;
 975
 976       begin
 977          Split (Date, Y, M, D, S);
 978
 979          --  Build a time value in the middle of the same day and convert the
 980          --  time value to seconds.
 981
 982          Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili;
 983
 984          --  Count the number of days since the start of VMS time. 1858-11-17
 985          --  was a Wednesday.
 986
 987          Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2;
 988
 989          return Integer (Day_Count mod 7);
 990       end Day_Of_Week;
 991
 992       -----------
 993       -- Split --
 994       -----------
 995
 996       procedure Split
 997         (Date        : Time;
 998          Year        : out Year_Number;
 999          Month       : out Month_Number;
1000          Day         : out Day_Number;
1001          Day_Secs    : out Day_Duration;
1002          Hour        : out Integer;
1003          Minute      : out Integer;
1004          Second      : out Integer;
1005          Sub_Sec     : out Duration;
1006          Leap_Sec    : out Boolean;
1007          Use_TZ      : Boolean;
1008          Is_Historic : Boolean;
1009          Time_Zone   : Long_Integer)
1010       is
1011          --  Flags Use_TZ and Is_Historic are present for interfacing purposes
1012
1013          pragma Unreferenced (Use_TZ, Is_Historic);
1014
1015          procedure Numtim
1016            (Status : out Unsigned_Longword;
1017             Timbuf : out Unsigned_Word_Array;
1018             Timadr : Time);
1019
1020          pragma Import (External, Numtim);
1021
1022          pragma Import_Valued_Procedure
1023            (Numtim, "SYS$NUMTIM",
1024            (Unsigned_Longword, Unsigned_Word_Array, Time),
1025            (Value, Reference, Reference));
1026
1027          Status : Unsigned_Longword;
1028          Timbuf : Unsigned_Word_Array (1 .. 7);
1029
1030          Ada_Min_Year : constant := 1901;
1031          Ada_Max_Year : constant := 2399;
1032
1033          Date_M        : OS_Time;
1034          Elapsed_Leaps : Natural;
1035          Next_Leap_M   : OS_Time;
1036
1037       begin
1038          Date_M := OS_Time (Date);
1039
1040          --  Step 1: Leap seconds processing
1041
1042          if Leap_Support then
1043             Cumulative_Leap_Seconds
1044               (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M);
1045
1046             Leap_Sec := Date_M >= Next_Leap_M;
1047
1048             if Leap_Sec then
1049                Elapsed_Leaps := Elapsed_Leaps + 1;
1050             end if;
1051
1052          --  The target does not support leap seconds
1053
1054          else
1055             Elapsed_Leaps := 0;
1056             Leap_Sec      := False;
1057          end if;
1058
1059          Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili;
1060
1061          --  Step 2: Time zone processing
1062
1063          if Time_Zone /= 0 then
1064             Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili;
1065          end if;
1066
1067          --  After the leap seconds and time zone have been accounted for,
1068          --  the date should be within the bounds of Ada time.
1069
1070          if Date_M < Ada_Low
1071            or else Date_M > Ada_High
1072          then
1073             raise Time_Error;
1074          end if;
1075
1076          --  Step 3: Sub second processing
1077
1078          Sub_Sec := Duration (Date_M mod Mili) / Mili_F;
1079
1080          --  Drop the sub seconds
1081
1082          Date_M := Date_M - (Date_M mod Mili);
1083
1084          --  Step 4: VMS system call
1085
1086          Numtim (Status, Timbuf, Time (Date_M));
1087
1088          if Status mod 2 /= 1
1089            or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year
1090          then
1091             raise Time_Error;
1092          end if;
1093
1094          --  Step 5: Time components processing
1095
1096          Year   := Year_Number (Timbuf (1));
1097          Month  := Month_Number (Timbuf (2));
1098          Day    := Day_Number (Timbuf (3));
1099          Hour   := Integer (Timbuf (4));
1100          Minute := Integer (Timbuf (5));
1101          Second := Integer (Timbuf (6));
1102
1103          Day_Secs := Day_Duration (Hour   * 3_600) +
1104                      Day_Duration (Minute *    60) +
1105                      Day_Duration (Second)         +
1106                                    Sub_Sec;
1107       end Split;
1108
1109       -------------
1110       -- Time_Of --
1111       -------------
1112
1113       function Time_Of
1114         (Year         : Year_Number;
1115          Month        : Month_Number;
1116          Day          : Day_Number;
1117          Day_Secs     : Day_Duration;
1118          Hour         : Integer;
1119          Minute       : Integer;
1120          Second       : Integer;
1121          Sub_Sec      : Duration;
1122          Leap_Sec     : Boolean;
1123          Use_Day_Secs : Boolean;
1124          Use_TZ       : Boolean;
1125          Is_Historic  : Boolean;
1126          Time_Zone    : Long_Integer) return Time
1127       is
1128          --  Flag Is_Historic is present for interfacing purposes
1129
1130          pragma Unreferenced (Is_Historic);
1131
1132          procedure Cvt_Vectim
1133            (Status         : out Unsigned_Longword;
1134             Input_Time     : Unsigned_Word_Array;
1135             Resultant_Time : out Time);
1136
1137          pragma Import (External, Cvt_Vectim);
1138
1139          pragma Import_Valued_Procedure
1140            (Cvt_Vectim, "LIB$CVT_VECTIM",
1141            (Unsigned_Longword, Unsigned_Word_Array, Time),
1142            (Value, Reference, Reference));
1143
1144          Status : Unsigned_Longword;
1145          Timbuf : Unsigned_Word_Array (1 .. 7);
1146
1147          Y  : Year_Number  := Year;
1148          Mo : Month_Number := Month;
1149          D  : Day_Number   := Day;
1150          H  : Integer      := Hour;
1151          Mi : Integer      := Minute;
1152          Se : Integer      := Second;
1153          Su : Duration     := Sub_Sec;
1154
1155          Elapsed_Leaps : Natural;
1156          Int_Day_Secs  : Integer;
1157          Next_Leap_M   : OS_Time;
1158          Res           : Time;
1159          Res_M         : OS_Time;
1160          Rounded_Res_M : OS_Time;
1161
1162       begin
1163          --  No validity checks are performed on the input values since it is
1164          --  assumed that the called has already performed them.
1165
1166          --  Step 1: Hour, minute, second and sub second processing
1167
1168          if Use_Day_Secs then
1169
1170             --  A day seconds value of 86_400 designates a new day
1171
1172             if Day_Secs = 86_400.0 then
1173                declare
1174                   Adj_Year  : Year_Number := Year;
1175                   Adj_Month : Month_Number := Month;
1176                   Adj_Day   : Day_Number   := Day;
1177
1178                begin
1179                   if Day < Days_In_Month (Month)
1180                     or else (Month = 2
1181                                and then Is_Leap (Year))
1182                   then
1183                      Adj_Day := Day + 1;
1184
1185                   --  The day adjustment moves the date to a new month
1186
1187                   else
1188                      Adj_Day := 1;
1189
1190                      if Month < 12 then
1191                         Adj_Month := Month + 1;
1192
1193                      --  The month adjustment moves the date to a new year
1194
1195                      else
1196                         Adj_Month := 1;
1197                         Adj_Year  := Year + 1;
1198                      end if;
1199                   end if;
1200
1201                   Y  := Adj_Year;
1202                   Mo := Adj_Month;
1203                   D  := Adj_Day;
1204                   H  := 0;
1205                   Mi := 0;
1206                   Se := 0;
1207                   Su := 0.0;
1208                end;
1209
1210             --  Normal case (not exactly one day)
1211
1212             else
1213                --  Sub second extraction
1214
1215                Int_Day_Secs :=
1216                  (if Day_Secs > 0.0
1217                   then Integer (Day_Secs - 0.5)
1218                   else Integer (Day_Secs));
1219
1220                H  := Int_Day_Secs / 3_600;
1221                Mi := (Int_Day_Secs / 60) mod 60;
1222                Se := Int_Day_Secs mod 60;
1223                Su := Day_Secs - Duration (Int_Day_Secs);
1224             end if;
1225          end if;
1226
1227          --  Step 2: System call to VMS
1228
1229          Timbuf (1) := Unsigned_Word (Y);
1230          Timbuf (2) := Unsigned_Word (Mo);
1231          Timbuf (3) := Unsigned_Word (D);
1232          Timbuf (4) := Unsigned_Word (H);
1233          Timbuf (5) := Unsigned_Word (Mi);
1234          Timbuf (6) := Unsigned_Word (Se);
1235          Timbuf (7) := 0;
1236
1237          Cvt_Vectim (Status, Timbuf, Res);
1238
1239          if Status mod 2 /= 1 then
1240             raise Time_Error;
1241          end if;
1242
1243          --  Step 3: Sub second adjustment
1244
1245          Res_M := OS_Time (Res) + OS_Time (Su * Mili_F);
1246
1247          --  Step 4: Bounds check
1248
1249          Check_Within_Time_Bounds (Res_M);
1250
1251          --  Step 5: Time zone processing
1252
1253          if Time_Zone /= 0 then
1254             Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili;
1255          end if;
1256
1257          --  Step 6: Leap seconds processing
1258
1259          if Leap_Support then
1260             Cumulative_Leap_Seconds
1261               (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M);
1262
1263             Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili;
1264
1265             --  An Ada 2005 caller requesting an explicit leap second or an
1266             --  Ada 95 caller accounting for an invisible leap second.
1267
1268             if Leap_Sec
1269               or else Res_M >= Next_Leap_M
1270             then
1271                Res_M := Res_M + OS_Time (1) * Mili;
1272             end if;
1273
1274             --  Leap second validity check
1275
1276             Rounded_Res_M := Res_M - (Res_M mod Mili);
1277
1278             if Use_TZ
1279               and then Leap_Sec
1280               and then Rounded_Res_M /= Next_Leap_M
1281             then
1282                raise Time_Error;
1283             end if;
1284          end if;
1285
1286          return Time (Res_M);
1287       end Time_Of;
1288    end Formatting_Operations;
1289
1290    ---------------------------
1291    -- Time_Zones_Operations --
1292    ---------------------------
1293
1294    package body Time_Zones_Operations is
1295
1296       ---------------------
1297       -- UTC_Time_Offset --
1298       ---------------------
1299
1300       function UTC_Time_Offset (Date : Time) return Long_Integer is
1301          --  Formal parameter Date is here for interfacing, but is never
1302          --  actually used.
1303
1304          pragma Unreferenced (Date);
1305
1306          function get_gmtoff return Long_Integer;
1307          pragma Import (C, get_gmtoff, "get_gmtoff");
1308
1309       begin
1310          --  VMS is not capable of determining the time zone in some past or
1311          --  future point in time denoted by Date, thus the current time zone
1312          --  is retrieved.
1313
1314          return get_gmtoff;
1315       end UTC_Time_Offset;
1316    end Time_Zones_Operations;
1317 end Ada.Calendar;