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