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