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-2012, 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 3, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is the Alpha/VMS version 33 34with Ada.Unchecked_Conversion; 35 36with System.Aux_DEC; use System.Aux_DEC; 37with System.OS_Primitives; use System.OS_Primitives; 38 39package body Ada.Calendar is 40 41 -------------------------- 42 -- Implementation Notes -- 43 -------------------------- 44 45 -- Variables of type Ada.Calendar.Time have suffix _S or _M to denote 46 -- units of seconds or milis. 47 48 -- Because time is measured in different units and from different origins 49 -- on various targets, a system independent model is incorporated into 50 -- Ada.Calendar. The idea behind the design is to encapsulate all target 51 -- dependent machinery in a single package, thus providing a uniform 52 -- interface to all existing and potential children. 53 54 -- package Ada.Calendar 55 -- procedure Split (5 parameters) -------+ 56 -- | Call from local routine 57 -- private | 58 -- package Formatting_Operations | 59 -- procedure Split (11 parameters) <--+ 60 -- end Formatting_Operations | 61 -- end Ada.Calendar | 62 -- | 63 -- package Ada.Calendar.Formatting | Call from child routine 64 -- procedure Split (9 or 10 parameters) -+ 65 -- end Ada.Calendar.Formatting 66 67 -- The behaviour of the interfacing routines is controlled via various 68 -- flags. All new Ada 2005 types from children of Ada.Calendar are 69 -- emulated by a similar type. For instance, type Day_Number is replaced 70 -- by Integer in various routines. One ramification of this model is that 71 -- the caller site must perform validity checks on returned results. 72 -- The end result of this model is the lack of target specific files per 73 -- child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc). 74 75 ----------------------- 76 -- Local Subprograms -- 77 ----------------------- 78 79 procedure Check_Within_Time_Bounds (T : OS_Time); 80 -- Ensure that a time representation value falls withing the bounds of Ada 81 -- time. Leap seconds support is taken into account. 82 83 procedure Cumulative_Leap_Seconds 84 (Start_Date : OS_Time; 85 End_Date : OS_Time; 86 Elapsed_Leaps : out Natural; 87 Next_Leap_Sec : out OS_Time); 88 -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or 89 -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec 90 -- represents the next leap second occurrence on or after End_Date. If 91 -- there are no leaps seconds after End_Date, End_Of_Time is returned. 92 -- End_Of_Time can be used as End_Date to count all the leap seconds that 93 -- have occurred on or after Start_Date. 94 -- 95 -- Note: Any sub seconds of Start_Date and End_Date are discarded before 96 -- the calculations are done. For instance: if 113 seconds is a leap 97 -- second (it isn't) and 113.5 is input as an End_Date, the leap second 98 -- at 113 will not be counted in Leaps_Between, but it will be returned 99 -- as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is 100 -- a leap second, the comparison should be: 101 -- 102 -- End_Date >= Next_Leap_Sec; 103 -- 104 -- After_Last_Leap is designed so that this comparison works without 105 -- having to first check if Next_Leap_Sec is a valid leap second. 106 107 function To_Duration (T : Time) return Duration; 108 function To_Relative_Time (D : Duration) return Time; 109 -- It is important to note that duration's fractional part denotes nano 110 -- seconds while the units of Time are 100 nanoseconds. If a regular 111 -- Unchecked_Conversion was employed, the resulting values would be off 112 -- by 100. 113 114 -------------------------- 115 -- Leap seconds control -- 116 -------------------------- 117 118 Flag : Integer; 119 pragma Import (C, Flag, "__gl_leap_seconds_support"); 120 -- This imported value is used to determine whether the compilation had 121 -- binder flag "-y" present which enables leap seconds. A value of zero 122 -- signifies no leap seconds support while a value of one enables the 123 -- support. 124 125 Leap_Support : constant Boolean := Flag = 1; 126 -- The above flag controls the usage of leap seconds in all Ada.Calendar 127 -- routines. 128 129 Leap_Seconds_Count : constant Natural := 25; 130 131 --------------------- 132 -- Local Constants -- 133 --------------------- 134 135 -- The range of Ada time expressed as milis since the VMS Epoch 136 137 Ada_Low : constant OS_Time := (10 * 366 + 32 * 365 + 45) * Milis_In_Day; 138 Ada_High : constant OS_Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day; 139 140 -- Even though the upper bound of time is 2399-12-31 23:59:59.9999999 141 -- UTC, it must be increased to include all leap seconds. 142 143 Ada_High_And_Leaps : constant OS_Time := 144 Ada_High + OS_Time (Leap_Seconds_Count) * Mili; 145 146 -- Two constants used in the calculations of elapsed leap seconds. 147 -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time 148 -- is earlier than Ada_Low in time zone +28. 149 150 End_Of_Time : constant OS_Time := Ada_High + OS_Time (3) * Milis_In_Day; 151 Start_Of_Time : constant OS_Time := Ada_Low - OS_Time (3) * Milis_In_Day; 152 153 -- The following table contains the hard time values of all existing leap 154 -- seconds. The values are produced by the utility program xleaps.adb. 155 156 Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of OS_Time := 157 (35855136000000000, 158 36014112010000000, 159 36329472020000000, 160 36644832030000000, 161 36960192040000000, 162 37276416050000000, 163 37591776060000000, 164 37907136070000000, 165 38222496080000000, 166 38695104090000000, 167 39010464100000000, 168 39325824110000000, 169 39957408120000000, 170 40747104130000000, 171 41378688140000000, 172 41694048150000000, 173 42166656160000000, 174 42482016170000000, 175 42797376180000000, 176 43271712190000000, 177 43744320200000000, 178 44218656210000000, 179 46427904220000000, 180 47374848230000000, 181 48478176240000000); 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 Use_TZ is 521 -- 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 Use_TZ => False, 535 Is_Historic => True, 536 Time_Zone => 0); 537 538 -- Validity checks 539 540 if not Year'Valid 541 or else not Month'Valid 542 or else not Day'Valid 543 or else not Seconds'Valid 544 then 545 raise Time_Error; 546 end if; 547 end Split; 548 549 ------------- 550 -- Time_Of -- 551 ------------- 552 553 function Time_Of 554 (Year : Year_Number; 555 Month : Month_Number; 556 Day : Day_Number; 557 Seconds : Day_Duration := 0.0) return Time 558 is 559 -- The values in the following constants are irrelevant, they are just 560 -- placeholders; the choice of constructing a Day_Duration value is 561 -- controlled by the Use_Day_Secs flag. 562 563 H : constant Integer := 1; 564 M : constant Integer := 1; 565 Se : constant Integer := 1; 566 Ss : constant Duration := 0.1; 567 568 begin 569 if not Year'Valid 570 or else not Month'Valid 571 or else not Day'Valid 572 or else not Seconds'Valid 573 then 574 raise Time_Error; 575 end if; 576 577 -- Use UTC as the local time zone on VMS, the status of flag Use_TZ is 578 -- irrelevant in this case. 579 580 return 581 Formatting_Operations.Time_Of 582 (Year => Year, 583 Month => Month, 584 Day => Day, 585 Day_Secs => Seconds, 586 Hour => H, 587 Minute => M, 588 Second => Se, 589 Sub_Sec => Ss, 590 Leap_Sec => False, 591 Use_Day_Secs => True, 592 Use_TZ => False, 593 Is_Historic => True, 594 Time_Zone => 0); 595 end Time_Of; 596 597 ----------------- 598 -- To_Duration -- 599 ----------------- 600 601 function To_Duration (T : Time) return Duration is 602 function Time_To_Duration is 603 new Ada.Unchecked_Conversion (Time, Duration); 604 begin 605 return Time_To_Duration (T * 100); 606 end To_Duration; 607 608 ---------------------- 609 -- To_Relative_Time -- 610 ---------------------- 611 612 function To_Relative_Time (D : Duration) return Time is 613 function Duration_To_Time is 614 new Ada.Unchecked_Conversion (Duration, Time); 615 begin 616 return Duration_To_Time (D / 100.0); 617 end To_Relative_Time; 618 619 ---------- 620 -- Year -- 621 ---------- 622 623 function Year (Date : Time) return Year_Number is 624 Y : Year_Number; 625 M : Month_Number; 626 D : Day_Number; 627 S : Day_Duration; 628 pragma Unreferenced (M, D, S); 629 begin 630 Split (Date, Y, M, D, S); 631 return Y; 632 end Year; 633 634 -- The following packages assume that Time is a Long_Integer, the units 635 -- are 100 nanoseconds and the starting point in the VMS Epoch. 636 637 --------------------------- 638 -- Arithmetic_Operations -- 639 --------------------------- 640 641 package body Arithmetic_Operations is 642 643 --------- 644 -- Add -- 645 --------- 646 647 function Add (Date : Time; Days : Long_Integer) return Time is 648 pragma Unsuppress (Overflow_Check); 649 Date_M : constant OS_Time := OS_Time (Date); 650 begin 651 return Time (Date_M + OS_Time (Days) * Milis_In_Day); 652 exception 653 when Constraint_Error => 654 raise Time_Error; 655 end Add; 656 657 ---------------- 658 -- Difference -- 659 ---------------- 660 661 procedure Difference 662 (Left : Time; 663 Right : Time; 664 Days : out Long_Integer; 665 Seconds : out Duration; 666 Leap_Seconds : out Integer) 667 is 668 Diff_M : OS_Time; 669 Diff_S : OS_Time; 670 Earlier : OS_Time; 671 Elapsed_Leaps : Natural; 672 Later : OS_Time; 673 Negate : Boolean := False; 674 Next_Leap : OS_Time; 675 Sub_Seconds : Duration; 676 677 begin 678 -- This classification is necessary in order to avoid a Time_Error 679 -- being raised by the arithmetic operators in Ada.Calendar. 680 681 if Left >= Right then 682 Later := OS_Time (Left); 683 Earlier := OS_Time (Right); 684 else 685 Later := OS_Time (Right); 686 Earlier := OS_Time (Left); 687 Negate := True; 688 end if; 689 690 -- If the target supports leap seconds, process them 691 692 if Leap_Support then 693 Cumulative_Leap_Seconds 694 (Earlier, Later, Elapsed_Leaps, Next_Leap); 695 696 if Later >= Next_Leap then 697 Elapsed_Leaps := Elapsed_Leaps + 1; 698 end if; 699 700 -- The target does not support leap seconds 701 702 else 703 Elapsed_Leaps := 0; 704 end if; 705 706 Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili; 707 708 -- Sub second processing 709 710 Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F; 711 712 -- Convert to seconds. Note that his action eliminates the sub 713 -- seconds automatically. 714 715 Diff_S := Diff_M / Mili; 716 717 Days := Long_Integer (Diff_S / Secs_In_Day); 718 Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds; 719 Leap_Seconds := Integer (Elapsed_Leaps); 720 721 if Negate then 722 Days := -Days; 723 Seconds := -Seconds; 724 725 if Leap_Seconds /= 0 then 726 Leap_Seconds := -Leap_Seconds; 727 end if; 728 end if; 729 end Difference; 730 731 -------------- 732 -- Subtract -- 733 -------------- 734 735 function Subtract (Date : Time; Days : Long_Integer) return Time is 736 pragma Unsuppress (Overflow_Check); 737 Date_M : constant OS_Time := OS_Time (Date); 738 begin 739 return Time (Date_M - OS_Time (Days) * Milis_In_Day); 740 exception 741 when Constraint_Error => 742 raise Time_Error; 743 end Subtract; 744 end Arithmetic_Operations; 745 746 --------------------------- 747 -- Conversion_Operations -- 748 --------------------------- 749 750 package body Conversion_Operations is 751 752 Epoch_Offset : constant OS_Time := 35067168000000000; 753 -- The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in 754 -- 100 nanoseconds. 755 756 ----------------- 757 -- To_Ada_Time -- 758 ----------------- 759 760 function To_Ada_Time (Unix_Time : Long_Integer) return Time is 761 pragma Unsuppress (Overflow_Check); 762 Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili; 763 begin 764 return Time (Unix_Rep + Epoch_Offset); 765 exception 766 when Constraint_Error => 767 raise Time_Error; 768 end To_Ada_Time; 769 770 ----------------- 771 -- To_Ada_Time -- 772 ----------------- 773 774 function To_Ada_Time 775 (tm_year : Integer; 776 tm_mon : Integer; 777 tm_day : Integer; 778 tm_hour : Integer; 779 tm_min : Integer; 780 tm_sec : Integer; 781 tm_isdst : Integer) return Time 782 is 783 pragma Unsuppress (Overflow_Check); 784 785 Year_Shift : constant Integer := 1900; 786 Month_Shift : constant Integer := 1; 787 788 Year : Year_Number; 789 Month : Month_Number; 790 Day : Day_Number; 791 Second : Integer; 792 Leap : Boolean; 793 Result : OS_Time; 794 795 begin 796 -- Input processing 797 798 Year := Year_Number (Year_Shift + tm_year); 799 Month := Month_Number (Month_Shift + tm_mon); 800 Day := Day_Number (tm_day); 801 802 -- Step 1: Validity checks of input values 803 804 if not Year'Valid 805 or else not Month'Valid 806 or else not Day'Valid 807 or else tm_hour not in 0 .. 24 808 or else tm_min not in 0 .. 59 809 or else tm_sec not in 0 .. 60 810 or else tm_isdst not in -1 .. 1 811 then 812 raise Time_Error; 813 end if; 814 815 -- Step 2: Potential leap second 816 817 if tm_sec = 60 then 818 Leap := True; 819 Second := 59; 820 else 821 Leap := False; 822 Second := tm_sec; 823 end if; 824 825 -- Step 3: Calculate the time value 826 827 Result := 828 OS_Time 829 (Formatting_Operations.Time_Of 830 (Year => Year, 831 Month => Month, 832 Day => Day, 833 Day_Secs => 0.0, -- Time is given in h:m:s 834 Hour => tm_hour, 835 Minute => tm_min, 836 Second => Second, 837 Sub_Sec => 0.0, -- No precise sub second given 838 Leap_Sec => Leap, 839 Use_Day_Secs => False, -- Time is given in h:m:s 840 Use_TZ => True, -- Force usage of explicit time zone 841 Is_Historic => True, 842 Time_Zone => 0)); -- Place the value in UTC 843 -- Step 4: Daylight Savings Time 844 845 if tm_isdst = 1 then 846 Result := Result + OS_Time (3_600) * Mili; 847 end if; 848 849 return Time (Result); 850 exception 851 when Constraint_Error => 852 raise Time_Error; 853 end To_Ada_Time; 854 855 ----------------- 856 -- To_Duration -- 857 ----------------- 858 859 function To_Duration 860 (tv_sec : Long_Integer; 861 tv_nsec : Long_Integer) return Duration 862 is 863 pragma Unsuppress (Overflow_Check); 864 begin 865 return Duration (tv_sec) + Duration (tv_nsec) / Mili_F; 866 end To_Duration; 867 868 ------------------------ 869 -- To_Struct_Timespec -- 870 ------------------------ 871 872 procedure To_Struct_Timespec 873 (D : Duration; 874 tv_sec : out Long_Integer; 875 tv_nsec : out Long_Integer) 876 is 877 pragma Unsuppress (Overflow_Check); 878 Secs : Duration; 879 Nano_Secs : Duration; 880 881 begin 882 -- Seconds extraction, avoid potential rounding errors 883 884 Secs := D - 0.5; 885 tv_sec := Long_Integer (Secs); 886 887 -- 100 Nanoseconds extraction 888 889 Nano_Secs := D - Duration (tv_sec); 890 tv_nsec := Long_Integer (Nano_Secs * Mili); 891 end To_Struct_Timespec; 892 893 ------------------ 894 -- To_Struct_Tm -- 895 ------------------ 896 897 procedure To_Struct_Tm 898 (T : Time; 899 tm_year : out Integer; 900 tm_mon : out Integer; 901 tm_day : out Integer; 902 tm_hour : out Integer; 903 tm_min : out Integer; 904 tm_sec : out Integer) 905 is 906 pragma Unsuppress (Overflow_Check); 907 Year : Year_Number; 908 Month : Month_Number; 909 Second : Integer; 910 Day_Secs : Day_Duration; 911 Sub_Sec : Duration; 912 Leap_Sec : Boolean; 913 914 begin 915 -- Step 1: Split the input time 916 917 Formatting_Operations.Split 918 (Date => T, 919 Year => Year, 920 Month => Month, 921 Day => tm_day, 922 Day_Secs => Day_Secs, 923 Hour => tm_hour, 924 Minute => tm_min, 925 Second => Second, 926 Sub_Sec => Sub_Sec, 927 Leap_Sec => Leap_Sec, 928 Use_TZ => True, 929 Is_Historic => False, 930 Time_Zone => 0); 931 932 -- Step 2: Correct the year and month 933 934 tm_year := Year - 1900; 935 tm_mon := Month - 1; 936 937 -- Step 3: Handle leap second occurrences 938 939 tm_sec := (if Leap_Sec then 60 else Second); 940 end To_Struct_Tm; 941 942 ------------------ 943 -- To_Unix_Time -- 944 ------------------ 945 946 function To_Unix_Time (Ada_Time : Time) return Long_Integer is 947 pragma Unsuppress (Overflow_Check); 948 Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time); 949 begin 950 return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili); 951 exception 952 when Constraint_Error => 953 raise Time_Error; 954 end To_Unix_Time; 955 end Conversion_Operations; 956 957 --------------------------- 958 -- Formatting_Operations -- 959 --------------------------- 960 961 package body Formatting_Operations is 962 963 ----------------- 964 -- Day_Of_Week -- 965 ----------------- 966 967 function Day_Of_Week (Date : Time) return Integer is 968 Y : Year_Number; 969 M : Month_Number; 970 D : Day_Number; 971 S : Day_Duration; 972 973 Day_Count : Long_Integer; 974 Midday_Date_S : Time; 975 976 begin 977 Split (Date, Y, M, D, S); 978 979 -- Build a time value in the middle of the same day and convert the 980 -- time value to seconds. 981 982 Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili; 983 984 -- Count the number of days since the start of VMS time. 1858-11-17 985 -- was a Wednesday. 986 987 Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2; 988 989 return Integer (Day_Count mod 7); 990 end Day_Of_Week; 991 992 ----------- 993 -- Split -- 994 ----------- 995 996 procedure Split 997 (Date : Time; 998 Year : out Year_Number; 999 Month : out Month_Number; 1000 Day : out Day_Number; 1001 Day_Secs : out Day_Duration; 1002 Hour : out Integer; 1003 Minute : out Integer; 1004 Second : out Integer; 1005 Sub_Sec : out Duration; 1006 Leap_Sec : out Boolean; 1007 Use_TZ : Boolean; 1008 Is_Historic : Boolean; 1009 Time_Zone : Long_Integer) 1010 is 1011 -- Flags Use_TZ and Is_Historic are present for interfacing purposes 1012 1013 pragma Unreferenced (Use_TZ, Is_Historic); 1014 1015 procedure Numtim 1016 (Status : out Unsigned_Longword; 1017 Timbuf : out Unsigned_Word_Array; 1018 Timadr : Time); 1019 1020 pragma Import (External, Numtim); 1021 1022 pragma Import_Valued_Procedure 1023 (Numtim, "SYS$NUMTIM", 1024 (Unsigned_Longword, Unsigned_Word_Array, Time), 1025 (Value, Reference, Reference)); 1026 1027 Status : Unsigned_Longword; 1028 Timbuf : Unsigned_Word_Array (1 .. 7); 1029 1030 Ada_Min_Year : constant := 1901; 1031 Ada_Max_Year : constant := 2399; 1032 1033 Date_M : OS_Time; 1034 Elapsed_Leaps : Natural; 1035 Next_Leap_M : OS_Time; 1036 1037 begin 1038 Date_M := OS_Time (Date); 1039 1040 -- Step 1: Leap seconds processing 1041 1042 if Leap_Support then 1043 Cumulative_Leap_Seconds 1044 (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M); 1045 1046 Leap_Sec := Date_M >= Next_Leap_M; 1047 1048 if Leap_Sec then 1049 Elapsed_Leaps := Elapsed_Leaps + 1; 1050 end if; 1051 1052 -- The target does not support leap seconds 1053 1054 else 1055 Elapsed_Leaps := 0; 1056 Leap_Sec := False; 1057 end if; 1058 1059 Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili; 1060 1061 -- Step 2: Time zone processing 1062 1063 if Time_Zone /= 0 then 1064 Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili; 1065 end if; 1066 1067 -- After the leap seconds and time zone have been accounted for, 1068 -- the date should be within the bounds of Ada time. 1069 1070 if Date_M < Ada_Low 1071 or else Date_M > Ada_High 1072 then 1073 raise Time_Error; 1074 end if; 1075 1076 -- Step 3: Sub second processing 1077 1078 Sub_Sec := Duration (Date_M mod Mili) / Mili_F; 1079 1080 -- Drop the sub seconds 1081 1082 Date_M := Date_M - (Date_M mod Mili); 1083 1084 -- Step 4: VMS system call 1085 1086 Numtim (Status, Timbuf, Time (Date_M)); 1087 1088 if Status mod 2 /= 1 1089 or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year 1090 then 1091 raise Time_Error; 1092 end if; 1093 1094 -- Step 5: Time components processing 1095 1096 Year := Year_Number (Timbuf (1)); 1097 Month := Month_Number (Timbuf (2)); 1098 Day := Day_Number (Timbuf (3)); 1099 Hour := Integer (Timbuf (4)); 1100 Minute := Integer (Timbuf (5)); 1101 Second := Integer (Timbuf (6)); 1102 1103 Day_Secs := Day_Duration (Hour * 3_600) + 1104 Day_Duration (Minute * 60) + 1105 Day_Duration (Second) + 1106 Sub_Sec; 1107 end Split; 1108 1109 ------------- 1110 -- Time_Of -- 1111 ------------- 1112 1113 function Time_Of 1114 (Year : Year_Number; 1115 Month : Month_Number; 1116 Day : Day_Number; 1117 Day_Secs : Day_Duration; 1118 Hour : Integer; 1119 Minute : Integer; 1120 Second : Integer; 1121 Sub_Sec : Duration; 1122 Leap_Sec : Boolean; 1123 Use_Day_Secs : Boolean; 1124 Use_TZ : Boolean; 1125 Is_Historic : Boolean; 1126 Time_Zone : Long_Integer) return Time 1127 is 1128 -- Flag Is_Historic is present for interfacing purposes 1129 1130 pragma Unreferenced (Is_Historic); 1131 1132 procedure Cvt_Vectim 1133 (Status : out Unsigned_Longword; 1134 Input_Time : Unsigned_Word_Array; 1135 Resultant_Time : out Time); 1136 1137 pragma Import (External, Cvt_Vectim); 1138 1139 pragma Import_Valued_Procedure 1140 (Cvt_Vectim, "LIB$CVT_VECTIM", 1141 (Unsigned_Longword, Unsigned_Word_Array, Time), 1142 (Value, Reference, Reference)); 1143 1144 Status : Unsigned_Longword; 1145 Timbuf : Unsigned_Word_Array (1 .. 7); 1146 1147 Y : Year_Number := Year; 1148 Mo : Month_Number := Month; 1149 D : Day_Number := Day; 1150 H : Integer := Hour; 1151 Mi : Integer := Minute; 1152 Se : Integer := Second; 1153 Su : Duration := Sub_Sec; 1154 1155 Elapsed_Leaps : Natural; 1156 Int_Day_Secs : Integer; 1157 Next_Leap_M : OS_Time; 1158 Res : Time; 1159 Res_M : OS_Time; 1160 Rounded_Res_M : OS_Time; 1161 1162 begin 1163 -- No validity checks are performed on the input values since it is 1164 -- assumed that the called has already performed them. 1165 1166 -- Step 1: Hour, minute, second and sub second processing 1167 1168 if Use_Day_Secs then 1169 1170 -- A day seconds value of 86_400 designates a new day 1171 1172 if Day_Secs = 86_400.0 then 1173 declare 1174 Adj_Year : Year_Number := Year; 1175 Adj_Month : Month_Number := Month; 1176 Adj_Day : Day_Number := Day; 1177 1178 begin 1179 if Day < Days_In_Month (Month) 1180 or else (Month = 2 1181 and then Is_Leap (Year)) 1182 then 1183 Adj_Day := Day + 1; 1184 1185 -- The day adjustment moves the date to a new month 1186 1187 else 1188 Adj_Day := 1; 1189 1190 if Month < 12 then 1191 Adj_Month := Month + 1; 1192 1193 -- The month adjustment moves the date to a new year 1194 1195 else 1196 Adj_Month := 1; 1197 Adj_Year := Year + 1; 1198 end if; 1199 end if; 1200 1201 Y := Adj_Year; 1202 Mo := Adj_Month; 1203 D := Adj_Day; 1204 H := 0; 1205 Mi := 0; 1206 Se := 0; 1207 Su := 0.0; 1208 end; 1209 1210 -- Normal case (not exactly one day) 1211 1212 else 1213 -- Sub second extraction 1214 1215 Int_Day_Secs := 1216 (if Day_Secs > 0.0 1217 then Integer (Day_Secs - 0.5) 1218 else Integer (Day_Secs)); 1219 1220 H := Int_Day_Secs / 3_600; 1221 Mi := (Int_Day_Secs / 60) mod 60; 1222 Se := Int_Day_Secs mod 60; 1223 Su := Day_Secs - Duration (Int_Day_Secs); 1224 end if; 1225 end if; 1226 1227 -- Step 2: System call to VMS 1228 1229 Timbuf (1) := Unsigned_Word (Y); 1230 Timbuf (2) := Unsigned_Word (Mo); 1231 Timbuf (3) := Unsigned_Word (D); 1232 Timbuf (4) := Unsigned_Word (H); 1233 Timbuf (5) := Unsigned_Word (Mi); 1234 Timbuf (6) := Unsigned_Word (Se); 1235 Timbuf (7) := 0; 1236 1237 Cvt_Vectim (Status, Timbuf, Res); 1238 1239 if Status mod 2 /= 1 then 1240 raise Time_Error; 1241 end if; 1242 1243 -- Step 3: Sub second adjustment 1244 1245 Res_M := OS_Time (Res) + OS_Time (Su * Mili_F); 1246 1247 -- Step 4: Bounds check 1248 1249 Check_Within_Time_Bounds (Res_M); 1250 1251 -- Step 5: Time zone processing 1252 1253 if Time_Zone /= 0 then 1254 Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili; 1255 end if; 1256 1257 -- Step 6: Leap seconds processing 1258 1259 if Leap_Support then 1260 Cumulative_Leap_Seconds 1261 (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); 1262 1263 Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili; 1264 1265 -- An Ada 2005 caller requesting an explicit leap second or an 1266 -- Ada 95 caller accounting for an invisible leap second. 1267 1268 if Leap_Sec 1269 or else Res_M >= Next_Leap_M 1270 then 1271 Res_M := Res_M + OS_Time (1) * Mili; 1272 end if; 1273 1274 -- Leap second validity check 1275 1276 Rounded_Res_M := Res_M - (Res_M mod Mili); 1277 1278 if Use_TZ 1279 and then Leap_Sec 1280 and then Rounded_Res_M /= Next_Leap_M 1281 then 1282 raise Time_Error; 1283 end if; 1284 end if; 1285 1286 return Time (Res_M); 1287 end Time_Of; 1288 end Formatting_Operations; 1289 1290 --------------------------- 1291 -- Time_Zones_Operations -- 1292 --------------------------- 1293 1294 package body Time_Zones_Operations is 1295 1296 --------------------- 1297 -- UTC_Time_Offset -- 1298 --------------------- 1299 1300 function UTC_Time_Offset (Date : Time) return Long_Integer is 1301 -- Formal parameter Date is here for interfacing, but is never 1302 -- actually used. 1303 1304 pragma Unreferenced (Date); 1305 1306 function get_gmtoff return Long_Integer; 1307 pragma Import (C, get_gmtoff, "get_gmtoff"); 1308 1309 begin 1310 -- VMS is not capable of determining the time zone in some past or 1311 -- future point in time denoted by Date, thus the current time zone 1312 -- is retrieved. 1313 1314 return get_gmtoff; 1315 end UTC_Time_Offset; 1316 end Time_Zones_Operations; 1317end Ada.Calendar; 1318