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