a-calend-vms.adb 32.3 KB
Newer Older
kenner's avatar
kenner committed
1 2 3 4 5 6 7 8
------------------------------------------------------------------------------
--                                                                          --
--                        GNAT RUN-TIME COMPONENTS                          --
--                                                                          --
--                         A D A . C A L E N D A R                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
9
--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
kenner's avatar
kenner committed
10 11 12 13 14 15 16 17 18
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
kcook's avatar
kcook committed
19 20
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
kenner's avatar
kenner committed
21 22 23 24 25 26 27 28 29
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
30
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
kenner's avatar
kenner committed
31 32 33
--                                                                          --
------------------------------------------------------------------------------

34
--  This is the Alpha/VMS version
kenner's avatar
kenner committed
35 36 37

with System.Aux_DEC; use System.Aux_DEC;

38 39
with Ada.Unchecked_Conversion;

kenner's avatar
kenner committed
40 41
package body Ada.Calendar is

42 43 44
   --------------------------
   -- Implementation Notes --
   --------------------------
kenner's avatar
kenner committed
45

46 47
   --  Variables of type Ada.Calendar.Time have suffix _S or _M to denote
   --  units of seconds or milis.
kenner's avatar
kenner committed
48

49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
   --  Because time is measured in different units and from different origins
   --  on various targets, a system independent model is incorporated into
   --  Ada.Calendar. The idea behing the design is to encapsulate all target
   --  dependent machinery in a single package, thus providing a uniform
   --  interface to all existing and any potential children.

   --     package Ada.Calendar
   --        procedure Split (5 parameters) -------+
   --                                              | Call from local routine
   --     private                                  |
   --        package Formatting_Operations         |
   --           procedure Split (11 parameters) <--+
   --        end Formatting_Operations             |
   --     end Ada.Calendar                         |
   --                                              |
   --     package Ada.Calendar.Formatting          | Call from child routine
   --        procedure Split (9 or 10 parameters) -+
   --     end Ada.Calendar.Formatting

   --  The behaviour of the interfacing routines is controlled via various
   --  flags. All new Ada 2005 types from children of Ada.Calendar are
   --  emulated by a similar type. For instance, type Day_Number is replaced
   --  by Integer in various routines. One ramification of this model is that
   --  the caller site must perform validity checks on returned results.
   --  The end result of this model is the lack of target specific files per
   --  child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc).

76 77 78
   -----------------------
   -- Local Subprograms --
   -----------------------
kenner's avatar
kenner committed
79

80 81 82
   procedure Check_Within_Time_Bounds (T : Time);
   --  Ensure that a time representation value falls withing the bounds of Ada
   --  time. Leap seconds support is taken into account.
83 84 85 86 87 88 89 90

   procedure Cumulative_Leap_Seconds
     (Start_Date    : Time;
      End_Date      : Time;
      Elapsed_Leaps : out Natural;
      Next_Leap_Sec : out Time);
   --  Elapsed_Leaps is the sum of the leap seconds that have occured on or
   --  after Start_Date and before (strictly before) End_Date. Next_Leap_Sec
