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
32with Interfaces.C.Extensions;
33
34package 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
652end GNAT.Calendar;
653