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