91 92 93 94
   --  represents the next leap second occurence on or after End_Date. If
   --  there are no leaps seconds after End_Date, End_Of_Time is returned.
   --  End_Of_Time can be used as End_Date to count all the leap seconds that
   --  have occured on or after Start_Date.
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
   --
   --  Note: Any sub seconds of Start_Date and End_Date are discarded before
   --  the calculations are done. For instance: if 113 seconds is a leap
   --  second (it isn't) and 113.5 is input as an End_Date, the leap second
   --  at 113 will not be counted in Leaps_Between, but it will be returned
   --  as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is
   --  a leap second, the comparison should be:
   --
   --     End_Date >= Next_Leap_Sec;
   --
   --  After_Last_Leap is designed so that this comparison works without
   --  having to first check if Next_Leap_Sec is a valid leap second.

   function To_Duration (T : Time) return Duration;
   function To_Relative_Time (D : Duration) return Time;
   --  It is important to note that duration's fractional part denotes nano
   --  seconds while the units of Time are 100 nanoseconds. If a regular
   --  Unchecked_Conversion was employed, the resulting values would be off
   --  by 100.
kenner's avatar
kenner committed
114

115 116 117
   --------------------------
   -- Leap seconds control --
   --------------------------
kenner's avatar
kenner committed
118

119 120 121 122 123 124 125 126 127 128
   Flag : Integer;
   pragma Import (C, Flag, "__gl_leap_seconds_support");
   --  This imported value is used to determine whether the compilation had
   --  binder flag "-y" present which enables leap seconds. A value of zero
   --  signifies no leap seconds support while a value of one enables the
   --  support.

   Leap_Support : constant Boolean := Flag = 1;
   --  The above flag controls the usage of leap seconds in all Ada.Calendar
   --  routines.
129 130 131

   Leap_Seconds_Count : constant Natural := 23;

132 133 134 135
   ---------------------
   -- Local Constants --
   ---------------------

136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
   --  The range of Ada time expressed as milis since the VMS Epoch

   Ada_Low  : constant Time :=  (10 * 366 +  32 * 365 + 45) * Milis_In_Day;
   Ada_High : constant Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day;

   --  Even though the upper bound of time is 2399-12-31 23:59:59.9999999
   --  UTC, it must be increased to include all leap seconds.

   Ada_High_And_Leaps : constant Time :=
                          Ada_High + Time (Leap_Seconds_Count) * Mili;

   --  Two constants used in the calculations of elapsed leap seconds.
   --  End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time
   --  is earlier than Ada_Low in time zone +28.

   End_Of_Time   : constant Time := Ada_High + Time (3) * Milis_In_Day;
   Start_Of_Time : constant Time := Ada_Low  - Time (3) * Milis_In_Day;
kenner's avatar
kenner committed
153

154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
   --  The following table contains the hard time values of all existing leap
   --  seconds. The values are produced by the utility program xleaps.adb.

   Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of Time :=
     (35855136000000000,
      36014112010000000,
      36329472020000000,
      36644832030000000,
      36960192040000000,
      37276416050000000,
      37591776060000000,
      37907136070000000,
      38222496080000000,
      38695104090000000,
      39010464100000000,
      39325824110000000,
      39957408120000000,
      40747104130000000,
      41378688140000000,
      41694048150000000,
      42166656160000000,
      42482016170000000,
      42797376180000000,
      43271712190000000,
      43744320200000000,
      44218656210000000,
      46427904220000000);
kenner's avatar
kenner committed
181 182 183 184 185 186 187 188

   ---------
   -- "+" --
   ---------

   function "+" (Left : Time; Right : Duration) return Time is
      pragma Unsuppress (Overflow_Check);
   begin
189
      return Left + To_Relative_Time (Right);
kenner's avatar
kenner committed
190 191 192 193 194 195 196 197
   exception
      when Constraint_Error =>
         raise Time_Error;
   end "+";

   function "+" (Left : Duration; Right : Time) return Time is
      pragma Unsuppress (Overflow_Check);
   begin
198
      return Right + Left;
kenner's avatar
kenner committed
199 200 201 202 203 204 205 206 207
   exception
      when Constraint_Error =>
         raise Time_Error;
   end "+";

   ---------
   -- "-" --
   ---------

208
   function "-" (Left : Time; Right : Duration) return Time is
kenner's avatar
kenner committed
209 210
      pragma Unsuppress (Overflow_Check);
   begin
211
      return Left - To_Relative_Time (Right);
kenner's avatar
kenner committed
212 213 214 215 216 217 218
   exception
      when Constraint_Error =>
         raise Time_Error;
   end "-";

   function "-" (Left : Time; Right : Time) return Duration is
      pragma Unsuppress (Overflow_Check);
219

220 221 222 223 224 225
      --  The bound of type Duration expressed as time

      Dur_High : constant Time := To_Relative_Time (Duration'Last);
      Dur_Low  : constant Time := To_Relative_Time (Duration'First);

      Res_M : Time;
226

kenner's avatar
kenner committed
227
   begin
228 229
      Res_M := Left - Right;

230 231 232 233
      --  Due to the extended range of Ada time, "-" is capable of producing
      --  results which may exceed the range of Duration. In order to prevent
      --  the generation of bogus values by the Unchecked_Conversion, we apply
      --  the following check.
234 235 236

      if Res_M < Dur_Low
        or else Res_M >= Dur_High
237 238
      then
         raise Time_Error;
239 240 241 242 243

      --  Normal case, result fits

      else
         return To_Duration (Res_M);
244 245
      end if;

kenner's avatar
kenner committed
246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
   exception
      when Constraint_Error =>
         raise Time_Error;
   end "-";

   ---------
   -- "<" --
   ---------

   function "<" (Left, Right : Time) return Boolean is
   begin
      return Long_Integer (Left) < Long_Integer (Right);
   end "<";

   ----------
   -- "<=" --
   ----------

   function "<=" (Left, Right : Time) return Boolean is
   begin
      return Long_Integer (Left) <= Long_Integer (Right);
   end "<=";

   ---------
   -- ">" --
   ---------

   function ">" (Left, Right : Time) return Boolean is
   begin
      return Long_Integer (Left) > Long_Integer (Right);
   end ">";

   ----------
   -- ">=" --
   ----------

   function ">=" (Left, Right : Time) return Boolean is
   begin
      return Long_Integer (Left) >= Long_Integer (Right);
   end ">=";

287 288 289
   ------------------------------
   -- Check_Within_Time_Bounds --
   ------------------------------
290

291
   procedure Check_Within_Time_Bounds (T : Time) is
292
   begin
293 294 295 296 297 298 299 300 301 302
      if Leap_Support then
         if T < Ada_Low or else T > Ada_High_And_Leaps then
            raise Time_Error;
         end if;
      else
         if T < Ada_Low or else T > Ada_High then
            raise Time_Error;
         end if;
      end if;
   end Check_Within_Time_Bounds;
303

kenner's avatar
kenner committed
304 305 306 307 308
   -----------
   -- Clock --
   -----------

   function Clock return Time is
309
      Elapsed_Leaps : Natural;
310 311
      Next_Leap_M   : Time;
      Res_M         : constant Time := Time (OSP.OS_Clock);
312

kenner's avatar
kenner committed
313
   begin
314 315 316 317 318
      --  Note that on other targets a soft-link is used to get a different
      --  clock depending whether tasking is used or not. On VMS this isn't
      --  needed since all clock calls end up using SYS$GETTIM, so call the
      --  OS_Primitives version for efficiency.

319 320 321 322 323 324 325 326
      --  If the target supports leap seconds, determine the number of leap
      --  seconds elapsed until this moment.

      if Leap_Support then
         Cumulative_Leap_Seconds
           (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M);

         --  The system clock may fall exactly on a leap second
327

328 329 330
         if Res_M >= Next_Leap_M then
            Elapsed_Leaps := Elapsed_Leaps + 1;
         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;
kenner's avatar
kenner committed
339 340
   end Clock;

341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
   -----------------------------
   -- Cumulative_Leap_Seconds --
   -----------------------------

   procedure Cumulative_Leap_Seconds
     (Start_Date    : Time;
      End_Date      : Time;
      Elapsed_Leaps : out Natural;
      Next_Leap_Sec : out Time)
   is
      End_Index   : Positive;
      End_T       : Time := End_Date;
      Start_Index : Positive;
      Start_T     : Time := Start_Date;

   begin
357
      pragma Assert (Leap_Support and then End_Date >= Start_Date);
358

359
      Next_Leap_Sec := End_Of_Time;
360 361 362 363 364 365 366 367 368 369 370 371 372

      --  Make sure that the end date does not excede the upper bound
      --  of Ada time.

      if End_Date > Ada_High then
         End_T := Ada_High;
      end if;

      --  Remove the sub seconds from both dates

      Start_T := Start_T - (Start_T mod Mili);
      End_T   := End_T   - (End_T   mod Mili);

373 374 375 376
      --  Some trivial cases:
      --                     Leap 1 . . . Leap N
      --  ---+========+------+############+-------+========+-----
      --     Start_T  End_T                       Start_T  End_T
377 378 379 380 381 382

      if End_T < Leap_Second_Times (1) then
         Elapsed_Leaps := 0;
         Next_Leap_Sec := Leap_Second_Times (1);
         return;

383
      elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then
384
         Elapsed_Leaps := 0;
385
         Next_Leap_Sec := End_Of_Time;
386 387 388 389 390 391
         return;
      end if;

      --  Perform the calculations only if the start date is within the leap
      --  second occurences table.

392
      if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then
393 394 395 396 397 398 399 400 401 402 403

         --    1    2                  N - 1   N
         --  +----+----+--  . . .  --+-------+---+
         --  | T1 | T2 |             | N - 1 | N |
         --  +----+----+--  . . .  --+-------+---+
         --         ^                   ^
         --         | Start_Index       | End_Index
         --         +-------------------+
         --             Leaps_Between

         --  The idea behind the algorithm is to iterate and find two closest
404 405
         --  dates which are after Start_T and End_T. Their corresponding
         --  index difference denotes the number of leap seconds elapsed.
406 407 408 409 410 411 412 413 414

         Start_Index := 1;
         loop
            exit when Leap_Second_Times (Start_Index) >= Start_T;
            Start_Index := Start_Index + 1;
         end loop;

         End_Index := Start_Index;
         loop
415
            exit when End_Index > Leap_Seconds_Count
416 417 418 419
              or else Leap_Second_Times (End_Index) >= End_T;
            End_Index := End_Index + 1;
         end loop;

420
         if End_Index <= Leap_Seconds_Count then
421 422 423 424 425 426 427 428 429 430
            Next_Leap_Sec := Leap_Second_Times (End_Index);
         end if;

         Elapsed_Leaps := End_Index - Start_Index;

      else
         Elapsed_Leaps := 0;
      end if;
   end Cumulative_Leap_Seconds;

kenner's avatar
kenner committed
431 432 433 434 435
   ---------
   -- Day --
   ---------

   function Day (Date : Time) return Day_Number is
436 437 438 439
      Y : Year_Number;
      M : Month_Number;
      D : Day_Number;
      S : Day_Duration;
440
      pragma Unreferenced (Y, M, S);
kenner's avatar
kenner committed
441
   begin
442 443
      Split (Date, Y, M, D, S);
      return D;
kenner's avatar
kenner committed
444 445
   end Day;

446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468
   -------------
   -- Is_Leap --
   -------------

   function Is_Leap (Year : Year_Number) return Boolean is
   begin
      --  Leap centenial years

      if Year mod 400 = 0 then
         return True;

      --  Non-leap centenial years

      elsif Year mod 100 = 0 then
         return False;

      --  Regular years

      else
         return Year mod 4 = 0;
      end if;
   end Is_Leap;

kenner's avatar
kenner committed
469 470 471 472 473
   -----------
   -- Month --
   -----------

   function Month (Date : Time) return Month_Number is
474 475 476 477
      Y : Year_Number;
      M : Month_Number;
      D : Day_Number;
      S : Day_Duration;
478
      pragma Unreferenced (Y, D, S);
kenner's avatar
kenner committed
479
   begin
480 481
      Split (Date, Y, M, D, S);
      return M;
kenner's avatar
kenner committed
482 483 484 485 486 487 488
   end Month;

   -------------
   -- Seconds --
   -------------

   function Seconds (Date : Time) return Day_Duration is
489 490 491 492
      Y : Year_Number;
      M : Month_Number;
      D : Day_Number;
      S : Day_Duration;
493
      pragma Unreferenced (Y, M, D);
kenner's avatar
kenner committed
494
   begin
495 496
      Split (Date, Y, M, D, S);
      return S;
kenner's avatar
kenner committed
497 498 499 500 501 502 503 504 505 506 507 508 509
   end Seconds;

   -----------
   -- Split --
   -----------

   procedure Split
     (Date    : Time;
      Year    : out Year_Number;
      Month   : out Month_Number;
      Day     : out Day_Number;
      Seconds : out Day_Duration)
   is
510 511 512 513 514
      H  : Integer;
      M  : Integer;
      Se : Integer;
      Ss : Duration;
      Le : Boolean;
515

kenner's avatar
kenner committed
516
   begin
517 518 519
      --  Use UTC as the local time zone on VMS, the status of flag Is_Ada_05
      --  is irrelevant in this case.

520
      Formatting_Operations.Split
521 522 523 524 525 526 527 528 529 530 531 532
        (Date      => Date,
         Year      => Year,
         Month     => Month,
         Day       => Day,
         Day_Secs  => Seconds,
         Hour      => H,
         Minute    => M,
         Second    => Se,
         Sub_Sec   => Ss,
         Leap_Sec  => Le,
         Is_Ada_05 => False,
         Time_Zone => 0);
kenner's avatar
kenner committed
533

534 535 536 537 538 539
      --  Validity checks

      if not Year'Valid
        or else not Month'Valid
        or else not Day'Valid
        or else not Seconds'Valid
kenner's avatar
kenner committed
540 541 542 543 544 545 546 547 548 549 550 551 552
      then
         raise Time_Error;
      end if;
   end Split;

   -------------
   -- Time_Of --
   -------------

   function Time_Of
     (Year    : Year_Number;
      Month   : Month_Number;
      Day     : Day_Number;
553
      Seconds : Day_Duration := 0.0) return Time
kenner's avatar
kenner committed
554
   is
555 556 557
      --  The values in the following constants are irrelevant, they are just
      --  placeholders; the choice of constructing a Day_Duration value is
      --  controlled by the Use_Day_Secs flag.
kenner's avatar
kenner committed
558

559 560 561 562
      H  : constant Integer := 1;
      M  : constant Integer := 1;
      Se : constant Integer := 1;
      Ss : constant Duration := 0.1;
563

kenner's avatar
kenner committed
564
   begin
565 566 567
      if not Year'Valid
        or else not Month'Valid
        or else not Day'Valid
kenner's avatar
kenner committed
568 569
        or else not Seconds'Valid
      then
570
         raise Time_Error;
kenner's avatar
kenner committed
571 572
      end if;

573 574 575
      --  Use UTC as the local time zone on VMS, the status of flag Is_Ada_05
      --  is irrelevant in this case.

576 577
      return
        Formatting_Operations.Time_Of
578 579 580 581 582 583 584 585
          (Year         => Year,
           Month        => Month,
           Day          => Day,
           Day_Secs     => Seconds,
           Hour         => H,
           Minute       => M,
           Second       => Se,
           Sub_Sec      => Ss,
586 587
           Leap_Sec     => False,
           Use_Day_Secs => True,
588
           Is_Ada_05    => False,
589 590
           Time_Zone    => 0);
   end Time_Of;
kenner's avatar
kenner committed
591

592 593 594
   -----------------
   -- To_Duration --
   -----------------
kenner's avatar
kenner committed
595

596 597 598 599 600 601
   function To_Duration (T : Time) return Duration is
      function Time_To_Duration is
        new Ada.Unchecked_Conversion (Time, Duration);
   begin
      return Time_To_Duration (T * 100);
   end To_Duration;
kenner's avatar
kenner committed
602

603 604 605
   ----------------------
   -- To_Relative_Time --
   ----------------------
kenner's avatar
kenner committed
606

607 608 609 610 611 612
   function To_Relative_Time (D : Duration) return Time is
      function Duration_To_Time is
        new Ada.Unchecked_Conversion (Duration, Time);
   begin
      return Duration_To_Time (D / 100.0);
   end To_Relative_Time;
kenner's avatar
kenner committed
613 614 615 616 617 618

   ----------
   -- Year --
   ----------

   function Year (Date : Time) return Year_Number is
619 620 621 622
      Y : Year_Number;
      M : Month_Number;
      D : Day_Number;
      S : Day_Duration;
623
      pragma Unreferenced (M, D, S);
kenner's avatar
kenner committed
624
   begin
625 626
      Split (Date, Y, M, D, S);
      return Y;
kenner's avatar
kenner committed
627 628
   end Year;

629 630
   --  The following packages assume that Time is a Long_Integer, the units
   --  are 100 nanoseconds and the starting point in the VMS Epoch.
631

632 633 634
   ---------------------------
   -- Arithmetic_Operations --
   ---------------------------
635

636
   package body Arithmetic_Operations is
637

638 639 640
      ---------
      -- Add --
      ---------
641

642
      function Add (Date : Time; Days : Long_Integer) return Time is
643
         pragma Unsuppress (Overflow_Check);
644
      begin
645
         return Date + Time (Days) * Milis_In_Day;
646 647 648 649 650 651 652 653 654 655 656 657 658 659 660
      exception
         when Constraint_Error =>
            raise Time_Error;
      end Add;

      ----------------
      -- Difference --
      ----------------

      procedure Difference
        (Left         : Time;
         Right        : Time;
         Days         : out Long_Integer;
         Seconds      : out Duration;
         Leap_Seconds : out Integer)
661
      is
662 663 664 665 666 667 668
         Mili_F : constant Duration := 10_000_000.0;

         Diff_M        : Time;
         Diff_S        : Time;
         Earlier       : Time;
         Elapsed_Leaps : Natural;
         Later         : Time;
669
         Negate        : Boolean := False;
670 671 672
         Next_Leap     : Time;
         Sub_Seconds   : Duration;

673
      begin
674 675 676 677 678 679 680 681 682 683 684 685
         --  This classification is necessary in order to avoid a Time_Error
         --  being raised by the arithmetic operators in Ada.Calendar.

         if Left >= Right then
            Later   := Left;
            Earlier := Right;
         else
            Later   := Right;
            Earlier := Left;
            Negate  := True;
         end if;

686
         --  If the target supports leap seconds, process them
687

688 689 690
         if Leap_Support then
            Cumulative_Leap_Seconds
              (Earlier, Later, Elapsed_Leaps, Next_Leap);
691

692 693 694 695 696 697 698 699
            if Later >= Next_Leap then
               Elapsed_Leaps := Elapsed_Leaps + 1;
            end if;

         --  The target does not support leap seconds

         else
            Elapsed_Leaps := 0;
700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717
         end if;

         Diff_M := Later - Earlier - Time (Elapsed_Leaps) * Mili;

         --  Sub second processing

         Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F;

         --  Convert to seconds. Note that his action eliminates the sub
         --  seconds automatically.

         Diff_S := Diff_M / Mili;

         Days := Long_Integer (Diff_S / Secs_In_Day);
         Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds;
         Leap_Seconds := Integer (Elapsed_Leaps);

         if Negate then
718 719 720 721 722 723
            Days    := -Days;
            Seconds := -Seconds;

            if Leap_Seconds /= 0 then
               Leap_Seconds := -Leap_Seconds;
            end if;
724 725 726 727 728 729 730 731
         end if;
      end Difference;

      --------------
      -- Subtract --
      --------------

      function Subtract (Date : Time; Days : Long_Integer) return Time is
732
         pragma Unsuppress (Overflow_Check);
733
      begin
734
         return Date - Time (Days) * Milis_In_Day;
735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780
      exception
         when Constraint_Error =>
            raise Time_Error;
      end Subtract;
   end Arithmetic_Operations;

   ---------------------------
   -- Formatting_Operations --
   ---------------------------

   package body Formatting_Operations is

      -----------------
      -- Day_Of_Week --
      -----------------

      function Day_Of_Week (Date : Time) return Integer is
         Y : Year_Number;
         M : Month_Number;
         D : Day_Number;
         S : Day_Duration;

         Day_Count     : Long_Integer;
         Midday_Date_S : Time;

      begin
         Split (Date, Y, M, D, S);

         --  Build a time value in the middle of the same day and convert the
         --  time value to seconds.

         Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili;

         --  Count the number of days since the start of VMS time. 1858-11-17
         --  was a Wednesday.

         Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2;

         return Integer (Day_Count mod 7);
      end Day_Of_Week;

      -----------
      -- Split --
      -----------

      procedure Split
781 782 783 784 785 786 787 788 789 790 791 792
        (Date      : Time;
         Year      : out Year_Number;
         Month     : out Month_Number;
         Day       : out Day_Number;
         Day_Secs  : out Day_Duration;
         Hour      : out Integer;
         Minute    : out Integer;
         Second    : out Integer;
         Sub_Sec   : out Duration;
         Leap_Sec  : out Boolean;
         Is_Ada_05 : Boolean;
         Time_Zone : Long_Integer)
793
      is
794 795 796 797
         --  The flag Is_Ada_05 is present for interfacing purposes

         pragma Unreferenced (Is_Ada_05);

798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816
         procedure Numtim
           (Status : out Unsigned_Longword;
            Timbuf : out Unsigned_Word_Array;
            Timadr : Time);

         pragma Interface (External, Numtim);

         pragma Import_Valued_Procedure
           (Numtim, "SYS$NUMTIM",
           (Unsigned_Longword, Unsigned_Word_Array, Time),
           (Value, Reference, Reference));

         Status : Unsigned_Longword;
         Timbuf : Unsigned_Word_Array (1 .. 7);

         Ada_Min_Year : constant := 1901;
         Ada_Max_Year : constant := 2399;
         Mili_F       : constant Duration := 10_000_000.0;

817 818 819
         Date_M        : Time;
         Elapsed_Leaps : Natural;
         Next_Leap_M   : Time;
820 821

      begin
822
         Date_M := Date;
823 824 825

         --  Step 1: Leap seconds processing

826 827 828 829 830 831 832 833 834
         if Leap_Support then
            Cumulative_Leap_Seconds
              (Start_Of_Time, Date, Elapsed_Leaps, Next_Leap_M);

            Leap_Sec := Date_M >= Next_Leap_M;

            if Leap_Sec then
               Elapsed_Leaps := Elapsed_Leaps + 1;
            end if;
835

836
         --  The target does not support leap seconds
837

838 839 840
         else
            Elapsed_Leaps := 0;
            Leap_Sec      := False;
841 842
         end if;

843 844
         Date_M := Date_M - Time (Elapsed_Leaps) * Mili;

845 846 847
         --  Step 2: Time zone processing

         if Time_Zone /= 0 then
848
            Date_M := Date_M + Time (Time_Zone) * 60 * Mili;
849 850 851 852 853
         end if;

         --  After the leap seconds and time zone have been accounted for,
         --  the date should be within the bounds of Ada time.

854 855
         if Date_M < Ada_Low
           or else Date_M > Ada_High
856 857 858 859 860 861
         then
            raise Time_Error;
         end if;

         --  Step 3: Sub second processing

862
         Sub_Sec := Duration (Date_M mod Mili) / Mili_F;
863 864 865

         --  Drop the sub seconds

866
         Date_M := Date_M - (Date_M mod Mili);
867 868 869

         --  Step 4: VMS system call

870
         Numtim (Status, Timbuf, Date_M);
871 872 873 874 875 876 877 878 879 880 881 882 883 884 885

         if Status mod 2 /= 1
           or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year
         then
            raise Time_Error;
         end if;

         --  Step 5: Time components processing

         Year   := Year_Number (Timbuf (1));
         Month  := Month_Number (Timbuf (2));
         Day    := Day_Number (Timbuf (3));
         Hour   := Integer (Timbuf (4));
         Minute := Integer (Timbuf (5));
         Second := Integer (Timbuf (6));
886

887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907
         Day_Secs := Day_Duration (Hour   * 3_600) +
                     Day_Duration (Minute *    60) +
                     Day_Duration (Second)         +
                                   Sub_Sec;
      end Split;

      -------------
      -- Time_Of --
      -------------

      function Time_Of
        (Year         : Year_Number;
         Month        : Month_Number;
         Day          : Day_Number;
         Day_Secs     : Day_Duration;
         Hour         : Integer;
         Minute       : Integer;
         Second       : Integer;
         Sub_Sec      : Duration;
         Leap_Sec     : Boolean;
         Use_Day_Secs : Boolean;
908
         Is_Ada_05    : Boolean;
909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927
         Time_Zone    : Long_Integer) return Time
      is
         procedure Cvt_Vectim
           (Status         : out Unsigned_Longword;
            Input_Time     : Unsigned_Word_Array;
            Resultant_Time : out Time);

         pragma Interface (External, Cvt_Vectim);

         pragma Import_Valued_Procedure
           (Cvt_Vectim, "LIB$CVT_VECTIM",
           (Unsigned_Longword, Unsigned_Word_Array, Time),
           (Value, Reference, Reference));

         Status : Unsigned_Longword;
         Timbuf : Unsigned_Word_Array (1 .. 7);

         Mili_F : constant := 10_000_000.0;

928 929 930 931 932 933 934
         Y  : Year_Number  := Year;
         Mo : Month_Number := Month;
         D  : Day_Number   := Day;
         H  : Integer      := Hour;
         Mi : Integer      := Minute;
         Se : Integer      := Second;
         Su : Duration     := Sub_Sec;
935

936 937 938 939 940
         Elapsed_Leaps : Natural;
         Int_Day_Secs  : Integer;
         Next_Leap_M   : Time;
         Res_M         : Time;
         Rounded_Res_M : Time;
941 942

      begin
943 944 945 946 947 948 949
         --  No validity checks are performed on the input values since it is
         --  assumed that the called has already performed them.

         --  Step 1: Hour, minute, second and sub second processing

         if Use_Day_Secs then

950
            --  A day seconds value of 86_400 designates a new day
951 952

            if Day_Secs = 86_400.0 then
953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990
               declare
                  Adj_Year  : Year_Number := Year;
                  Adj_Month : Month_Number := Month;
                  Adj_Day   : Day_Number   := Day;

               begin
                  if Day < Days_In_Month (Month)
                    or else (Month = 2
                               and then Is_Leap (Year))
                  then
                     Adj_Day := Day + 1;

                  --  The day adjustment moves the date to a new month

                  else
                     Adj_Day := 1;

                     if Month < 12 then
                        Adj_Month := Month + 1;

                     --  The month adjustment moves the date to a new year

                     else
                        Adj_Month := 1;
                        Adj_Year  := Year + 1;
                     end if;
                  end if;

                  Y  := Adj_Year;
                  Mo := Adj_Month;
                  D  := Adj_Day;
                  H  := 0;
                  Mi := 0;
                  Se := 0;
                  Su := 0.0;
               end;

            --  Normal case (not exactly one day)
991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009

            else
               --  Sub second extraction

               if Day_Secs > 0.0 then
                  Int_Day_Secs := Integer (Day_Secs - 0.5);
               else
                  Int_Day_Secs := Integer (Day_Secs);
               end if;

               H  := Int_Day_Secs / 3_600;
               Mi := (Int_Day_Secs / 60) mod 60;
               Se := Int_Day_Secs mod 60;
               Su := Day_Secs - Duration (Int_Day_Secs);
            end if;
         end if;

         --  Step 2: System call to VMS

1010 1011 1012
         Timbuf (1) := Unsigned_Word (Y);
         Timbuf (2) := Unsigned_Word (Mo);
         Timbuf (3) := Unsigned_Word (D);
1013 1014 1015 1016 1017
         Timbuf (4) := Unsigned_Word (H);
         Timbuf (5) := Unsigned_Word (Mi);
         Timbuf (6) := Unsigned_Word (Se);
         Timbuf (7) := 0;

1018
         Cvt_Vectim (Status, Timbuf, Res_M);
1019 1020 1021 1022 1023

         if Status mod 2 /= 1 then
            raise Time_Error;
         end if;

1024
         --  Step 3: Sub second adjustment
1025

1026
         Res_M := Res_M + Time (Su * Mili_F);
1027

1028
         --  Step 4: Bounds check
1029

1030
         Check_Within_Time_Bounds (Res_M);
1031 1032 1033 1034

         --  Step 5: Time zone processing

         if Time_Zone /= 0 then
1035
            Res_M := Res_M - Time (Time_Zone) * 60 * Mili;
1036 1037 1038
         end if;

         --  Step 6: Leap seconds processing
1039

1040 1041 1042
         if Leap_Support then
            Cumulative_Leap_Seconds
              (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M);
1043

1044
            Res_M := Res_M + Time (Elapsed_Leaps) * Mili;
1045

1046 1047
            --  An Ada 2005 caller requesting an explicit leap second or an
            --  Ada 95 caller accounting for an invisible leap second.
1048

1049 1050 1051 1052 1053
            if Leap_Sec
              or else Res_M >= Next_Leap_M
            then
               Res_M := Res_M + Time (1) * Mili;
            end if;
1054

1055
            --  Leap second validity check
1056

1057
            Rounded_Res_M := Res_M - (Res_M mod Mili);
1058

1059 1060 1061 1062 1063 1064
            if Is_Ada_05
              and then Leap_Sec
              and then Rounded_Res_M /= Next_Leap_M
            then
               raise Time_Error;
            end if;
1065 1066
         end if;

1067
         return Res_M;
1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097
      end Time_Of;
   end Formatting_Operations;

   ---------------------------
   -- Time_Zones_Operations --
   ---------------------------

   package body Time_Zones_Operations is

      ---------------------
      -- UTC_Time_Offset --
      ---------------------

      function UTC_Time_Offset (Date : Time) return Long_Integer is
         --  Formal parameter Date is here for interfacing, but is never
         --  actually used.

         pragma Unreferenced (Date);

         function get_gmtoff return Long_Integer;
         pragma Import (C, get_gmtoff, "get_gmtoff");

      begin
         --  VMS is not capable of determining the time zone in some past or
         --  future point in time denoted by Date, thus the current time zone
         --  is retrieved.

         return get_gmtoff;
      end UTC_Time_Offset;
   end Time_Zones_Operations;
kenner's avatar
kenner committed
1098
end Ada.Calendar;