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