8sa1-gcc/gcc/ada/g-calend.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                         G N A T . C A L E N D A R                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1999-2010, AdaCore                     --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

package body GNAT.Calendar is

   use Ada.Calendar;
   use Interfaces;

   -----------------
   -- Day_In_Year --
   -----------------

   function Day_In_Year (Date : Time) return Day_In_Year_Number is
      Year     : Year_Number;
      Month    : Month_Number;
      Day      : Day_Number;
      Day_Secs : Day_Duration;
      pragma Unreferenced (Day_Secs);
   begin
      Split (Date, Year, Month, Day, Day_Secs);
      return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
   end Day_In_Year;

   -----------------
   -- Day_Of_Week --
   -----------------

   function Day_Of_Week (Date : Time) return Day_Name is
      Year     : Year_Number;
      Month    : Month_Number;
      Day      : Day_Number;
      Day_Secs : Day_Duration;
      pragma Unreferenced (Day_Secs);
   begin
      Split (Date, Year, Month, Day, Day_Secs);
      return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
   end Day_Of_Week;

   ----------
   -- Hour --
   ----------

   function Hour (Date : Time) return Hour_Number is
      Year       : Year_Number;
      Month      : Month_Number;
      Day        : Day_Number;
      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;
      pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second);
   begin
      Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
      return Hour;
   end Hour;

   ----------------
   -- Julian_Day --
   ----------------

   --  Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this
   --  implementation is not expensive.

   function Julian_Day
     (Year  : Year_Number;
      Month : Month_Number;
      Day   : Day_Number) return Integer
   is
      Internal_Year  : Integer;
      Internal_Month : Integer;
      Internal_Day   : Integer;
      Julian_Date    : Integer;
      C              : Integer;
      Ya             : Integer;

   begin
      Internal_Year  := Integer (Year);
      Internal_Month := Integer (Month);
      Internal_Day   := Integer (Day);

      if Internal_Month > 2 then
         Internal_Month := Internal_Month - 3;
      else
         Internal_Month := Internal_Month + 9;
         Internal_Year  := Internal_Year - 1;
      end if;

      C  := Internal_Year / 100;
      Ya := Internal_Year - (100 * C);

      Julian_Date := (146_097 * C) / 4 +
        (1_461 * Ya) / 4 +
        (153 * Internal_Month + 2) / 5 +
        Internal_Day + 1_721_119;

      return Julian_Date;
   end Julian_Day;

   ------------
   -- Minute --
   ------------

   function Minute (Date : Time) return Minute_Number is
      Year       : Year_Number;
      Month      : Month_Number;
      Day        : Day_Number;
      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;
      pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second);
   begin
      Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
      return Minute;
   end Minute;

   ------------
   -- Second --
   ------------

   function Second (Date : Time) return Second_Number is
      Year       : Year_Number;
      Month      : Month_Number;
      Day        : Day_Number;
      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;
      pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second);
   begin
      Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
      return Second;
   end Second;

   -----------
   -- Split --
   -----------

   procedure Split
     (Date       : Time;
      Year       : out Year_Number;
      Month      : out Month_Number;
      Day        : out Day_Number;
      Hour       : out Hour_Number;
      Minute     : out Minute_Number;
      Second     : out Second_Number;
      Sub_Second : out Second_Duration)
   is
      Day_Secs : Day_Duration;
      Secs     : Natural;

   begin
      Split (Date, Year, Month, Day, Day_Secs);

      Secs       := (if Day_Secs = 0.0 then 0 else Natural (Day_Secs - 0.5));
      Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs));
      Hour       := Hour_Number (Secs / 3_600);
      Secs       := Secs mod 3_600;
      Minute     := Minute_Number (Secs / 60);
      Second     := Second_Number (Secs mod 60);
   end Split;

   ----------------
   -- Sub_Second --
   ----------------

   function Sub_Second (Date : Time) return Second_Duration is
      Year       : Year_Number;
      Month      : Month_Number;
      Day        : Day_Number;
      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;
      pragma Unreferenced (Year, Month, Day, Hour, Minute, Second);
   begin
      Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
      return Sub_Second;
   end Sub_Second;

   -------------
   -- Time_Of --
   -------------

   function Time_Of
     (Year       : Year_Number;
      Month      : Month_Number;
      Day        : Day_Number;
      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration := 0.0) return Time
   is

      Day_Secs : constant Day_Duration :=
                   Day_Duration (Hour   * 3_600) +
                   Day_Duration (Minute *    60) +
                   Day_Duration (Second)         +
                                 Sub_Second;
   begin
      return Time_Of (Year, Month, Day, Day_Secs);
   end Time_Of;

   -----------------
   -- To_Duration --
   -----------------

   function To_Duration (T : not null access timeval) return Duration is

      procedure timeval_to_duration
        (T    : not null access timeval;
         sec  : not null access C.long;
         usec : not null access C.long);
      pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");

      Micro : constant := 10**6;
      sec   : aliased C.long;
      usec  : aliased C.long;

   begin
      timeval_to_duration (T, sec'Access, usec'Access);
      return Duration (sec) + Duration (usec) / Micro;
   end To_Duration;

   ----------------
   -- To_Timeval --
   ----------------

   function To_Timeval (D : Duration) return timeval is

      procedure duration_to_timeval
        (Sec  : C.long;
         Usec : C.long;
         T : not null access timeval);
      pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");

      Micro  : constant := 10**6;
      Result : aliased timeval;
      sec    : C.long;
      usec   : C.long;

   begin
      if D = 0.0 then
         sec  := 0;
         usec := 0;
      else
         sec  := C.long (D - 0.5);
         usec := C.long ((D - Duration (sec)) * Micro - 0.5);
      end if;

      duration_to_timeval (sec, usec, Result'Access);

      return Result;
   end To_Timeval;

   ------------------
   -- Week_In_Year --
   ------------------

   function Week_In_Year (Date : Time) return Week_In_Year_Number is
      Year : Year_Number;
      Week : Week_In_Year_Number;
      pragma Unreferenced (Year);
   begin
      Year_Week_In_Year (Date, Year, Week);
      return Week;
   end Week_In_Year;

   -----------------------
   -- Year_Week_In_Year --
   -----------------------

   procedure Year_Week_In_Year
     (Date : Time;
      Year : out Year_Number;
      Week : out Week_In_Year_Number)
   is
      Month      : Month_Number;
      Day        : Day_Number;
      Hour       : Hour_Number;
      Minute     : Minute_Number;
      Second     : Second_Number;
      Sub_Second : Second_Duration;
      Jan_1      : Day_Name;
      Shift      : Week_In_Year_Number;
      Start_Week : Week_In_Year_Number;

      pragma Unreferenced (Hour, Minute, Second, Sub_Second);

      function Is_Leap (Year : Year_Number) return Boolean;
      --  Return True if Year denotes a leap year. Leap centennial years are
      --  properly handled.

      function Jan_1_Day_Of_Week
        (Jan_1     : Day_Name;
         Year      : Year_Number;
         Last_Year : Boolean := False;
         Next_Year : Boolean := False) return Day_Name;
      --  Given the weekday of January 1 in Year, determine the weekday on
      --  which January 1 fell last year or will fall next year as set by
      --  the two flags. This routine does not call Time_Of or Split.

      function Last_Year_Has_53_Weeks
        (Jan_1 : Day_Name;
         Year  : Year_Number) return Boolean;
      --  Given the weekday of January 1 in Year, determine whether last year
      --  has 53 weeks. A False value implies that the year has 52 weeks.

      -------------
      -- Is_Leap --
      -------------

      function Is_Leap (Year : Year_Number) return Boolean is
      begin
         if Year mod 400 = 0 then
            return True;
         elsif Year mod 100 = 0 then
            return False;
         else
            return Year mod 4 = 0;
         end if;
      end Is_Leap;

      -----------------------
      -- Jan_1_Day_Of_Week --
      -----------------------

      function Jan_1_Day_Of_Week
        (Jan_1     : Day_Name;
         Year      : Year_Number;
         Last_Year : Boolean := False;
         Next_Year : Boolean := False) return Day_Name
      is
         Shift : Integer := 0;

      begin
         if Last_Year then
            Shift := (if Is_Leap (Year - 1) then -2 else -1);
         elsif Next_Year then
            Shift := (if Is_Leap (Year) then 2 else 1);
         end if;

         return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7);
      end Jan_1_Day_Of_Week;

      ----------------------------
      -- Last_Year_Has_53_Weeks --
      ----------------------------

      function Last_Year_Has_53_Weeks
        (Jan_1 : Day_Name;
         Year  : Year_Number) return Boolean
      is
         Last_Jan_1 : constant Day_Name :=
                        Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True);

      begin
         --  These two cases are illustrated in the table below

         return
           Last_Jan_1 = Thursday
             or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1));
      end Last_Year_Has_53_Weeks;

   --  Start of processing for Week_In_Year

   begin
      Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);

      --  According to ISO 8601, the first week of year Y is the week that
      --  contains the first Thursday in year Y. The following table contains
      --  all possible combinations of years and weekdays along with examples.

      --    +-------+------+-------+---------+
      --    | Jan 1 | Leap | Weeks | Example |
      --    +-------+------+-------+---------+
      --    |  Mon  |  No  |  52   |  2007   |
      --    +-------+------+-------+---------+
      --    |  Mon  | Yes  |  52   |  1996   |
      --    +-------+------+-------+---------+
      --    |  Tue  |  No  |  52   |  2002   |
      --    +-------+------+-------+---------+
      --    |  Tue  | Yes  |  52   |  1980   |
      --    +-------+------+-------+---------+
      --    |  Wed  |  No  |  52   |  2003   |
      --    +-------+------#########---------+
      --    |  Wed  | Yes  #  53   #  1992   |
      --    +-------+------#-------#---------+
      --    |  Thu  |  No  #  53   #  1998   |
      --    +-------+------#-------#---------+
      --    |  Thu  | Yes  #  53   #  2004   |
      --    +-------+------#########---------+
      --    |  Fri  |  No  |  52   |  1999   |
      --    +-------+------+-------+---------+
      --    |  Fri  | Yes  |  52   |  1988   |
      --    +-------+------+-------+---------+
      --    |  Sat  |  No  |  52   |  1994   |
      --    +-------+------+-------+---------+
      --    |  Sat  | Yes  |  52   |  1972   |
      --    +-------+------+-------+---------+
      --    |  Sun  |  No  |  52   |  1995   |
      --    +-------+------+-------+---------+
      --    |  Sun  | Yes  |  52   |  1956   |
      --    +-------+------+-------+---------+

      --  A small optimization, the input date is January 1. Note that this
      --  is a key day since it determines the number of weeks and is used
      --  when special casing the first week of January and the last week of
      --  December.

      Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1
                            then Date
                            else (Time_Of (Year, 1, 1, 0.0)));

      --  Special cases for January

      if Month = 1 then

         --  Special case 1: January 1, 2 and 3. These three days may belong
         --  to last year's last week which can be week number 52 or 53.

         --    +-----+-----+-----+=====+-----+-----+-----+
         --    | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    | 26  | 27  | 28  # 29  # 30  | 31  |  1  |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    | 27  | 28  | 29  # 30  # 31  |  1  |  2  |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    | 28  | 29  | 30  # 31  #  1  |  2  |  3  |
         --    +-----+-----+-----+=====+-----+-----+-----+

         if (Day = 1 and then Jan_1 in Friday .. Sunday)
               or else
            (Day = 2 and then Jan_1 in Friday .. Saturday)
               or else
            (Day = 3 and then Jan_1 = Friday)
         then
            Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52);

            --  January 1, 2 and 3 belong to the previous year

            Year := Year - 1;
            return;

         --  Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week

         --    +-----+-----+-----+=====+-----+-----+-----+
         --    | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    | 29  | 30  | 31  #  1  #  2  |  3  |  4  |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    | 30  | 31  |  1  #  2  #  3  |  4  |  5  |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    | 31  |  1  |  2  #  3  #  4  |  5  |  6  |
         --    +-----+-----+-----+-----+-----+-----+-----+
         --    |  1  |  2  |  3  #  4  #  5  |  6  |  7  |
         --    +-----+-----+-----+=====+-----+-----+-----+

         elsif (Day <= 4 and then Jan_1 in Monday .. Thursday)
                  or else
               (Day = 5  and then Jan_1 in Monday .. Wednesday)
                  or else
               (Day = 6  and then Jan_1 in Monday ..  Tuesday)
                  or else
               (Day = 7  and then Jan_1 = Monday)
         then
            Week := 1;
            return;
         end if;

      --  Month other than 1

      --  Special case 3: December 29, 30 and 31. These days may belong to
      --  next year's first week.

      --    +-----+-----+-----+=====+-----+-----+-----+
      --    | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
      --    +-----+-----+-----+-----+-----+-----+-----+
      --    | 29  | 30  | 31  #  1  #  2  |  3  |  4  |
      --    +-----+-----+-----+-----+-----+-----+-----+
      --    | 30  | 31  |  1  #  2  #  3  |  4  |  5  |
      --    +-----+-----+-----+-----+-----+-----+-----+
      --    | 31  |  1  |  2  #  3  #  4  |  5  |  6  |
      --    +-----+-----+-----+=====+-----+-----+-----+

      elsif Month = 12 and then Day > 28 then
         declare
            Next_Jan_1 : constant Day_Name :=
                           Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True);
         begin
            if (Day = 29 and then Next_Jan_1 = Thursday)
                  or else
               (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday)
                  or else
               (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday)
            then
               Year := Year + 1;
               Week := 1;
               return;
            end if;
         end;
      end if;

      --  Determine the week from which to start counting. If January 1 does
      --  not belong to the first week of the input year, then the next week
      --  is the first week.

      Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2);

      --  At this point all special combinations have been accounted for and
      --  the proper start week has been found. Since January 1 may not fall
      --  on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an
      --  origin which falls on Monday.

      Shift := 7 - Day_Name'Pos (Jan_1);
      Week  := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7;
   end Year_Week_In_Year;

end GNAT.Calendar;