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