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-2006, 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
  49    begin
  50       Split (Date, Year, Month, Day, Day_Secs);
  51
  52       return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
  53    end Day_In_Year;
  54
  55    -----------------
  56    -- Day_Of_Week --
  57    -----------------
  58
  59    function Day_Of_Week (Date : Time) return Day_Name is
  60       Year     : Year_Number;
  61       Month    : Month_Number;
  62       Day      : Day_Number;
  63       Day_Secs : Day_Duration;
  64
  65    begin
  66       Split (Date, Year, Month, Day, Day_Secs);
  67
  68       return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
  69    end Day_Of_Week;
  70
  71    ----------
  72    -- Hour --
  73    ----------
  74
  75    function Hour (Date : Time) return Hour_Number is
  76       Year       : Year_Number;
  77       Month      : Month_Number;
  78       Day        : Day_Number;
  79       Hour       : Hour_Number;
  80       Minute     : Minute_Number;
  81       Second     : Second_Number;
  82       Sub_Second : Second_Duration;
  83
  84    begin
  85       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
  86       return Hour;
  87    end Hour;
  88
  89    ----------------
  90    -- Julian_Day --
  91    ----------------
  92
  93    --  Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this
  94    --  implementation is not expensive.
  95
  96    function Julian_Day
  97      (Year  : Year_Number;
  98       Month : Month_Number;
  99       Day   : Day_Number) return Integer
 100    is
 101       Internal_Year  : Integer;
 102       Internal_Month : Integer;
 103       Internal_Day   : Integer;
 104       Julian_Date    : Integer;
 105       C              : Integer;
 106       Ya             : Integer;
 107
 108    begin
 109       Internal_Year  := Integer (Year);
 110       Internal_Month := Integer (Month);
 111       Internal_Day   := Integer (Day);
 112
 113       if Internal_Month > 2 then
 114          Internal_Month := Internal_Month - 3;
 115       else
 116          Internal_Month := Internal_Month + 9;
 117          Internal_Year  := Internal_Year - 1;
 118       end if;
 119
 120       C  := Internal_Year / 100;
 121       Ya := Internal_Year - (100 * C);
 122
 123       Julian_Date := (146_097 * C) / 4 +
 124         (1_461 * Ya) / 4 +
 125         (153 * Internal_Month + 2) / 5 +
 126         Internal_Day + 1_721_119;
 127
 128       return Julian_Date;
 129    end Julian_Day;
 130
 131    ------------
 132    -- Minute --
 133    ------------
 134
 135    function Minute (Date : Time) return Minute_Number is
 136       Year       : Year_Number;
 137       Month      : Month_Number;
 138       Day        : Day_Number;
 139       Hour       : Hour_Number;
 140       Minute     : Minute_Number;
 141       Second     : Second_Number;
 142       Sub_Second : Second_Duration;
 143
 144    begin
 145       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 146       return Minute;
 147    end Minute;
 148
 149    ------------
 150    -- Second --
 151    ------------
 152
 153    function Second (Date : Time) return Second_Number is
 154       Year       : Year_Number;
 155       Month      : Month_Number;
 156       Day        : Day_Number;
 157       Hour       : Hour_Number;
 158       Minute     : Minute_Number;
 159       Second     : Second_Number;
 160       Sub_Second : Second_Duration;
 161
 162    begin
 163       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 164       return Second;
 165    end Second;
 166
 167    -----------
 168    -- Split --
 169    -----------
 170
 171    procedure Split
 172      (Date       : Time;
 173       Year       : out Year_Number;
 174       Month      : out Month_Number;
 175       Day        : out Day_Number;
 176       Hour       : out Hour_Number;
 177       Minute     : out Minute_Number;
 178       Second     : out Second_Number;
 179       Sub_Second : out Second_Duration)
 180    is
 181       Day_Secs : Day_Duration;
 182       Secs     : Natural;
 183
 184    begin
 185       Split (Date, Year, Month, Day, Day_Secs);
 186
 187       if Day_Secs = 0.0 then
 188          Secs := 0;
 189       else
 190          Secs := Natural (Day_Secs - 0.5);
 191       end if;
 192
 193       Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs));
 194       Hour       := Hour_Number (Secs / 3_600);
 195       Secs       := Secs mod 3_600;
 196       Minute     := Minute_Number (Secs / 60);
 197       Second     := Second_Number (Secs mod 60);
 198    end Split;
 199
 200    ----------------
 201    -- Sub_Second --
 202    ----------------
 203
 204    function Sub_Second (Date : Time) return Second_Duration is
 205       Year       : Year_Number;
 206       Month      : Month_Number;
 207       Day        : Day_Number;
 208       Hour       : Hour_Number;
 209       Minute     : Minute_Number;
 210       Second     : Second_Number;
 211       Sub_Second : Second_Duration;
 212
 213    begin
 214       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 215       return Sub_Second;
 216    end Sub_Second;
 217
 218    -------------
 219    -- Time_Of --
 220    -------------
 221
 222    function Time_Of
 223      (Year       : Year_Number;
 224       Month      : Month_Number;
 225       Day        : Day_Number;
 226       Hour       : Hour_Number;
 227       Minute     : Minute_Number;
 228       Second     : Second_Number;
 229       Sub_Second : Second_Duration := 0.0) return Time
 230    is
 231       Day_Secs : constant Day_Duration :=
 232                    Day_Duration (Hour   * 3_600) +
 233                    Day_Duration (Minute *    60) +
 234                    Day_Duration (Second)         +
 235                                  Sub_Second;
 236    begin
 237       return Time_Of (Year, Month, Day, Day_Secs);
 238    end Time_Of;
 239
 240    -----------------
 241    -- To_Duration --
 242    -----------------
 243
 244    function To_Duration (T : not null access timeval) return Duration is
 245
 246       procedure timeval_to_duration
 247         (T    : not null access timeval;
 248          sec  : not null access C.long;
 249          usec : not null access C.long);
 250       pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
 251
 252       Micro : constant := 10**6;
 253       sec   : aliased C.long;
 254       usec  : aliased C.long;
 255
 256    begin
 257       timeval_to_duration (T, sec'Access, usec'Access);
 258       return Duration (sec) + Duration (usec) / Micro;
 259    end To_Duration;
 260
 261    ----------------
 262    -- To_Timeval --
 263    ----------------
 264
 265    function To_Timeval (D : Duration) return timeval is
 266
 267       procedure duration_to_timeval
 268         (Sec  : C.long;
 269          Usec : C.long;
 270          T : not null access timeval);
 271       pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
 272
 273       Micro  : constant := 10**6;
 274       Result : aliased timeval;
 275       sec    : C.long;
 276       usec   : C.long;
 277
 278    begin
 279       if D = 0.0 then
 280          sec  := 0;
 281          usec := 0;
 282       else
 283          sec  := C.long (D - 0.5);
 284          usec := C.long ((D - Duration (sec)) * Micro - 0.5);
 285       end if;
 286
 287       duration_to_timeval (sec, usec, Result'Access);
 288
 289       return Result;
 290    end To_Timeval;
 291
 292    ------------------
 293    -- Week_In_Year --
 294    ------------------
 295
 296    function Week_In_Year (Date : Time) return Week_In_Year_Number is
 297       Year       : Year_Number;
 298       Month      : Month_Number;
 299       Day        : Day_Number;
 300       Hour       : Hour_Number;
 301       Minute     : Minute_Number;
 302       Second     : Second_Number;
 303       Sub_Second : Second_Duration;
 304       Offset     : Natural;
 305
 306    begin
 307       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 308
 309       --  Day offset number for the first week of the year
 310
 311       Offset := Julian_Day (Year, 1, 1) mod 7;
 312
 313       return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 314    end Week_In_Year;
 315
 316 end GNAT.Calendar;