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-2005, 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       Dsecs : Day_Duration;
  48
  49    begin
  50       Split (Date, Year, Month, Day, Dsecs);
  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       Dsecs : Day_Duration;
  64
  65    begin
  66       Split (Date, Year, Month, Day, Dsecs);
  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
  94    --  that this 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       Dsecs : Day_Duration;
 182       Secs  : Natural;
 183
 184    begin
 185       Split (Date, Year, Month, Day, Dsecs);
 186
 187       if Dsecs = 0.0 then
 188          Secs := 0;
 189       else
 190          Secs := Natural (Dsecs - 0.5);
 191       end if;
 192
 193       Sub_Second := Second_Duration (Dsecs - Day_Duration (Secs));
 194       Hour       := Hour_Number (Secs / 3600);
 195       Secs       := Secs mod 3600;
 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       Dsecs : constant Day_Duration :=
 232                 Day_Duration (Hour * 3600 + Minute * 60 + Second) +
 233                                                              Sub_Second;
 234    begin
 235       return Time_Of (Year, Month, Day, Dsecs);
 236    end Time_Of;
 237
 238    -----------------
 239    -- To_Duration --
 240    -----------------
 241
 242    function To_Duration (T : access timeval) return Duration is
 243
 244       procedure timeval_to_duration
 245         (T    : access timeval;
 246          sec  : access C.long;
 247          usec : access C.long);
 248       pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
 249
 250       Micro : constant := 10**6;
 251       sec   : aliased C.long;
 252       usec  : aliased C.long;
 253
 254    begin
 255       timeval_to_duration (T, sec'Access, usec'Access);
 256       return Duration (sec) + Duration (usec) / Micro;
 257    end To_Duration;
 258
 259    ----------------
 260    -- To_Timeval --
 261    ----------------
 262
 263    function To_Timeval  (D : Duration) return timeval is
 264
 265       procedure duration_to_timeval (Sec, Usec : C.long; T : access timeval);
 266       pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
 267
 268       Micro  : constant := 10**6;
 269       Result : aliased timeval;
 270       sec    : C.long;
 271       usec   : C.long;
 272
 273    begin
 274       if D = 0.0 then
 275          sec  := 0;
 276          usec := 0;
 277       else
 278          sec  := C.long (D - 0.5);
 279          usec := C.long ((D - Duration (sec)) * Micro - 0.5);
 280       end if;
 281
 282       duration_to_timeval (sec, usec, Result'Access);
 283
 284       return Result;
 285    end To_Timeval;
 286
 287    ------------------
 288    -- Week_In_Year --
 289    ------------------
 290
 291    function Week_In_Year
 292      (Date : Ada.Calendar.Time) return Week_In_Year_Number
 293    is
 294       Year       : Year_Number;
 295       Month      : Month_Number;
 296       Day        : Day_Number;
 297       Hour       : Hour_Number;
 298       Minute     : Minute_Number;
 299       Second     : Second_Number;
 300       Sub_Second : Second_Duration;
 301       Offset     : Natural;
 302
 303    begin
 304       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 305
 306       --  Day offset number for the first week of the year
 307
 308       Offset := Julian_Day (Year, 1, 1) mod 7;
 309
 310       return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 311    end Week_In_Year;
 312
 313 end GNAT.Calendar;