gcc/ada/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-2008, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 package body GNAT.Calendar is
  35
  36    use Ada.Calendar;
  37    use Interfaces;
  38
  39    -----------------
  40    -- Day_In_Year --
  41    -----------------
  42
  43    function Day_In_Year (Date : Time) return Day_In_Year_Number is
  44       Year     : Year_Number;
  45       Month    : Month_Number;
  46       Day      : Day_Number;
  47       Day_Secs : Day_Duration;
  48       pragma Unreferenced (Day_Secs);
  49    begin
  50       Split (Date, Year, Month, Day, Day_Secs);
  51       return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
  52    end Day_In_Year;
  53
  54    -----------------
  55    -- Day_Of_Week --
  56    -----------------
  57
  58    function Day_Of_Week (Date : Time) return Day_Name is
  59       Year     : Year_Number;
  60       Month    : Month_Number;
  61       Day      : Day_Number;
  62       Day_Secs : Day_Duration;
  63       pragma Unreferenced (Day_Secs);
  64    begin
  65       Split (Date, Year, Month, Day, Day_Secs);
  66       return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
  67    end Day_Of_Week;
  68
  69    ----------
  70    -- Hour --
  71    ----------
  72
  73    function Hour (Date : Time) return Hour_Number is
  74       Year       : Year_Number;
  75       Month      : Month_Number;
  76       Day        : Day_Number;
  77       Hour       : Hour_Number;
  78       Minute     : Minute_Number;
  79       Second     : Second_Number;
  80       Sub_Second : Second_Duration;
  81       pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second);
  82    begin
  83       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
  84       return Hour;
  85    end Hour;
  86
  87    ----------------
  88    -- Julian_Day --
  89    ----------------
  90
  91    --  Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this
  92    --  implementation is not expensive.
  93
  94    function Julian_Day
  95      (Year  : Year_Number;
  96       Month : Month_Number;
  97       Day   : Day_Number) return Integer
  98    is
  99       Internal_Year  : Integer;
 100       Internal_Month : Integer;
 101       Internal_Day   : Integer;
 102       Julian_Date    : Integer;
 103       C              : Integer;
 104       Ya             : Integer;
 105
 106    begin
 107       Internal_Year  := Integer (Year);
 108       Internal_Month := Integer (Month);
 109       Internal_Day   := Integer (Day);
 110
 111       if Internal_Month > 2 then
 112          Internal_Month := Internal_Month - 3;
 113       else
 114          Internal_Month := Internal_Month + 9;
 115          Internal_Year  := Internal_Year - 1;
 116       end if;
 117
 118       C  := Internal_Year / 100;
 119       Ya := Internal_Year - (100 * C);
 120
 121       Julian_Date := (146_097 * C) / 4 +
 122         (1_461 * Ya) / 4 +
 123         (153 * Internal_Month + 2) / 5 +
 124         Internal_Day + 1_721_119;
 125
 126       return Julian_Date;
 127    end Julian_Day;
 128
 129    ------------
 130    -- Minute --
 131    ------------
 132
 133    function Minute (Date : Time) return Minute_Number is
 134       Year       : Year_Number;
 135       Month      : Month_Number;
 136       Day        : Day_Number;
 137       Hour       : Hour_Number;
 138       Minute     : Minute_Number;
 139       Second     : Second_Number;
 140       Sub_Second : Second_Duration;
 141       pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second);
 142    begin
 143       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 144       return Minute;
 145    end Minute;
 146
 147    ------------
 148    -- Second --
 149    ------------
 150
 151    function Second (Date : Time) return Second_Number is
 152       Year       : Year_Number;
 153       Month      : Month_Number;
 154       Day        : Day_Number;
 155       Hour       : Hour_Number;
 156       Minute     : Minute_Number;
 157       Second     : Second_Number;
 158       Sub_Second : Second_Duration;
 159       pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second);
 160    begin
 161       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 162       return Second;
 163    end Second;
 164
 165    -----------
 166    -- Split --
 167    -----------
 168
 169    procedure Split
 170      (Date       : Time;
 171       Year       : out Year_Number;
 172       Month      : out Month_Number;
 173       Day        : out Day_Number;
 174       Hour       : out Hour_Number;
 175       Minute     : out Minute_Number;
 176       Second     : out Second_Number;
 177       Sub_Second : out Second_Duration)
 178    is
 179       Day_Secs : Day_Duration;
 180       Secs     : Natural;
 181
 182    begin
 183       Split (Date, Year, Month, Day, Day_Secs);
 184
 185       if Day_Secs = 0.0 then
 186          Secs := 0;
 187       else
 188          Secs := Natural (Day_Secs - 0.5);
 189       end if;
 190
 191       Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs));
 192       Hour       := Hour_Number (Secs / 3_600);
 193       Secs       := Secs mod 3_600;
 194       Minute     := Minute_Number (Secs / 60);
 195       Second     := Second_Number (Secs mod 60);
 196    end Split;
 197
 198    ----------------
 199    -- Sub_Second --
 200    ----------------
 201
 202    function Sub_Second (Date : Time) return Second_Duration is
 203       Year       : Year_Number;
 204       Month      : Month_Number;
 205       Day        : Day_Number;
 206       Hour       : Hour_Number;
 207       Minute     : Minute_Number;
 208       Second     : Second_Number;
 209       Sub_Second : Second_Duration;
 210       pragma Unreferenced (Year, Month, Day, Hour, Minute, Second);
 211    begin
 212       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 213       return Sub_Second;
 214    end Sub_Second;
 215
 216    -------------
 217    -- Time_Of --
 218    -------------
 219
 220    function Time_Of
 221      (Year       : Year_Number;
 222       Month      : Month_Number;
 223       Day        : Day_Number;
 224       Hour       : Hour_Number;
 225       Minute     : Minute_Number;
 226       Second     : Second_Number;
 227       Sub_Second : Second_Duration := 0.0) return Time
 228    is
 229
 230       Day_Secs : constant Day_Duration :=
 231                    Day_Duration (Hour   * 3_600) +
 232                    Day_Duration (Minute *    60) +
 233                    Day_Duration (Second)         +
 234                                  Sub_Second;
 235    begin
 236       return Time_Of (Year, Month, Day, Day_Secs);
 237    end Time_Of;
 238
 239    -----------------
 240    -- To_Duration --
 241    -----------------
 242
 243    function To_Duration (T : not null access timeval) return Duration is
 244
 245       procedure timeval_to_duration
 246         (T    : not null access timeval;
 247          sec  : not null access C.long;
 248          usec : not null access C.long);
 249       pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
 250
 251       Micro : constant := 10**6;
 252       sec   : aliased C.long;
 253       usec  : aliased C.long;
 254
 255    begin
 256       timeval_to_duration (T, sec'Access, usec'Access);
 257       return Duration (sec) + Duration (usec) / Micro;
 258    end To_Duration;
 259
 260    ----------------
 261    -- To_Timeval --
 262    ----------------
 263
 264    function To_Timeval (D : Duration) return timeval is
 265
 266       procedure duration_to_timeval
 267         (Sec  : C.long;
 268          Usec : C.long;
 269          T : not null access timeval);
 270       pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
 271
 272       Micro  : constant := 10**6;
 273       Result : aliased timeval;
 274       sec    : C.long;
 275       usec   : C.long;
 276
 277    begin
 278       if D = 0.0 then
 279          sec  := 0;
 280          usec := 0;
 281       else
 282          sec  := C.long (D - 0.5);
 283          usec := C.long ((D - Duration (sec)) * Micro - 0.5);
 284       end if;
 285
 286       duration_to_timeval (sec, usec, Result'Access);
 287
 288       return Result;
 289    end To_Timeval;
 290
 291    ------------------
 292    -- Week_In_Year --
 293    ------------------
 294
 295    function Week_In_Year (Date : Time) return Week_In_Year_Number is
 296       Year : Year_Number;
 297       Week : Week_In_Year_Number;
 298       pragma Unreferenced (Year);
 299    begin
 300       Year_Week_In_Year (Date, Year, Week);
 301       return Week;
 302    end Week_In_Year;
 303
 304    -----------------------
 305    -- Year_Week_In_Year --
 306    -----------------------
 307
 308    procedure Year_Week_In_Year
 309      (Date : Time;
 310       Year : out Year_Number;
 311       Week : out Week_In_Year_Number)
 312    is
 313       Month      : Month_Number;
 314       Day        : Day_Number;
 315       Hour       : Hour_Number;
 316       Minute     : Minute_Number;
 317       Second     : Second_Number;
 318       Sub_Second : Second_Duration;
 319       Jan_1      : Day_Name;
 320       Shift      : Week_In_Year_Number;
 321       Start_Week : Week_In_Year_Number;
 322
 323       pragma Unreferenced (Hour, Minute, Second, Sub_Second);
 324
 325       function Is_Leap (Year : Year_Number) return Boolean;
 326       --  Return True if Year denotes a leap year. Leap centennial years are
 327       --  properly handled.
 328
 329       function Jan_1_Day_Of_Week
 330         (Jan_1     : Day_Name;
 331          Year      : Year_Number;
 332          Last_Year : Boolean := False;
 333          Next_Year : Boolean := False) return Day_Name;
 334       --  Given the weekday of January 1 in Year, determine the weekday on
 335       --  which January 1 fell last year or will fall next year as set by
 336       --  the two flags. This routine does not call Time_Of or Split.
 337
 338       function Last_Year_Has_53_Weeks
 339         (Jan_1 : Day_Name;
 340          Year  : Year_Number) return Boolean;
 341       --  Given the weekday of January 1 in Year, determine whether last year
 342       --  has 53 weeks. A False value implies that the year has 52 weeks.
 343
 344       -------------
 345       -- Is_Leap --
 346       -------------
 347
 348       function Is_Leap (Year : Year_Number) return Boolean is
 349       begin
 350          if Year mod 400 = 0 then
 351             return True;
 352          elsif Year mod 100 = 0 then
 353             return False;
 354          else
 355             return Year mod 4 = 0;
 356          end if;
 357       end Is_Leap;
 358
 359       -----------------------
 360       -- Jan_1_Day_Of_Week --
 361       -----------------------
 362
 363       function Jan_1_Day_Of_Week
 364         (Jan_1     : Day_Name;
 365          Year      : Year_Number;
 366          Last_Year : Boolean := False;
 367          Next_Year : Boolean := False) return Day_Name
 368       is
 369          Shift : Integer := 0;
 370
 371       begin
 372          if Last_Year then
 373             if Is_Leap (Year - 1) then
 374                Shift := -2;
 375             else
 376                Shift := -1;
 377             end if;
 378
 379          elsif Next_Year then
 380             if Is_Leap (Year) then
 381                Shift := 2;
 382             else
 383                Shift := 1;
 384             end if;
 385          end if;
 386
 387          return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7);
 388       end Jan_1_Day_Of_Week;
 389
 390       ----------------------------
 391       -- Last_Year_Has_53_Weeks --
 392       ----------------------------
 393
 394       function Last_Year_Has_53_Weeks
 395         (Jan_1 : Day_Name;
 396          Year  : Year_Number) return Boolean
 397       is
 398          Last_Jan_1 : constant Day_Name :=
 399                         Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True);
 400
 401       begin
 402          --  These two cases are illustrated in the table below
 403
 404          return
 405            Last_Jan_1 = Thursday
 406              or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1));
 407       end Last_Year_Has_53_Weeks;
 408
 409    --  Start of processing for Week_In_Year
 410
 411    begin
 412       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 413
 414       --  According to ISO 8601, the first week of year Y is the week that
 415       --  contains the first Thursday in year Y. The following table contains
 416       --  all possible combinations of years and weekdays along with examples.
 417
 418       --    +-------+------+-------+---------+
 419       --    | Jan 1 | Leap | Weeks | Example |
 420       --    +-------+------+-------+---------+
 421       --    |  Mon  |  No  |  52   |  2007   |
 422       --    +-------+------+-------+---------+
 423       --    |  Mon  | Yes  |  52   |  1996   |
 424       --    +-------+------+-------+---------+
 425       --    |  Tue  |  No  |  52   |  2002   |
 426       --    +-------+------+-------+---------+
 427       --    |  Tue  | Yes  |  52   |  1980   |
 428       --    +-------+------+-------+---------+
 429       --    |  Wed  |  No  |  52   |  2003   |
 430       --    +-------+------#########---------+
 431       --    |  Wed  | Yes  #  53   #  1992   |
 432       --    +-------+------#-------#---------+
 433       --    |  Thu  |  No  #  53   #  1998   |
 434       --    +-------+------#-------#---------+
 435       --    |  Thu  | Yes  #  53   #  2004   |
 436       --    +-------+------#########---------+
 437       --    |  Fri  |  No  |  52   |  1999   |
 438       --    +-------+------+-------+---------+
 439       --    |  Fri  | Yes  |  52   |  1988   |
 440       --    +-------+------+-------+---------+
 441       --    |  Sat  |  No  |  52   |  1994   |
 442       --    +-------+------+-------+---------+
 443       --    |  Sat  | Yes  |  52   |  1972   |
 444       --    +-------+------+-------+---------+
 445       --    |  Sun  |  No  |  52   |  1995   |
 446       --    +-------+------+-------+---------+
 447       --    |  Sun  | Yes  |  52   |  1956   |
 448       --    +-------+------+-------+---------+
 449
 450       --  A small optimization, the input date is January 1. Note that this
 451       --  is a key day since it determines the number of weeks and is used
 452       --  when special casing the first week of January and the last week of
 453       --  December.
 454
 455       if Day = 1 and then Month = 1 then
 456          Jan_1 := Day_Of_Week (Date);
 457       else
 458          Jan_1 := Day_Of_Week (Time_Of (Year, 1, 1, 0.0));
 459       end if;
 460
 461       if Month = 1 then
 462
 463          --  Special case 1: January 1, 2 and 3. These three days may belong
 464          --  to last year's last week which can be week number 52 or 53.
 465
 466          --    +-----+-----+-----+=====+-----+-----+-----+
 467          --    | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
 468          --    +-----+-----+-----+-----+-----+-----+-----+
 469          --    | 26  | 27  | 28  # 29  # 30  | 31  |  1  |
 470          --    +-----+-----+-----+-----+-----+-----+-----+
 471          --    | 27  | 28  | 29  # 30  # 31  |  1  |  2  |
 472          --    +-----+-----+-----+-----+-----+-----+-----+
 473          --    | 28  | 29  | 30  # 31  #  1  |  2  |  3  |
 474          --    +-----+-----+-----+=====+-----+-----+-----+
 475
 476          if (Day = 1 and then Jan_1 in Friday .. Sunday)
 477                or else
 478             (Day = 2 and then Jan_1 in Friday .. Saturday)
 479                or else
 480             (Day = 3 and then Jan_1 = Friday)
 481          then
 482             if Last_Year_Has_53_Weeks (Jan_1, Year) then
 483                Week := 53;
 484             else
 485                Week := 52;
 486             end if;
 487
 488             --  January 1, 2 and 3 belong to the previous year
 489
 490             Year := Year - 1;
 491             return;
 492
 493          --  Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week
 494
 495          --    +-----+-----+-----+=====+-----+-----+-----+
 496          --    | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
 497          --    +-----+-----+-----+-----+-----+-----+-----+
 498          --    | 29  | 30  | 31  #  1  #  2  |  3  |  4  |
 499          --    +-----+-----+-----+-----+-----+-----+-----+
 500          --    | 30  | 31  |  1  #  2  #  3  |  4  |  5  |
 501          --    +-----+-----+-----+-----+-----+-----+-----+
 502          --    | 31  |  1  |  2  #  3  #  4  |  5  |  6  |
 503          --    +-----+-----+-----+-----+-----+-----+-----+
 504          --    |  1  |  2  |  3  #  4  #  5  |  6  |  7  |
 505          --    +-----+-----+-----+=====+-----+-----+-----+
 506
 507          elsif (Day <= 4 and then Jan_1 in Monday .. Thursday)
 508                   or else
 509                (Day = 5  and then Jan_1 in Monday .. Wednesday)
 510                   or else
 511                (Day = 6  and then Jan_1 in Monday ..  Tuesday)
 512                   or else
 513                (Day = 7  and then Jan_1 = Monday)
 514          then
 515             Week := 1;
 516             return;
 517          end if;
 518
 519       --  Special case 3: December 29, 30 and 31. These days may belong to
 520       --  next year's first week.
 521
 522       --    +-----+-----+-----+=====+-----+-----+-----+
 523       --    | Mon | Tue | Wed # Thu # Fri | Sat | Sun |
 524       --    +-----+-----+-----+-----+-----+-----+-----+
 525       --    | 29  | 30  | 31  #  1  #  2  |  3  |  4  |
 526       --    +-----+-----+-----+-----+-----+-----+-----+
 527       --    | 30  | 31  |  1  #  2  #  3  |  4  |  5  |
 528       --    +-----+-----+-----+-----+-----+-----+-----+
 529       --    | 31  |  1  |  2  #  3  #  4  |  5  |  6  |
 530       --    +-----+-----+-----+=====+-----+-----+-----+
 531
 532       elsif Month = 12 and then Day > 28 then
 533          declare
 534             Next_Jan_1 : constant Day_Name :=
 535                            Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True);
 536          begin
 537             if (Day = 29 and then Next_Jan_1 = Thursday)
 538                   or else
 539                (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday)
 540                   or else
 541                (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday)
 542             then
 543                Year := Year + 1;
 544                Week := 1;
 545                return;
 546             end if;
 547          end;
 548       end if;
 549
 550       --  Determine the week from which to start counting. If January 1 does
 551       --  not belong to the first week of the input year, then the next week
 552       --  is the first week.
 553
 554       if Jan_1 in Friday .. Sunday then
 555          Start_Week := 1;
 556       else
 557          Start_Week := 2;
 558       end if;
 559
 560       --  At this point all special combinations have been accounted for and
 561       --  the proper start week has been found. Since January 1 may not fall
 562       --  on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an
 563       --  origin which falls on Monday.
 564
 565       Shift := 7 - Day_Name'Pos (Jan_1);
 566       Week  := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7;
 567    end Year_Week_In_Year;
 568
 569 end GNAT.Calendar;