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-2001 Ada Core Technologies, Inc.            --
  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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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)
 100       return  Integer
 101    is
 102       Internal_Year  : Integer;
 103       Internal_Month : Integer;
 104       Internal_Day   : Integer;
 105       Julian_Date    : Integer;
 106       C              : Integer;
 107       Ya             : Integer;
 108
 109    begin
 110       Internal_Year  := Integer (Year);
 111       Internal_Month := Integer (Month);
 112       Internal_Day   := Integer (Day);
 113
 114       if Internal_Month > 2 then
 115          Internal_Month := Internal_Month - 3;
 116       else
 117          Internal_Month := Internal_Month + 9;
 118          Internal_Year  := Internal_Year - 1;
 119       end if;
 120
 121       C  := Internal_Year / 100;
 122       Ya := Internal_Year - (100 * C);
 123
 124       Julian_Date := (146_097 * C) / 4 +
 125         (1_461 * Ya) / 4 +
 126         (153 * Internal_Month + 2) / 5 +
 127         Internal_Day + 1_721_119;
 128
 129       return Julian_Date;
 130    end Julian_Day;
 131
 132    ------------
 133    -- Minute --
 134    ------------
 135
 136    function Minute (Date : Time) return Minute_Number is
 137       Year       : Year_Number;
 138       Month      : Month_Number;
 139       Day        : Day_Number;
 140       Hour       : Hour_Number;
 141       Minute     : Minute_Number;
 142       Second     : Second_Number;
 143       Sub_Second : Second_Duration;
 144
 145    begin
 146       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 147       return Minute;
 148    end Minute;
 149
 150    ------------
 151    -- Second --
 152    ------------
 153
 154    function Second (Date : Time) return Second_Number is
 155       Year       : Year_Number;
 156       Month      : Month_Number;
 157       Day        : Day_Number;
 158       Hour       : Hour_Number;
 159       Minute     : Minute_Number;
 160       Second     : Second_Number;
 161       Sub_Second : Second_Duration;
 162
 163    begin
 164       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 165       return Second;
 166    end Second;
 167
 168    -----------
 169    -- Split --
 170    -----------
 171
 172    procedure Split
 173      (Date       : Time;
 174       Year       : out Year_Number;
 175       Month      : out Month_Number;
 176       Day        : out Day_Number;
 177       Hour       : out Hour_Number;
 178       Minute     : out Minute_Number;
 179       Second     : out Second_Number;
 180       Sub_Second : out Second_Duration)
 181    is
 182       Dsecs : Day_Duration;
 183       Secs  : Natural;
 184
 185    begin
 186       Split (Date, Year, Month, Day, Dsecs);
 187
 188       if Dsecs = 0.0 then
 189          Secs := 0;
 190       else
 191          Secs := Natural (Dsecs - 0.5);
 192       end if;
 193
 194       Sub_Second := Second_Duration (Dsecs - Day_Duration (Secs));
 195       Hour       := Hour_Number (Secs / 3600);
 196       Secs       := Secs mod 3600;
 197       Minute     := Minute_Number (Secs / 60);
 198       Second     := Second_Number (Secs mod 60);
 199    end Split;
 200
 201    ----------------
 202    -- Sub_Second --
 203    ----------------
 204
 205    function Sub_Second (Date : Time) return Second_Duration is
 206       Year       : Year_Number;
 207       Month      : Month_Number;
 208       Day        : Day_Number;
 209       Hour       : Hour_Number;
 210       Minute     : Minute_Number;
 211       Second     : Second_Number;
 212       Sub_Second : Second_Duration;
 213
 214    begin
 215       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 216       return Sub_Second;
 217    end Sub_Second;
 218
 219    -------------
 220    -- Time_Of --
 221    -------------
 222
 223    function Time_Of
 224      (Year       : Year_Number;
 225       Month      : Month_Number;
 226       Day        : Day_Number;
 227       Hour       : Hour_Number;
 228       Minute     : Minute_Number;
 229       Second     : Second_Number;
 230       Sub_Second : Second_Duration := 0.0)
 231       return Time
 232    is
 233       Dsecs : constant Day_Duration :=
 234                 Day_Duration (Hour * 3600 + Minute * 60 + Second) +
 235                                                              Sub_Second;
 236    begin
 237       return Time_Of (Year, Month, Day, Dsecs);
 238    end Time_Of;
 239
 240    -----------------
 241    -- To_Duration --
 242    -----------------
 243
 244    function To_Duration (T : access timeval) return Duration is
 245
 246       procedure timeval_to_duration
 247         (T    : access timeval;
 248          sec  : access C.long;
 249          usec : 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
 257    begin
 258       timeval_to_duration (T, sec'Access, usec'Access);
 259       return Duration (sec) + Duration (usec) / Micro;
 260    end To_Duration;
 261
 262    ----------------
 263    -- To_Timeval --
 264    ----------------
 265
 266    function To_Timeval  (D : Duration) return timeval is
 267
 268       procedure duration_to_timeval (Sec, Usec : C.long; T : access timeval);
 269       pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval");
 270
 271       Micro  : constant := 10**6;
 272       Result : aliased timeval;
 273       sec    : C.long;
 274       usec   : C.long;
 275
 276    begin
 277       if D = 0.0 then
 278          sec  := 0;
 279          usec := 0;
 280       else
 281          sec  := C.long (D - 0.5);
 282          usec := C.long ((D - Duration (sec)) * Micro - 0.5);
 283       end if;
 284
 285       duration_to_timeval (sec, usec, Result'Access);
 286
 287       return Result;
 288    end To_Timeval;
 289
 290    ------------------
 291    -- Week_In_Year --
 292    ------------------
 293
 294    function Week_In_Year
 295      (Date : Ada.Calendar.Time)
 296       return Week_In_Year_Number
 297    is
 298       Year       : Year_Number;
 299       Month      : Month_Number;
 300       Day        : Day_Number;
 301       Hour       : Hour_Number;
 302       Minute     : Minute_Number;
 303       Second     : Second_Number;
 304       Sub_Second : Second_Duration;
 305       Offset     : Natural;
 306
 307    begin
 308       Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second);
 309
 310       --  Day offset number for the first week of the year.
 311
 312       Offset := Julian_Day (Year, 1, 1) mod 7;
 313
 314       return 1 + ((Day_In_Year (Date) - 1) + Offset) / 7;
 315    end Week_In_Year;
 316
 317 end GNAT.Calendar;