Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT RUN-TIME COMPONENTS                         --

--                                                                          --

--                         G N A T . C A L E N D A R                        --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--                     Copyright (C) 1999-2009, 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 2,  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.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT;  see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- As a special exception,  if other files  instantiate  generics from this --

-- unit, or you link  this unit with other files  to produce an executable, --

-- this  unit  does not  by itself cause  the resulting  executable  to  be --

-- covered  by the  GNU  General  Public  License.  This exception does not --

-- however invalidate  any other reasons why  the executable file  might be --

-- covered by the  GNU Public License.                                      --

--                                                                          --

-- 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;