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