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