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