1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- G N A T . C A L E N D A R --
9 -- Copyright (C) 1999-2012, AdaCore --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 package body GNAT
.Calendar
is
41 function Day_In_Year
(Date
: Time
) return Day_In_Year_Number
is
45 Day_Secs
: Day_Duration
;
46 pragma Unreferenced
(Day_Secs
);
48 Split
(Date
, Year
, Month
, Day
, Day_Secs
);
49 return Julian_Day
(Year
, Month
, Day
) - Julian_Day
(Year
, 1, 1) + 1;
56 function Day_Of_Week
(Date
: Time
) return Day_Name
is
60 Day_Secs
: Day_Duration
;
61 pragma Unreferenced
(Day_Secs
);
63 Split
(Date
, Year
, Month
, Day
, Day_Secs
);
64 return Day_Name
'Val ((Julian_Day
(Year
, Month
, Day
)) mod 7);
71 function Hour
(Date
: Time
) return Hour_Number
is
76 Minute
: Minute_Number
;
77 Second
: Second_Number
;
78 Sub_Second
: Second_Duration
;
79 pragma Unreferenced
(Year
, Month
, Day
, Minute
, Second
, Sub_Second
);
81 Split
(Date
, Year
, Month
, Day
, Hour
, Minute
, Second
, Sub_Second
);
89 -- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this
90 -- implementation is not expensive.
95 Day
: Day_Number
) return Integer
97 Internal_Year
: Integer;
98 Internal_Month
: Integer;
99 Internal_Day
: Integer;
100 Julian_Date
: Integer;
105 Internal_Year
:= Integer (Year
);
106 Internal_Month
:= Integer (Month
);
107 Internal_Day
:= Integer (Day
);
109 if Internal_Month
> 2 then
110 Internal_Month
:= Internal_Month
- 3;
112 Internal_Month
:= Internal_Month
+ 9;
113 Internal_Year
:= Internal_Year
- 1;
116 C
:= Internal_Year
/ 100;
117 Ya
:= Internal_Year
- (100 * C
);
119 Julian_Date
:= (146_097
* C
) / 4 +
121 (153 * Internal_Month
+ 2) / 5 +
122 Internal_Day
+ 1_721_119
;
131 function Minute
(Date
: Time
) return Minute_Number
is
133 Month
: Month_Number
;
136 Minute
: Minute_Number
;
137 Second
: Second_Number
;
138 Sub_Second
: Second_Duration
;
139 pragma Unreferenced
(Year
, Month
, Day
, Hour
, Second
, Sub_Second
);
141 Split
(Date
, Year
, Month
, Day
, Hour
, Minute
, Second
, Sub_Second
);
149 function Second
(Date
: Time
) return Second_Number
is
151 Month
: Month_Number
;
154 Minute
: Minute_Number
;
155 Second
: Second_Number
;
156 Sub_Second
: Second_Duration
;
157 pragma Unreferenced
(Year
, Month
, Day
, Hour
, Minute
, Sub_Second
);
159 Split
(Date
, Year
, Month
, Day
, Hour
, Minute
, Second
, Sub_Second
);
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
)
177 Day_Secs
: Day_Duration
;
181 Split
(Date
, Year
, Month
, Day
, Day_Secs
);
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);
191 ---------------------
192 -- Split_At_Locale --
193 ---------------------
195 procedure Split_At_Locale
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
)
205 procedure Ada_Calendar_Split
207 Year
: out Year_Number
;
208 Month
: out Month_Number
;
209 Day
: out Day_Number
;
210 Day_Secs
: out Day_Duration
;
212 Minute
: out Integer;
213 Second
: out Integer;
214 Sub_Sec
: out Duration;
215 Leap_Sec
: out Boolean;
217 Is_Historic
: Boolean;
218 Time_Zone
: Long_Integer);
219 pragma Import
(Ada
, Ada_Calendar_Split
, "__gnat_split");
224 pragma Unreferenced
(Ds
, Le
);
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.
239 Sub_Sec
=> Sub_Second
,
242 Is_Historic
=> False,
250 function Sub_Second
(Date
: Time
) return Second_Duration
is
252 Month
: Month_Number
;
255 Minute
: Minute_Number
;
256 Second
: Second_Number
;
257 Sub_Second
: Second_Duration
;
258 pragma Unreferenced
(Year
, Month
, Day
, Hour
, Minute
, Second
);
260 Split
(Date
, Year
, Month
, Day
, Hour
, Minute
, Second
, Sub_Second
);
270 Month
: Month_Number
;
273 Minute
: Minute_Number
;
274 Second
: Second_Number
;
275 Sub_Second
: Second_Duration
:= 0.0) return Time
277 Day_Secs
: constant Day_Duration
:=
278 Day_Duration
(Hour
* 3_600
) +
279 Day_Duration
(Minute
* 60) +
280 Day_Duration
(Second
) +
283 return Time_Of
(Year
, Month
, Day
, Day_Secs
);
286 -----------------------
287 -- Time_Of_At_Locale --
288 -----------------------
290 function Time_Of_At_Locale
292 Month
: Month_Number
;
295 Minute
: Minute_Number
;
296 Second
: Second_Number
;
297 Sub_Second
: Second_Duration
:= 0.0) return Time
299 function Ada_Calendar_Time_Of
301 Month
: Month_Number
;
303 Day_Secs
: Day_Duration
;
309 Use_Day_Secs
: Boolean;
311 Is_Historic
: Boolean;
312 Time_Zone
: Long_Integer) return Time
;
313 pragma Import
(Ada
, Ada_Calendar_Time_Of
, "__gnat_time_of");
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.
328 Sub_Sec
=> Sub_Second
,
330 Use_Day_Secs
=> False,
332 Is_Historic
=> False,
334 end Time_Of_At_Locale
;
340 function To_Duration
(T
: not null access timeval
) return Duration is
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");
348 Micro
: constant := 10**6;
349 sec
: aliased C
.long
;
350 usec
: aliased C
.long
;
353 timeval_to_duration
(T
, sec
'Access, usec
'Access);
354 return Duration (sec
) + Duration (usec
) / Micro
;
361 function To_Timeval
(D
: Duration) return timeval
is
363 procedure duration_to_timeval
366 T
: not null access timeval
);
367 pragma Import
(C
, duration_to_timeval
, "__gnat_duration_to_timeval");
369 Micro
: constant := 10**6;
370 Result
: aliased timeval
;
379 sec
:= C
.long
(D
- 0.5);
380 usec
:= C
.long
((D
- Duration (sec
)) * Micro
- 0.5);
383 duration_to_timeval
(sec
, usec
, Result
'Access);
392 function Week_In_Year
(Date
: Time
) return Week_In_Year_Number
is
394 Week
: Week_In_Year_Number
;
395 pragma Unreferenced
(Year
);
397 Year_Week_In_Year
(Date
, Year
, Week
);
401 -----------------------
402 -- Year_Week_In_Year --
403 -----------------------
405 procedure Year_Week_In_Year
407 Year
: out Year_Number
;
408 Week
: out Week_In_Year_Number
)
410 Month
: Month_Number
;
413 Minute
: Minute_Number
;
414 Second
: Second_Number
;
415 Sub_Second
: Second_Duration
;
417 Shift
: Week_In_Year_Number
;
418 Start_Week
: Week_In_Year_Number
;
420 pragma Unreferenced
(Hour
, Minute
, Second
, Sub_Second
);
422 function Is_Leap
(Year
: Year_Number
) return Boolean;
423 -- Return True if Year denotes a leap year. Leap centennial years are
426 function Jan_1_Day_Of_Week
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.
435 function Last_Year_Has_53_Weeks
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.
445 function Is_Leap
(Year
: Year_Number
) return Boolean is
447 if Year
mod 400 = 0 then
449 elsif Year
mod 100 = 0 then
452 return Year
mod 4 = 0;
456 -----------------------
457 -- Jan_1_Day_Of_Week --
458 -----------------------
460 function Jan_1_Day_Of_Week
463 Last_Year
: Boolean := False;
464 Next_Year
: Boolean := False) return Day_Name
466 Shift
: Integer := 0;
470 Shift
:= (if Is_Leap
(Year
- 1) then -2 else -1);
472 Shift
:= (if Is_Leap
(Year
) then 2 else 1);
475 return Day_Name
'Val ((Day_Name
'Pos (Jan_1
) + Shift
) mod 7);
476 end Jan_1_Day_Of_Week
;
478 ----------------------------
479 -- Last_Year_Has_53_Weeks --
480 ----------------------------
482 function Last_Year_Has_53_Weeks
484 Year
: Year_Number
) return Boolean
486 Last_Jan_1
: constant Day_Name
:=
487 Jan_1_Day_Of_Week
(Jan_1
, Year
, Last_Year
=> True);
490 -- These two cases are illustrated in the table below
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
;
497 -- Start of processing for Week_In_Year
500 Split
(Date
, Year
, Month
, Day
, Hour
, Minute
, Second
, Sub_Second
);
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.
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 -- +-------+------+-------+---------+
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
543 Jan_1
:= Day_Of_Week
(if Day
= 1 and then Month
= 1
545 else (Time_Of
(Year
, 1, 1, 0.0)));
547 -- Special cases for January
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.
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 -- +-----+-----+-----+=====+-----+-----+-----+
564 if (Day
= 1 and then Jan_1
in Friday
.. Sunday
)
566 (Day
= 2 and then Jan_1
in Friday
.. Saturday
)
568 (Day
= 3 and then Jan_1
= Friday
)
570 Week
:= (if Last_Year_Has_53_Weeks
(Jan_1
, Year
) then 53 else 52);
572 -- January 1, 2 and 3 belong to the previous year
577 -- Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week
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 -- +-----+-----+-----+=====+-----+-----+-----+
591 elsif (Day
<= 4 and then Jan_1
in Monday
.. Thursday
)
593 (Day
= 5 and then Jan_1
in Monday
.. Wednesday
)
595 (Day
= 6 and then Jan_1
in Monday
.. Tuesday
)
597 (Day
= 7 and then Jan_1
= Monday
)
603 -- Month other than 1
605 -- Special case 3: December 29, 30 and 31. These days may belong to
606 -- next year's first week.
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 -- +-----+-----+-----+=====+-----+-----+-----+
618 elsif Month
= 12 and then Day
> 28 then
620 Next_Jan_1
: constant Day_Name
:=
621 Jan_1_Day_Of_Week
(Jan_1
, Year
, Next_Year
=> True);
623 if (Day
= 29 and then Next_Jan_1
= Thursday
)
625 (Day
= 30 and then Next_Jan_1
in Wednesday
.. Thursday
)
627 (Day
= 31 and then Next_Jan_1
in Tuesday
.. Thursday
)
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.
640 Start_Week
:= (if Jan_1
in Friday
.. Sunday
then 1 else 2);
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.
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
;