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-2018, 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. 230 231 Ada_Calendar_Split 232 (Date => Date, 233 Year => Year, 234 Month => Month, 235 Day => Day, 236 Day_Secs => Ds, 237 Hour => Hour, 238 Minute => Minute, 239 Second => Second, 240 Sub_Sec => Sub_Second, 241 Leap_Sec => Le, 242 Use_TZ => False, 243 Is_Historic => False, 244 Time_Zone => 0); 245 end Split_At_Locale; 246 247 ---------------- 248 -- Sub_Second -- 249 ---------------- 250 251 function Sub_Second (Date : Time) return Second_Duration is 252 Year : Year_Number; 253 Month : Month_Number; 254 Day : Day_Number; 255 Hour : Hour_Number; 256 Minute : Minute_Number; 257 Second : Second_Number; 258 Sub_Second : Second_Duration; 259 pragma Unreferenced (Year, Month, Day, Hour, Minute, Second); 260 begin 261 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 262 return Sub_Second; 263 end Sub_Second; 264 265 ------------- 266 -- Time_Of -- 267 ------------- 268 269 function Time_Of 270 (Year : Year_Number; 271 Month : Month_Number; 272 Day : Day_Number; 273 Hour : Hour_Number; 274 Minute : Minute_Number; 275 Second : Second_Number; 276 Sub_Second : Second_Duration := 0.0) return Time 277 is 278 Day_Secs : constant Day_Duration := 279 Day_Duration (Hour * 3_600) + 280 Day_Duration (Minute * 60) + 281 Day_Duration (Second) + 282 Sub_Second; 283 begin 284 return Time_Of (Year, Month, Day, Day_Secs); 285 end Time_Of; 286 287 ----------------------- 288 -- Time_Of_At_Locale -- 289 ----------------------- 290 291 function Time_Of_At_Locale 292 (Year : Year_Number; 293 Month : Month_Number; 294 Day : Day_Number; 295 Hour : Hour_Number; 296 Minute : Minute_Number; 297 Second : Second_Number; 298 Sub_Second : Second_Duration := 0.0) return Time 299 is 300 function Ada_Calendar_Time_Of 301 (Year : Year_Number; 302 Month : Month_Number; 303 Day : Day_Number; 304 Day_Secs : Day_Duration; 305 Hour : Integer; 306 Minute : Integer; 307 Second : Integer; 308 Sub_Sec : Duration; 309 Leap_Sec : Boolean; 310 Use_Day_Secs : Boolean; 311 Use_TZ : Boolean; 312 Is_Historic : Boolean; 313 Time_Zone : Long_Integer) return Time; 314 pragma Import (Ada, Ada_Calendar_Time_Of, "__gnat_time_of"); 315 316 begin 317 -- Even though the input time zone is UTC (0), the flag Use_TZ will 318 -- ensure that Split picks up the local time zone. 319 320 return 321 Ada_Calendar_Time_Of 322 (Year => Year, 323 Month => Month, 324 Day => Day, 325 Day_Secs => 0.0, 326 Hour => Hour, 327 Minute => Minute, 328 Second => Second, 329 Sub_Sec => Sub_Second, 330 Leap_Sec => False, 331 Use_Day_Secs => False, 332 Use_TZ => False, 333 Is_Historic => False, 334 Time_Zone => 0); 335 end Time_Of_At_Locale; 336 337 ----------------- 338 -- To_Duration -- 339 ----------------- 340 341 function To_Duration (T : not null access timeval) return Duration is 342 343 procedure timeval_to_duration 344 (T : not null access timeval; 345 sec : not null access C.Extensions.long_long; 346 usec : not null access C.long); 347 pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); 348 349 Micro : constant := 10**6; 350 sec : aliased C.Extensions.long_long; 351 usec : aliased C.long; 352 353 begin 354 timeval_to_duration (T, sec'Access, usec'Access); 355 return Duration (sec) + Duration (usec) / Micro; 356 end To_Duration; 357 358 ---------------- 359 -- To_Timeval -- 360 ---------------- 361 362 function To_Timeval (D : Duration) return timeval is 363 364 procedure duration_to_timeval 365 (Sec : C.Extensions.long_long; 366 Usec : C.long; 367 T : not null access timeval); 368 pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval"); 369 370 Micro : constant := 10**6; 371 Result : aliased timeval; 372 sec : C.Extensions.long_long; 373 usec : C.long; 374 375 begin 376 if D = 0.0 then 377 sec := 0; 378 usec := 0; 379 else 380 sec := C.Extensions.long_long (D - 0.5); 381 usec := C.long ((D - Duration (sec)) * Micro - 0.5); 382 end if; 383 384 duration_to_timeval (sec, usec, Result'Access); 385 386 return Result; 387 end To_Timeval; 388 389 ------------------ 390 -- Week_In_Year -- 391 ------------------ 392 393 function Week_In_Year (Date : Time) return Week_In_Year_Number is 394 Year : Year_Number; 395 Week : Week_In_Year_Number; 396 pragma Unreferenced (Year); 397 begin 398 Year_Week_In_Year (Date, Year, Week); 399 return Week; 400 end Week_In_Year; 401 402 ----------------------- 403 -- Year_Week_In_Year -- 404 ----------------------- 405 406 procedure Year_Week_In_Year 407 (Date : Time; 408 Year : out Year_Number; 409 Week : out Week_In_Year_Number) 410 is 411 Month : Month_Number; 412 Day : Day_Number; 413 Hour : Hour_Number; 414 Minute : Minute_Number; 415 Second : Second_Number; 416 Sub_Second : Second_Duration; 417 Jan_1 : Day_Name; 418 Shift : Week_In_Year_Number; 419 Start_Week : Week_In_Year_Number; 420 421 pragma Unreferenced (Hour, Minute, Second, Sub_Second); 422 423 function Is_Leap (Year : Year_Number) return Boolean; 424 -- Return True if Year denotes a leap year. Leap centennial years are 425 -- properly handled. 426 427 function Jan_1_Day_Of_Week 428 (Jan_1 : Day_Name; 429 Year : Year_Number; 430 Last_Year : Boolean := False; 431 Next_Year : Boolean := False) return Day_Name; 432 -- Given the weekday of January 1 in Year, determine the weekday on 433 -- which January 1 fell last year or will fall next year as set by 434 -- the two flags. This routine does not call Time_Of or Split. 435 436 function Last_Year_Has_53_Weeks 437 (Jan_1 : Day_Name; 438 Year : Year_Number) return Boolean; 439 -- Given the weekday of January 1 in Year, determine whether last year 440 -- has 53 weeks. A False value implies that the year has 52 weeks. 441 442 ------------- 443 -- Is_Leap -- 444 ------------- 445 446 function Is_Leap (Year : Year_Number) return Boolean is 447 begin 448 if Year mod 400 = 0 then 449 return True; 450 elsif Year mod 100 = 0 then 451 return False; 452 else 453 return Year mod 4 = 0; 454 end if; 455 end Is_Leap; 456 457 ----------------------- 458 -- Jan_1_Day_Of_Week -- 459 ----------------------- 460 461 function Jan_1_Day_Of_Week 462 (Jan_1 : Day_Name; 463 Year : Year_Number; 464 Last_Year : Boolean := False; 465 Next_Year : Boolean := False) return Day_Name 466 is 467 Shift : Integer := 0; 468 469 begin 470 if Last_Year then 471 Shift := (if Is_Leap (Year - 1) then -2 else -1); 472 elsif Next_Year then 473 Shift := (if Is_Leap (Year) then 2 else 1); 474 end if; 475 476 return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7); 477 end Jan_1_Day_Of_Week; 478 479 ---------------------------- 480 -- Last_Year_Has_53_Weeks -- 481 ---------------------------- 482 483 function Last_Year_Has_53_Weeks 484 (Jan_1 : Day_Name; 485 Year : Year_Number) return Boolean 486 is 487 Last_Jan_1 : constant Day_Name := 488 Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True); 489 490 begin 491 -- These two cases are illustrated in the table below 492 493 return 494 Last_Jan_1 = Thursday 495 or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1)); 496 end Last_Year_Has_53_Weeks; 497 498 -- Start of processing for Week_In_Year 499 500 begin 501 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); 502 503 -- According to ISO 8601, the first week of year Y is the week that 504 -- contains the first Thursday in year Y. The following table contains 505 -- all possible combinations of years and weekdays along with examples. 506 507 -- +-------+------+-------+---------+ 508 -- | Jan 1 | Leap | Weeks | Example | 509 -- +-------+------+-------+---------+ 510 -- | Mon | No | 52 | 2007 | 511 -- +-------+------+-------+---------+ 512 -- | Mon | Yes | 52 | 1996 | 513 -- +-------+------+-------+---------+ 514 -- | Tue | No | 52 | 2002 | 515 -- +-------+------+-------+---------+ 516 -- | Tue | Yes | 52 | 1980 | 517 -- +-------+------+-------+---------+ 518 -- | Wed | No | 52 | 2003 | 519 -- +-------+------#########---------+ 520 -- | Wed | Yes # 53 # 1992 | 521 -- +-------+------#-------#---------+ 522 -- | Thu | No # 53 # 1998 | 523 -- +-------+------#-------#---------+ 524 -- | Thu | Yes # 53 # 2004 | 525 -- +-------+------#########---------+ 526 -- | Fri | No | 52 | 1999 | 527 -- +-------+------+-------+---------+ 528 -- | Fri | Yes | 52 | 1988 | 529 -- +-------+------+-------+---------+ 530 -- | Sat | No | 52 | 1994 | 531 -- +-------+------+-------+---------+ 532 -- | Sat | Yes | 52 | 1972 | 533 -- +-------+------+-------+---------+ 534 -- | Sun | No | 52 | 1995 | 535 -- +-------+------+-------+---------+ 536 -- | Sun | Yes | 52 | 1956 | 537 -- +-------+------+-------+---------+ 538 539 -- A small optimization, the input date is January 1. Note that this 540 -- is a key day since it determines the number of weeks and is used 541 -- when special casing the first week of January and the last week of 542 -- December. 543 544 Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1 545 then Date 546 else (Time_Of (Year, 1, 1, 0.0))); 547 548 -- Special cases for January 549 550 if Month = 1 then 551 552 -- Special case 1: January 1, 2 and 3. These three days may belong 553 -- to last year's last week which can be week number 52 or 53. 554 555 -- +-----+-----+-----+=====+-----+-----+-----+ 556 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | 557 -- +-----+-----+-----+-----+-----+-----+-----+ 558 -- | 26 | 27 | 28 # 29 # 30 | 31 | 1 | 559 -- +-----+-----+-----+-----+-----+-----+-----+ 560 -- | 27 | 28 | 29 # 30 # 31 | 1 | 2 | 561 -- +-----+-----+-----+-----+-----+-----+-----+ 562 -- | 28 | 29 | 30 # 31 # 1 | 2 | 3 | 563 -- +-----+-----+-----+=====+-----+-----+-----+ 564 565 if (Day = 1 and then Jan_1 in Friday .. Sunday) 566 or else 567 (Day = 2 and then Jan_1 in Friday .. Saturday) 568 or else 569 (Day = 3 and then Jan_1 = Friday) 570 then 571 Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52); 572 573 -- January 1, 2 and 3 belong to the previous year 574 575 Year := Year - 1; 576 return; 577 578 -- Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week 579 580 -- +-----+-----+-----+=====+-----+-----+-----+ 581 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | 582 -- +-----+-----+-----+-----+-----+-----+-----+ 583 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | 584 -- +-----+-----+-----+-----+-----+-----+-----+ 585 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | 586 -- +-----+-----+-----+-----+-----+-----+-----+ 587 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | 588 -- +-----+-----+-----+-----+-----+-----+-----+ 589 -- | 1 | 2 | 3 # 4 # 5 | 6 | 7 | 590 -- +-----+-----+-----+=====+-----+-----+-----+ 591 592 elsif (Day <= 4 and then Jan_1 in Monday .. Thursday) 593 or else 594 (Day = 5 and then Jan_1 in Monday .. Wednesday) 595 or else 596 (Day = 6 and then Jan_1 in Monday .. Tuesday) 597 or else 598 (Day = 7 and then Jan_1 = Monday) 599 then 600 Week := 1; 601 return; 602 end if; 603 604 -- Month other than 1 605 606 -- Special case 3: December 29, 30 and 31. These days may belong to 607 -- next year's first week. 608 609 -- +-----+-----+-----+=====+-----+-----+-----+ 610 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | 611 -- +-----+-----+-----+-----+-----+-----+-----+ 612 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | 613 -- +-----+-----+-----+-----+-----+-----+-----+ 614 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | 615 -- +-----+-----+-----+-----+-----+-----+-----+ 616 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | 617 -- +-----+-----+-----+=====+-----+-----+-----+ 618 619 elsif Month = 12 and then Day > 28 then 620 declare 621 Next_Jan_1 : constant Day_Name := 622 Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True); 623 begin 624 if (Day = 29 and then Next_Jan_1 = Thursday) 625 or else 626 (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday) 627 or else 628 (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday) 629 then 630 Year := Year + 1; 631 Week := 1; 632 return; 633 end if; 634 end; 635 end if; 636 637 -- Determine the week from which to start counting. If January 1 does 638 -- not belong to the first week of the input year, then the next week 639 -- is the first week. 640 641 Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2); 642 643 -- At this point all special combinations have been accounted for and 644 -- the proper start week has been found. Since January 1 may not fall 645 -- on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an 646 -- origin which falls on Monday. 647 648 Shift := 7 - Day_Name'Pos (Jan_1); 649 Week := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7; 650 end Year_Week_In_Year; 651 652end GNAT.Calendar; 653