1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . C A L E N D A R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-2021, AdaCore -- 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 32with Interfaces.C.Extensions; 33 34package body GNAT.Calendar is 35 use Ada.Calendar; 36 use Interfaces; 37 38 ----------------- 39 -- Day_In_Year -- 40 ----------------- 41 42 function Day_In_Year (Date : Time) return Day_In_Year_Number is 43 Year : Year_Number; 44 Month : Month_Number; 45 Day : Day_Number; 46 Day_Secs : Day_Duration; 47 pragma Unreferenced (Day_Secs); 48 begin 49 Split (Date, Year, Month, Day, Day_Secs); 50 return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1; 51 end Day_In_Year; 52 53 ----------------- 54 -- Day_Of_Week -- 55 ----------------- 56 57 function Day_Of_Week (Date : Time) return Day_Name is 58 Year : Year_Number; 59 Month : Month_Number; 60 Day : Day_Number; 61 Day_Secs : Day_Duration; 62 pragma Unreferenced (Day_Secs); 63 begin 64 Split (Date, Year, Month, Day, Day_Secs); 65 return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7); 66 end Day_Of_Week; 67 68 ---------- 69 -- Hour -- 70 ---------- 71 72 function Hour (Date : Time) return Hour_Number is 73 Year : Year_Number; 74 Month : Month_Number; 75 Day : Day_Number; 76 Hour : Hour_Number; 77 Minute : Minute_Number; 78 Second : Second_Number; 79 Sub_Second : Second_Duration; 80 pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second); 81 begin 82 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 83 return Hour; 84 end Hour; 85 86 ---------------- 87 -- Julian_Day -- 88 ---------------- 89 90 -- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this 91 -- implementation is not expensive. 92 93 function Julian_Day 94 (Year : Year_Number; 95 Month : Month_Number; 96 Day : Day_Number) return Integer 97 is 98 Internal_Year : Integer; 99 Internal_Month : Integer; 100 Internal_Day : Integer; 101 Julian_Date : Integer; 102 C : Integer; 103 Ya : Integer; 104 105 begin 106 Internal_Year := Integer (Year); 107 Internal_Month := Integer (Month); 108 Internal_Day := Integer (Day); 109 110 if Internal_Month > 2 then 111 Internal_Month := Internal_Month - 3; 112 else 113 Internal_Month := Internal_Month + 9; 114 Internal_Year := Internal_Year - 1; 115 end if; 116 117 C := Internal_Year / 100; 118 Ya := Internal_Year - (100 * C); 119 120 Julian_Date := (146_097 * C) / 4 + 121 (1_461 * Ya) / 4 + 122 (153 * Internal_Month + 2) / 5 + 123 Internal_Day + 1_721_119; 124 125 return Julian_Date; 126 end Julian_Day; 127 128 ------------ 129 -- Minute -- 130 ------------ 131 132 function Minute (Date : Time) return Minute_Number is 133 Year : Year_Number; 134 Month : Month_Number; 135 Day : Day_Number; 136 Hour : Hour_Number; 137 Minute : Minute_Number; 138 Second : Second_Number; 139 Sub_Second : Second_Duration; 140 pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second); 141 begin 142 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 143 return Minute; 144 end Minute; 145 146 ------------ 147 -- Second -- 148 ------------ 149 150 function Second (Date : Time) return Second_Number is 151 Year : Year_Number; 152 Month : Month_Number; 153 Day : Day_Number; 154 Hour : Hour_Number; 155 Minute : Minute_Number; 156 Second : Second_Number; 157 Sub_Second : Second_Duration; 158 pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second); 159 begin 160 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 161 return Second; 162 end Second; 163 164 ----------- 165 -- Split -- 166 ----------- 167 168 procedure Split 169 (Date : Time; 170 Year : out Year_Number; 171 Month : out Month_Number; 172 Day : out Day_Number; 173 Hour : out Hour_Number; 174 Minute : out Minute_Number; 175 Second : out Second_Number; 176 Sub_Second : out Second_Duration) 177 is 178 Day_Secs : Day_Duration; 179 Secs : Natural; 180 181 begin 182 Split (Date, Year, Month, Day, Day_Secs); 183 184 Secs := (if Day_Secs = 0.0 then 0 else Natural (Day_Secs - 0.5)); 185 Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs)); 186 Hour := Hour_Number (Secs / 3_600); 187 Secs := Secs mod 3_600; 188 Minute := Minute_Number (Secs / 60); 189 Second := Second_Number (Secs mod 60); 190 end Split; 191 192 --------------------- 193 -- Split_At_Locale -- 194 --------------------- 195 196 procedure Split_At_Locale 197 (Date : Time; 198 Year : out Year_Number; 199 Month : out Month_Number; 200 Day : out Day_Number; 201 Hour : out Hour_Number; 202 Minute : out Minute_Number; 203 Second : out Second_Number; 204 Sub_Second : out Second_Duration) 205 is 206 procedure Ada_Calendar_Split 207 (Date : Time; 208 Year : out Year_Number; 209 Month : out Month_Number; 210 Day : out Day_Number; 211 Day_Secs : out Day_Duration; 212 Hour : out Integer; 213 Minute : out Integer; 214 Second : out Integer; 215 Sub_Sec : out Duration; 216 Leap_Sec : out Boolean; 217 Use_TZ : Boolean; 218 Is_Historic : Boolean; 219 Time_Zone : Long_Integer); 220 pragma Import (Ada, Ada_Calendar_Split, "__gnat_split"); 221 222 Ds : Day_Duration; 223 Le : Boolean; 224 225 pragma Unreferenced (Ds, Le); 226 227 begin 228 -- Even though the input time zone is UTC (0), the flag Use_TZ will 229 -- ensure that Split picks up the local time zone. ???But Use_TZ is 230 -- False below, and anyway, Use_TZ has no effect if Time_Zone is 0. 231 232 Ada_Calendar_Split 233 (Date => Date, 234 Year => Year, 235 Month => Month, 236 Day => Day, 237 Day_Secs => Ds, 238 Hour => Hour, 239 Minute => Minute, 240 Second => Second, 241 Sub_Sec => Sub_Second, 242 Leap_Sec => Le, 243 Use_TZ => False, 244 Is_Historic => False, 245 Time_Zone => 0); 246 end Split_At_Locale; 247 248 ---------------- 249 -- Sub_Second -- 250 ---------------- 251 252 function Sub_Second (Date : Time) return Second_Duration is 253 Year : Year_Number; 254 Month : Month_Number; 255 Day : Day_Number; 256 Hour : Hour_Number; 257 Minute : Minute_Number; 258 Second : Second_Number; 259 Sub_Second : Second_Duration; 260 pragma Unreferenced (Year, Month, Day, Hour, Minute, Second); 261 begin 262 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 263 return Sub_Second; 264 end Sub_Second; 265 266 ------------- 267 -- Time_Of -- 268 ------------- 269 270 function Time_Of 271 (Year : Year_Number; 272 Month : Month_Number; 273 Day : Day_Number; 274 Hour : Hour_Number; 275 Minute : Minute_Number; 276 Second : Second_Number; 277 Sub_Second : Second_Duration := 0.0) return Time 278 is 279 Day_Secs : constant Day_Duration := 280 Day_Duration (Hour * 3_600) + 281 Day_Duration (Minute * 60) + 282 Day_Duration (Second) + 283 Sub_Second; 284 begin 285 return Time_Of (Year, Month, Day, Day_Secs); 286 end Time_Of; 287 288 ----------------------- 289 -- Time_Of_At_Locale -- 290 ----------------------- 291 292 function Time_Of_At_Locale 293 (Year : Year_Number; 294 Month : Month_Number; 295 Day : Day_Number; 296 Hour : Hour_Number; 297 Minute : Minute_Number; 298 Second : Second_Number; 299 Sub_Second : Second_Duration := 0.0) return Time 300 is 301 function Ada_Calendar_Time_Of 302 (Year : Year_Number; 303 Month : Month_Number; 304 Day : Day_Number; 305 Day_Secs : Day_Duration; 306 Hour : Integer; 307 Minute : Integer; 308 Second : Integer; 309 Sub_Sec : Duration; 310 Leap_Sec : Boolean; 311 Use_Day_Secs : Boolean; 312 Use_TZ : Boolean; 313 Is_Historic : Boolean; 314 Time_Zone : Long_Integer) return Time; 315 pragma Import (Ada, Ada_Calendar_Time_Of, "__gnat_time_of"); 316 317 begin 318 -- Even though the input time zone is UTC (0), the flag Use_TZ will 319 -- ensure that Split picks up the local time zone. ???But there is no 320 -- call to Split here. 321 322 return 323 Ada_Calendar_Time_Of 324 (Year => Year, 325 Month => Month, 326 Day => Day, 327 Day_Secs => 0.0, 328 Hour => Hour, 329 Minute => Minute, 330 Second => Second, 331 Sub_Sec => Sub_Second, 332 Leap_Sec => False, 333 Use_Day_Secs => False, 334 Use_TZ => False, 335 Is_Historic => False, 336 Time_Zone => 0); 337 end Time_Of_At_Locale; 338 339 ----------------- 340 -- To_Duration -- 341 ----------------- 342 343 function To_Duration (T : not null access timeval) return Duration is 344 345 procedure timeval_to_duration 346 (T : not null access timeval; 347 sec : not null access C.Extensions.long_long; 348 usec : not null access C.long); 349 pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); 350 351 Micro : constant := 10**6; 352 sec : aliased C.Extensions.long_long; 353 usec : aliased C.long; 354 355 begin 356 timeval_to_duration (T, sec'Access, usec'Access); 357 pragma Annotate (CodePeer, Modified, sec); 358 pragma Annotate (CodePeer, Modified, usec); 359 360 return Duration (sec) + Duration (usec) / Micro; 361 end To_Duration; 362 363 ---------------- 364 -- To_Timeval -- 365 ---------------- 366 367 function To_Timeval (D : Duration) return timeval is 368 369 procedure duration_to_timeval 370 (Sec : C.Extensions.long_long; 371 Usec : C.long; 372 T : not null access timeval); 373 pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval"); 374 375 Micro : constant := 10**6; 376 Result : aliased timeval; 377 sec : C.Extensions.long_long; 378 usec : C.long; 379 380 begin 381 if D = 0.0 then 382 sec := 0; 383 usec := 0; 384 else 385 sec := C.Extensions.long_long (D - 0.5); 386 usec := C.long ((D - Duration (sec)) * Micro - 0.5); 387 end if; 388 389 duration_to_timeval (sec, usec, Result'Access); 390 391 return Result; 392 end To_Timeval; 393 394 ------------------ 395 -- Week_In_Year -- 396 ------------------ 397 398 function Week_In_Year (Date : Time) return Week_In_Year_Number is 399 Year : Year_Number; 400 Week : Week_In_Year_Number; 401 pragma Unreferenced (Year); 402 begin 403 Year_Week_In_Year (Date, Year, Week); 404 return Week; 405 end Week_In_Year; 406 407 ----------------------- 408 -- Year_Week_In_Year -- 409 ----------------------- 410 411 procedure Year_Week_In_Year 412 (Date : Time; 413 Year : out Year_Number; 414 Week : out Week_In_Year_Number) 415 is 416 Month : Month_Number; 417 Day : Day_Number; 418 Hour : Hour_Number; 419 Minute : Minute_Number; 420 Second : Second_Number; 421 Sub_Second : Second_Duration; 422 Jan_1 : Day_Name; 423 Shift : Week_In_Year_Number; 424 Start_Week : Week_In_Year_Number; 425 426 pragma Unreferenced (Hour, Minute, Second, Sub_Second); 427 428 function Is_Leap (Year : Year_Number) return Boolean; 429 -- Return True if Year denotes a leap year. Leap centennial years are 430 -- properly handled. 431 432 function Jan_1_Day_Of_Week 433 (Jan_1 : Day_Name; 434 Year : Year_Number; 435 Last_Year : Boolean := False; 436 Next_Year : Boolean := False) return Day_Name; 437 -- Given the weekday of January 1 in Year, determine the weekday on 438 -- which January 1 fell last year or will fall next year as set by 439 -- the two flags. This routine does not call Time_Of or Split. 440 441 function Last_Year_Has_53_Weeks 442 (Jan_1 : Day_Name; 443 Year : Year_Number) return Boolean; 444 -- Given the weekday of January 1 in Year, determine whether last year 445 -- has 53 weeks. A False value implies that the year has 52 weeks. 446 447 ------------- 448 -- Is_Leap -- 449 ------------- 450 451 function Is_Leap (Year : Year_Number) return Boolean is 452 begin 453 if Year mod 400 = 0 then 454 return True; 455 elsif Year mod 100 = 0 then 456 return False; 457 else 458 return Year mod 4 = 0; 459 end if; 460 end Is_Leap; 461 462 ----------------------- 463 -- Jan_1_Day_Of_Week -- 464 ----------------------- 465 466 function Jan_1_Day_Of_Week 467 (Jan_1 : Day_Name; 468 Year : Year_Number; 469 Last_Year : Boolean := False; 470 Next_Year : Boolean := False) return Day_Name 471 is 472 Shift : Integer := 0; 473 474 begin 475 if Last_Year then 476 Shift := (if Is_Leap (Year - 1) then -2 else -1); 477 elsif Next_Year then 478 Shift := (if Is_Leap (Year) then 2 else 1); 479 end if; 480 481 return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7); 482 end Jan_1_Day_Of_Week; 483 484 ---------------------------- 485 -- Last_Year_Has_53_Weeks -- 486 ---------------------------- 487 488 function Last_Year_Has_53_Weeks 489 (Jan_1 : Day_Name; 490 Year : Year_Number) return Boolean 491 is 492 Last_Jan_1 : constant Day_Name := 493 Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True); 494 495 begin 496 -- These two cases are illustrated in the table below 497 498 return 499 Last_Jan_1 = Thursday 500 or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1)); 501 end Last_Year_Has_53_Weeks; 502 503 -- Start of processing for Week_In_Year 504 505 begin 506 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 507 508 -- According to ISO 8601, the first week of year Y is the week that 509 -- contains the first Thursday in year Y. The following table contains 510 -- all possible combinations of years and weekdays along with examples. 511 512 -- +-------+------+-------+---------+ 513 -- | Jan 1 | Leap | Weeks | Example | 514 -- +-------+------+-------+---------+ 515 -- | Mon | No | 52 | 2007 | 516 -- +-------+------+-------+---------+ 517 -- | Mon | Yes | 52 | 1996 | 518 -- +-------+------+-------+---------+ 519 -- | Tue | No | 52 | 2002 | 520 -- +-------+------+-------+---------+ 521 -- | Tue | Yes | 52 | 1980 | 522 -- +-------+------+-------+---------+ 523 -- | Wed | No | 52 | 2003 | 524 -- +-------+------#########---------+ 525 -- | Wed | Yes # 53 # 1992 | 526 -- +-------+------#-------#---------+ 527 -- | Thu | No # 53 # 1998 | 528 -- +-------+------#-------#---------+ 529 -- | Thu | Yes # 53 # 2004 | 530 -- +-------+------#########---------+ 531 -- | Fri | No | 52 | 1999 | 532 -- +-------+------+-------+---------+ 533 -- | Fri | Yes | 52 | 1988 | 534 -- +-------+------+-------+---------+ 535 -- | Sat | No | 52 | 1994 | 536 -- +-------+------+-------+---------+ 537 -- | Sat | Yes | 52 | 1972 | 538 -- +-------+------+-------+---------+ 539 -- | Sun | No | 52 | 1995 | 540 -- +-------+------+-------+---------+ 541 -- | Sun | Yes | 52 | 1956 | 542 -- +-------+------+-------+---------+ 543 544 -- A small optimization, the input date is January 1. Note that this 545 -- is a key day since it determines the number of weeks and is used 546 -- when special casing the first week of January and the last week of 547 -- December. 548 549 Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1 550 then Date 551 else (Time_Of (Year, 1, 1, 0.0))); 552 553 -- Special cases for January 554 555 if Month = 1 then 556 557 -- Special case 1: January 1, 2 and 3. These three days may belong 558 -- to last year's last week which can be week number 52 or 53. 559 560 -- +-----+-----+-----+=====+-----+-----+-----+ 561 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | 562 -- +-----+-----+-----+-----+-----+-----+-----+ 563 -- | 26 | 27 | 28 # 29 # 30 | 31 | 1 | 564 -- +-----+-----+-----+-----+-----+-----+-----+ 565 -- | 27 | 28 | 29 # 30 # 31 | 1 | 2 | 566 -- +-----+-----+-----+-----+-----+-----+-----+ 567 -- | 28 | 29 | 30 # 31 # 1 | 2 | 3 | 568 -- +-----+-----+-----+=====+-----+-----+-----+ 569 570 if (Day = 1 and then Jan_1 in Friday .. Sunday) 571 or else 572 (Day = 2 and then Jan_1 in Friday .. Saturday) 573 or else 574 (Day = 3 and then Jan_1 = Friday) 575 then 576 Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52); 577 578 -- January 1, 2 and 3 belong to the previous year 579 580 Year := Year - 1; 581 return; 582 583 -- Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week 584 585 -- +-----+-----+-----+=====+-----+-----+-----+ 586 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | 587 -- +-----+-----+-----+-----+-----+-----+-----+ 588 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | 589 -- +-----+-----+-----+-----+-----+-----+-----+ 590 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | 591 -- +-----+-----+-----+-----+-----+-----+-----+ 592 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | 593 -- +-----+-----+-----+-----+-----+-----+-----+ 594 -- | 1 | 2 | 3 # 4 # 5 | 6 | 7 | 595 -- +-----+-----+-----+=====+-----+-----+-----+ 596 597 elsif (Day <= 4 and then Jan_1 in Monday .. Thursday) 598 or else 599 (Day = 5 and then Jan_1 in Monday .. Wednesday) 600 or else 601 (Day = 6 and then Jan_1 in Monday .. Tuesday) 602 or else 603 (Day = 7 and then Jan_1 = Monday) 604 then 605 Week := 1; 606 return; 607 end if; 608 609 -- Month other than 1 610 611 -- Special case 3: December 29, 30 and 31. These days may belong to 612 -- next year's first week. 613 614 -- +-----+-----+-----+=====+-----+-----+-----+ 615 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | 616 -- +-----+-----+-----+-----+-----+-----+-----+ 617 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | 618 -- +-----+-----+-----+-----+-----+-----+-----+ 619 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | 620 -- +-----+-----+-----+-----+-----+-----+-----+ 621 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | 622 -- +-----+-----+-----+=====+-----+-----+-----+ 623 624 elsif Month = 12 and then Day > 28 then 625 declare 626 Next_Jan_1 : constant Day_Name := 627 Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True); 628 begin 629 if (Day = 29 and then Next_Jan_1 = Thursday) 630 or else 631 (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday) 632 or else 633 (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday) 634 then 635 Year := Year + 1; 636 Week := 1; 637 return; 638 end if; 639 end; 640 end if; 641 642 -- Determine the week from which to start counting. If January 1 does 643 -- not belong to the first week of the input year, then the next week 644 -- is the first week. 645 646 Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2); 647 648 -- At this point all special combinations have been accounted for and 649 -- the proper start week has been found. Since January 1 may not fall 650 -- on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an 651 -- origin which falls on Monday. 652 653 Shift := 7 - Day_Name'Pos (Jan_1); 654 Week := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7; 655 end Year_Week_In_Year; 656 657end GNAT.Calendar; 658