1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- G N A T . C A L E N D A R --
9 -- Copyright (C) 1999-2010, 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);
195 function Sub_Second (Date : Time) return Second_Duration is
197 Month : Month_Number;
200 Minute : Minute_Number;
201 Second : Second_Number;
202 Sub_Second : Second_Duration;
203 pragma Unreferenced (Year, Month, Day, Hour, Minute, Second);
205 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
215 Month : Month_Number;
218 Minute : Minute_Number;
219 Second : Second_Number;
220 Sub_Second : Second_Duration := 0.0) return Time
223 Day_Secs : constant Day_Duration :=
224 Day_Duration (Hour * 3_600) +
225 Day_Duration (Minute * 60) +
226 Day_Duration (Second) +
229 return Time_Of (Year, Month, Day, Day_Secs);
236 function To_Duration (T : not null access timeval) return Duration is
238 procedure timeval_to_duration
239 (T : not null access timeval;
240 sec : not null access C.long;
241 usec : not null access C.long);
242 pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
244 Micro : constant := 10**6;
245 sec : aliased C.long;
246 usec : aliased C.long;
249 timeval_to_duration (T, sec'Access, usec'Access);
250 return Duration (sec) + Duration (usec) / Micro;
257 function To_Timeval (D : Duration) return timeval is
259 procedure duration_to_timeval
262 T : not null access timeval);
263 pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
265 Micro : constant := 10**6;
266 Result : aliased timeval;
275 sec := C.long (D - 0.5);
276 usec := C.long ((D - Duration (sec)) * Micro - 0.5);
279 duration_to_timeval (sec, usec, Result'Access);
288 function Week_In_Year (Date : Time) return Week_In_Year_Number is
290 Week : Week_In_Year_Number;
291 pragma Unreferenced (Year);
293 Year_Week_In_Year (Date, Year, Week);
297 -----------------------
298 -- Year_Week_In_Year --
299 -----------------------
301 procedure Year_Week_In_Year
303 Year : out Year_Number;
304 Week : out Week_In_Year_Number)
306 Month : Month_Number;
309 Minute : Minute_Number;
310 Second : Second_Number;
311 Sub_Second : Second_Duration;
313 Shift : Week_In_Year_Number;
314 Start_Week : Week_In_Year_Number;
316 pragma Unreferenced (Hour, Minute, Second, Sub_Second);
318 function Is_Leap (Year : Year_Number) return Boolean;
319 -- Return True if Year denotes a leap year. Leap centennial years are
322 function Jan_1_Day_Of_Week
325 Last_Year : Boolean := False;
326 Next_Year : Boolean := False) return Day_Name;
327 -- Given the weekday of January 1 in Year, determine the weekday on
328 -- which January 1 fell last year or will fall next year as set by
329 -- the two flags. This routine does not call Time_Of or Split.
331 function Last_Year_Has_53_Weeks
333 Year : Year_Number) return Boolean;
334 -- Given the weekday of January 1 in Year, determine whether last year
335 -- has 53 weeks. A False value implies that the year has 52 weeks.
341 function Is_Leap (Year : Year_Number) return Boolean is
343 if Year mod 400 = 0 then
345 elsif Year mod 100 = 0 then
348 return Year mod 4 = 0;
352 -----------------------
353 -- Jan_1_Day_Of_Week --
354 -----------------------
356 function Jan_1_Day_Of_Week
359 Last_Year : Boolean := False;
360 Next_Year : Boolean := False) return Day_Name
362 Shift : Integer := 0;
366 Shift := (if Is_Leap (Year - 1) then -2 else -1);
368 Shift := (if Is_Leap (Year) then 2 else 1);
371 return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7);
372 end Jan_1_Day_Of_Week;
374 ----------------------------
375 -- Last_Year_Has_53_Weeks --
376 ----------------------------
378 function Last_Year_Has_53_Weeks
380 Year : Year_Number) return Boolean
382 Last_Jan_1 : constant Day_Name :=
383 Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True);
386 -- These two cases are illustrated in the table below
389 Last_Jan_1 = Thursday
390 or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1));
391 end Last_Year_Has_53_Weeks;
393 -- Start of processing for Week_In_Year
396 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
398 -- According to ISO 8601, the first week of year Y is the week that
399 -- contains the first Thursday in year Y. The following table contains
400 -- all possible combinations of years and weekdays along with examples.
402 -- +-------+------+-------+---------+
403 -- | Jan 1 | Leap | Weeks | Example |
404 -- +-------+------+-------+---------+
405 -- | Mon | No | 52 | 2007 |
406 -- +-------+------+-------+---------+
407 -- | Mon | Yes | 52 | 1996 |
408 -- +-------+------+-------+---------+
409 -- | Tue | No | 52 | 2002 |
410 -- +-------+------+-------+---------+
411 -- | Tue | Yes | 52 | 1980 |
412 -- +-------+------+-------+---------+
413 -- | Wed | No | 52 | 2003 |
414 -- +-------+------#########---------+
415 -- | Wed | Yes # 53 # 1992 |
416 -- +-------+------#-------#---------+
417 -- | Thu | No # 53 # 1998 |
418 -- +-------+------#-------#---------+
419 -- | Thu | Yes # 53 # 2004 |
420 -- +-------+------#########---------+
421 -- | Fri | No | 52 | 1999 |
422 -- +-------+------+-------+---------+
423 -- | Fri | Yes | 52 | 1988 |
424 -- +-------+------+-------+---------+
425 -- | Sat | No | 52 | 1994 |
426 -- +-------+------+-------+---------+
427 -- | Sat | Yes | 52 | 1972 |
428 -- +-------+------+-------+---------+
429 -- | Sun | No | 52 | 1995 |
430 -- +-------+------+-------+---------+
431 -- | Sun | Yes | 52 | 1956 |
432 -- +-------+------+-------+---------+
434 -- A small optimization, the input date is January 1. Note that this
435 -- is a key day since it determines the number of weeks and is used
436 -- when special casing the first week of January and the last week of
439 Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1
441 else (Time_Of (Year, 1, 1, 0.0)));
443 -- Special cases for January
447 -- Special case 1: January 1, 2 and 3. These three days may belong
448 -- to last year's last week which can be week number 52 or 53.
450 -- +-----+-----+-----+=====+-----+-----+-----+
451 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
452 -- +-----+-----+-----+-----+-----+-----+-----+
453 -- | 26 | 27 | 28 # 29 # 30 | 31 | 1 |
454 -- +-----+-----+-----+-----+-----+-----+-----+
455 -- | 27 | 28 | 29 # 30 # 31 | 1 | 2 |
456 -- +-----+-----+-----+-----+-----+-----+-----+
457 -- | 28 | 29 | 30 # 31 # 1 | 2 | 3 |
458 -- +-----+-----+-----+=====+-----+-----+-----+
460 if (Day = 1 and then Jan_1 in Friday .. Sunday)
462 (Day = 2 and then Jan_1 in Friday .. Saturday)
464 (Day = 3 and then Jan_1 = Friday)
466 Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52);
468 -- January 1, 2 and 3 belong to the previous year
473 -- Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week
475 -- +-----+-----+-----+=====+-----+-----+-----+
476 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
477 -- +-----+-----+-----+-----+-----+-----+-----+
478 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 |
479 -- +-----+-----+-----+-----+-----+-----+-----+
480 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 |
481 -- +-----+-----+-----+-----+-----+-----+-----+
482 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 |
483 -- +-----+-----+-----+-----+-----+-----+-----+
484 -- | 1 | 2 | 3 # 4 # 5 | 6 | 7 |
485 -- +-----+-----+-----+=====+-----+-----+-----+
487 elsif (Day <= 4 and then Jan_1 in Monday .. Thursday)
489 (Day = 5 and then Jan_1 in Monday .. Wednesday)
491 (Day = 6 and then Jan_1 in Monday .. Tuesday)
493 (Day = 7 and then Jan_1 = Monday)
499 -- Month other than 1
501 -- Special case 3: December 29, 30 and 31. These days may belong to
502 -- next year's first week.
504 -- +-----+-----+-----+=====+-----+-----+-----+
505 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
506 -- +-----+-----+-----+-----+-----+-----+-----+
507 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 |
508 -- +-----+-----+-----+-----+-----+-----+-----+
509 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 |
510 -- +-----+-----+-----+-----+-----+-----+-----+
511 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 |
512 -- +-----+-----+-----+=====+-----+-----+-----+
514 elsif Month = 12 and then Day > 28 then
516 Next_Jan_1 : constant Day_Name :=
517 Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True);
519 if (Day = 29 and then Next_Jan_1 = Thursday)
521 (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday)
523 (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday)
532 -- Determine the week from which to start counting. If January 1 does
533 -- not belong to the first week of the input year, then the next week
534 -- is the first week.
536 Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2);
538 -- At this point all special combinations have been accounted for and
539 -- the proper start week has been found. Since January 1 may not fall
540 -- on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an
541 -- origin which falls on Monday.
543 Shift := 7 - Day_Name'Pos (Jan_1);
544 Week := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7;
545 end Year_Week_In_Year;