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