1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- G N A T . C A L E N D A R --
9 -- Copyright (C) 1999-2008, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 package body GNAT.Calendar is
43 function Day_In_Year (Date : Time) return Day_In_Year_Number is
47 Day_Secs : Day_Duration;
48 pragma Unreferenced (Day_Secs);
50 Split (Date, Year, Month, Day, Day_Secs);
51 return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
58 function Day_Of_Week (Date : Time) return Day_Name is
62 Day_Secs : Day_Duration;
63 pragma Unreferenced (Day_Secs);
65 Split (Date, Year, Month, Day, Day_Secs);
66 return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
73 function Hour (Date : Time) return Hour_Number is
78 Minute : Minute_Number;
79 Second : Second_Number;
80 Sub_Second : Second_Duration;
81 pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second);
83 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
91 -- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this
92 -- implementation is not expensive.
97 Day : Day_Number) return Integer
99 Internal_Year : Integer;
100 Internal_Month : Integer;
101 Internal_Day : Integer;
102 Julian_Date : Integer;
107 Internal_Year := Integer (Year);
108 Internal_Month := Integer (Month);
109 Internal_Day := Integer (Day);
111 if Internal_Month > 2 then
112 Internal_Month := Internal_Month - 3;
114 Internal_Month := Internal_Month + 9;
115 Internal_Year := Internal_Year - 1;
118 C := Internal_Year / 100;
119 Ya := Internal_Year - (100 * C);
121 Julian_Date := (146_097 * C) / 4 +
123 (153 * Internal_Month + 2) / 5 +
124 Internal_Day + 1_721_119;
133 function Minute (Date : Time) return Minute_Number is
135 Month : Month_Number;
138 Minute : Minute_Number;
139 Second : Second_Number;
140 Sub_Second : Second_Duration;
141 pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second);
143 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
151 function Second (Date : Time) return Second_Number is
153 Month : Month_Number;
156 Minute : Minute_Number;
157 Second : Second_Number;
158 Sub_Second : Second_Duration;
159 pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second);
161 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
171 Year : out Year_Number;
172 Month : out Month_Number;
173 Day : out Day_Number;
174 Hour : out Hour_Number;
175 Minute : out Minute_Number;
176 Second : out Second_Number;
177 Sub_Second : out Second_Duration)
179 Day_Secs : Day_Duration;
183 Split (Date, Year, Month, Day, Day_Secs);
185 if Day_Secs = 0.0 then
188 Secs := Natural (Day_Secs - 0.5);
191 Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs));
192 Hour := Hour_Number (Secs / 3_600);
193 Secs := Secs mod 3_600;
194 Minute := Minute_Number (Secs / 60);
195 Second := Second_Number (Secs mod 60);
202 function Sub_Second (Date : Time) return Second_Duration is
204 Month : Month_Number;
207 Minute : Minute_Number;
208 Second : Second_Number;
209 Sub_Second : Second_Duration;
210 pragma Unreferenced (Year, Month, Day, Hour, Minute, Second);
212 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
222 Month : Month_Number;
225 Minute : Minute_Number;
226 Second : Second_Number;
227 Sub_Second : Second_Duration := 0.0) return Time
230 Day_Secs : constant Day_Duration :=
231 Day_Duration (Hour * 3_600) +
232 Day_Duration (Minute * 60) +
233 Day_Duration (Second) +
236 return Time_Of (Year, Month, Day, Day_Secs);
243 function To_Duration (T : not null access timeval) return Duration is
245 procedure timeval_to_duration
246 (T : not null access timeval;
247 sec : not null access C.long;
248 usec : not null access C.long);
249 pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
251 Micro : constant := 10**6;
252 sec : aliased C.long;
253 usec : aliased C.long;
256 timeval_to_duration (T, sec'Access, usec'Access);
257 return Duration (sec) + Duration (usec) / Micro;
264 function To_Timeval (D : Duration) return timeval is
266 procedure duration_to_timeval
269 T : not null access timeval);
270 pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
272 Micro : constant := 10**6;
273 Result : aliased timeval;
282 sec := C.long (D - 0.5);
283 usec := C.long ((D - Duration (sec)) * Micro - 0.5);
286 duration_to_timeval (sec, usec, Result'Access);
295 function Week_In_Year (Date : Time) return Week_In_Year_Number is
297 Month : Month_Number;
300 Minute : Minute_Number;
301 Second : Second_Number;
302 Sub_Second : Second_Duration;
304 Shift : Week_In_Year_Number;
305 Start_Week : Week_In_Year_Number;
307 pragma Unreferenced (Hour, Minute, Second, Sub_Second);
309 function Is_Leap (Year : Year_Number) return Boolean;
310 -- Return True if Year denotes a leap year. Leap centennial years are
313 function Jan_1_Day_Of_Week
316 Last_Year : Boolean := False;
317 Next_Year : Boolean := False) return Day_Name;
318 -- Given the weekday of January 1 in Year, determine the weekday on
319 -- which January 1 fell last year or will fall next year as set by
320 -- the two flags. This routine does not call Time_Of or Split.
322 function Last_Year_Has_53_Weeks
324 Year : Year_Number) return Boolean;
325 -- Given the weekday of January 1 in Year, determine whether last year
326 -- has 53 weeks. A False value implies that the year has 52 weeks.
332 function Is_Leap (Year : Year_Number) return Boolean is
334 if Year mod 400 = 0 then
336 elsif Year mod 100 = 0 then
339 return Year mod 4 = 0;
343 -----------------------
344 -- Jan_1_Day_Of_Week --
345 -----------------------
347 function Jan_1_Day_Of_Week
350 Last_Year : Boolean := False;
351 Next_Year : Boolean := False) return Day_Name
353 Shift : Integer := 0;
357 if Is_Leap (Year - 1) then
364 if Is_Leap (Year) then
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);
385 -- These two cases are illustrated in the table below
388 Last_Jan_1 = Thursday
390 (Last_Jan_1 = Wednesday
391 and then Is_Leap (Year - 1));
392 end Last_Year_Has_53_Weeks;
394 -- Start of processing for Week_In_Year
397 Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
399 -- According to ISO 8601, the first week of year Y is the week that
400 -- contains the first Thursday in year Y. The following table contains
401 -- all possible combinations of years and weekdays along with examples.
403 -- +-------+------+-------+---------+
404 -- | Jan 1 | Leap | Weeks | Example |
405 -- +-------+------+-------+---------+
406 -- | Mon | No | 52 | 2007 |
407 -- +-------+------+-------+---------+
408 -- | Mon | Yes | 52 | 1996 |
409 -- +-------+------+-------+---------+
410 -- | Tue | No | 52 | 2002 |
411 -- +-------+------+-------+---------+
412 -- | Tue | Yes | 52 | 1980 |
413 -- +-------+------+-------+---------+
414 -- | Wed | No | 52 | 2003 |
415 -- +-------+------#########---------+
416 -- | Wed | Yes # 53 # 1992 |
417 -- +-------+------#-------#---------+
418 -- | Thu | No # 53 # 1998 |
419 -- +-------+------#-------#---------+
420 -- | Thu | Yes # 53 # 2004 |
421 -- +-------+------#########---------+
422 -- | Fri | No | 52 | 1999 |
423 -- +-------+------+-------+---------+
424 -- | Fri | Yes | 52 | 1988 |
425 -- +-------+------+-------+---------+
426 -- | Sat | No | 52 | 1994 |
427 -- +-------+------+-------+---------+
428 -- | Sat | Yes | 52 | 1972 |
429 -- +-------+------+-------+---------+
430 -- | Sun | No | 52 | 1995 |
431 -- +-------+------+-------+---------+
432 -- | Sun | Yes | 52 | 1956 |
433 -- +-------+------+-------+---------+
435 -- A small optimization, the input date is January 1. Note that this
436 -- is a key day since it determines the number of weeks and is used
437 -- when special casing the first week of January and the last week of
443 Jan_1 := Day_Of_Week (Date);
445 Jan_1 := Day_Of_Week (Time_Of (Year, 1, 1, 0.0));
450 -- Special case 1: January 1, 2 and 3. These three days may belong
451 -- to last year's last week which can be week number 52 or 53.
453 -- +-----+-----+-----+=====+-----+-----+-----+
454 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
455 -- +-----+-----+-----+-----+-----+-----+-----+
456 -- | 26 | 27 | 28 # 29 # 30 | 31 | 1 |
457 -- +-----+-----+-----+-----+-----+-----+-----+
458 -- | 27 | 28 | 29 # 30 # 31 | 1 | 2 |
459 -- +-----+-----+-----+-----+-----+-----+-----+
460 -- | 28 | 29 | 30 # 31 # 1 | 2 | 3 |
461 -- +-----+-----+-----+=====+-----+-----+-----+
463 if (Day = 1 and then Jan_1 in Friday .. Sunday)
465 (Day = 2 and then Jan_1 in Friday .. Saturday)
467 (Day = 3 and then Jan_1 = Friday)
469 if Last_Year_Has_53_Weeks (Jan_1, Year) then
475 -- Special case 2: January 1, 2, 3, 4, 5 and 6 of the first week. In
476 -- this scenario January 1 does not fall on a Monday.
478 -- +-----+-----+-----+=====+-----+-----+-----+
479 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
480 -- +-----+-----+-----+-----+-----+-----+-----+
481 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 |
482 -- +-----+-----+-----+-----+-----+-----+-----+
483 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 |
484 -- +-----+-----+-----+-----+-----+-----+-----+
485 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 |
486 -- +-----+-----+-----+-----+-----+-----+-----+
488 elsif (Day <= 4 and then Jan_1 in Tuesday .. Thursday)
490 (Day = 5 and then Jan_1 in Tuesday .. Wednesday)
492 (Day = 6 and then Jan_1 = Tuesday)
497 -- Special case 3: December 29, 30 and 31. These days may belong to
498 -- next year's first week.
500 -- +-----+-----+-----+=====+-----+-----+-----+
501 -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
502 -- +-----+-----+-----+-----+-----+-----+-----+
503 -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 |
504 -- +-----+-----+-----+-----+-----+-----+-----+
505 -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 |
506 -- +-----+-----+-----+-----+-----+-----+-----+
507 -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 |
508 -- +-----+-----+-----+=====+-----+-----+-----+
514 Next_Jan_1 : constant Day_Name :=
515 Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True);
517 if (Day = 29 and then Next_Jan_1 = Thursday)
519 (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday)
521 (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday)
528 -- Determine the week from which to start counting. If January 1 does
529 -- not belong to the first week of the input year, then the next week
530 -- is the first week.
532 if Jan_1 in Friday .. Sunday then
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 return Start_Week + (Day_In_Year (Date) - Shift - 1) / 7;