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 --                                                                          --
  10 --           Copyright (C) 1999-2001 Ada Core Technologies, Inc.            --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 package body GNAT.Calendar is
  36
  37    use Ada.Calendar;
  38    use Interfaces;
  39
  40    -----------------
  41    -- Day_In_Year --
  42    -----------------
  43
  44    function Day_In_Year (Date : Time) return Day_In_Year_Number is
  45       Year  : Year_Number;
  46       Month : Month_Number;
  47       Day   : Day_Number;
  48       Dsecs : Day_Duration;
  49
  50    begin
  51       Split (Date, Year, Month, Day, Dsecs);
  52
  53       return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1;
  54    end Day_In_Year;
  55
  56    -----------------
  57    -- Day_Of_Week --
  58    -----------------
  59
  60    function Day_Of_Week (Date : Time) return Day_Name is
  61       Year  : Year_Number;
  62       Month : Month_Number;
  63       Day   : Day_Number;
  64       Dsecs : Day_Duration;
  65
  66    begin
  67       Split (Date, Year, Month, Day, Dsecs);
  68
  69       return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7);
  70    end Day_Of_Week;
  71
  72    ----------
  73    -- Hour --
  74    ----------
  75
  76    function Hour (Date : Time) return Hour_Number is
  77       Year       : Year_Number;
  78       Month      : Month_Number;
  79       Day        : Day_Number;
  80       Hour       : Hour_Number;
  81       Minute     : Minute_Number;
  82       Second     : Second_Number;
  83       Sub_Second : Second_Duration;
  84
  85    begin
  86       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
  87       return Hour;
  88    end Hour;
  89
  90    ----------------
  91    -- Julian_Day --
  92    ----------------
  93
  94    --  Julian_Day is used to by Day_Of_Week and Day_In_Year. Note
  95    --  that this implementation is not expensive.
  96
  97    function Julian_Day
  98      (Year  : Year_Number;
  99       Month : Month_Number;
 100       Day   : Day_Number)
 101       return  Integer
 102    is
 103       Internal_Year  : Integer;
 104       Internal_Month : Integer;
 105       Internal_Day   : Integer;
 106       Julian_Date    : Integer;
 107       C              : Integer;
 108       Ya             : Integer;
 109
 110    begin
 111       Internal_Year  := Integer (Year);
 112       Internal_Month := Integer (Month);
 113       Internal_Day   := Integer (Day);
 114
 115       if Internal_Month > 2 then
 116          Internal_Month := Internal_Month - 3;
 117       else
 118          Internal_Month := Internal_Month + 9;
 119          Internal_Year  := Internal_Year - 1;
 120       end if;
 121
 122       C  := Internal_Year / 100;
 123       Ya := Internal_Year - (100 * C);
 124
 125       Julian_Date := (146_097 * C) / 4 +
 126         (1_461 * Ya) / 4 +
 127         (153 * Internal_Month + 2) / 5 +
 128         Internal_Day + 1_721_119;
 129
 130       return Julian_Date;
 131    end Julian_Day;
 132
 133    ------------
 134    -- Minute --
 135    ------------
 136
 137    function Minute (Date : Time) return Minute_Number is
 138       Year       : Year_Number;
 139       Month      : Month_Number;
 140       Day        : Day_Number;
 141       Hour       : Hour_Number;
 142       Minute     : Minute_Number;
 143       Second     : Second_Number;
 144       Sub_Second : Second_Duration;
 145
 146    begin
 147       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 148       return Minute;
 149    end Minute;
 150
 151    ------------
 152    -- Second --
 153    ------------
 154
 155    function Second (Date : Time) return Second_Number is
 156       Year       : Year_Number;
 157       Month      : Month_Number;
 158       Day        : Day_Number;
 159       Hour       : Hour_Number;
 160       Minute     : Minute_Number;
 161       Second     : Second_Number;
 162       Sub_Second : Second_Duration;
 163
 164    begin
 165       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 166       return Second;
 167    end Second;
 168
 169    -----------
 170    -- Split --
 171    -----------
 172
 173    procedure Split
 174      (Date       : Time;
 175       Year       : out Year_Number;
 176       Month      : out Month_Number;
 177       Day        : out Day_Number;
 178       Hour       : out Hour_Number;
 179       Minute     : out Minute_Number;
 180       Second     : out Second_Number;
 181       Sub_Second : out Second_Duration)
 182    is
 183       Dsecs : Day_Duration;
 184       Secs  : Natural;
 185
 186    begin
 187       Split (Date, Year, Month, Day, Dsecs);
 188
 189       if Dsecs = 0.0 then
 190          Secs := 0;
 191       else
 192          Secs := Natural (Dsecs - 0.5);
 193       end if;
 194
 195       Sub_Second := Second_Duration (Dsecs - Day_Duration (Secs));
 196       Hour       := Hour_Number (Secs / 3600);
 197       Secs       := Secs mod 3600;
 198       Minute     := Minute_Number (Secs / 60);
 199       Second     := Second_Number (Secs mod 60);
 200    end Split;
 201
 202    ----------------
 203    -- Sub_Second --
 204    ----------------
 205
 206    function Sub_Second (Date : Time) return Second_Duration is
 207       Year       : Year_Number;
 208       Month      : Month_Number;
 209       Day        : Day_Number;
 210       Hour       : Hour_Number;
 211       Minute     : Minute_Number;
 212       Second     : Second_Number;
 213       Sub_Second : Second_Duration;
 214
 215    begin
 216       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 217       return Sub_Second;
 218    end Sub_Second;
 219
 220    -------------
 221    -- Time_Of --
 222    -------------
 223
 224    function Time_Of
 225      (Year       : Year_Number;
 226       Month      : Month_Number;
 227       Day        : Day_Number;
 228       Hour       : Hour_Number;
 229       Minute     : Minute_Number;
 230       Second     : Second_Number;
 231       Sub_Second : Second_Duration := 0.0)
 232       return Time
 233    is
 234       Dsecs : constant Day_Duration :=
 235                 Day_Duration (Hour * 3600 + Minute * 60 + Second) +
 236                                                              Sub_Second;
 237    begin
 238       return Time_Of (Year, Month, Day, Dsecs);
 239    end Time_Of;
 240
 241    -----------------
 242    -- To_Duration --
 243    -----------------
 244
 245    function To_Duration (T : access timeval) return Duration is
 246
 247       procedure timeval_to_duration
 248         (T    : access timeval;
 249          sec  : access C.long;
 250          usec : access C.long);
 251       pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
 252
 253       Micro : constant := 10**6;
 254       sec   : aliased C.long;
 255       usec  : aliased C.long;
 256
 257
 258    begin
 259       timeval_to_duration (T, sec'Access, usec'Access);
 260       return Duration (sec) + Duration (usec) / Micro;
 261    end To_Duration;
 262
 263    ----------------
 264    -- To_Timeval --
 265    ----------------
 266
 267    function To_Timeval  (D : Duration) return timeval is
 268
 269       procedure duration_to_timeval (Sec, Usec : C.long; T : 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
 296      (Date : Ada.Calendar.Time)
 297       return Week_In_Year_Number
 298    is
 299       Year       : Year_Number;
 300       Month      : Month_Number;
 301       Day        : Day_Number;
 302       Hour       : Hour_Number;
 303       Minute     : Minute_Number;
 304       Second     : Second_Number;
 305       Sub_Second : Second_Duration;
 306       Offset     : Natural;
 307
 308    begin
 309       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 310
 311       --  Day offset number for the first week of the year.
 312
 313       Offset := Julian_Day (Year, 1, 1) mod 7;
 314
 315       return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 316    end Week_In_Year;
 317
 318 end GNAT.Calendar;