File : a-calend-cert.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                         A D A . C A L E N D A R                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2004-2015, 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 3,  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.                                     --
  17 --                                                                          --
  18 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31 
  32 --  This is the rts-cert version of this package
  33 
  34 with Interfaces.C; use Interfaces.C;
  35 with Ada.Unchecked_Conversion;
  36 
  37 package body Ada.Calendar with
  38   SPARK_Mode => Off
  39 is
  40 
  41    ------------------------
  42    -- Local Declarations --
  43    ------------------------
  44 
  45    Secs_Per_Day : constant := 86_400.0;
  46    --  Number of seconds in a day
  47 
  48    Radix_Time : Time;
  49    --  This is the zero point for time values. Time_Of returns 1 Jan 1970,
  50    --  0 UTC for this value. The time at which the board boots is given this
  51    --  conventional Time value. The BSP can adjust the initial real time
  52    --  relative to this value.
  53 
  54    --  Julian day range covers Ada.Time range requirement with smallest
  55    --  possible delta within 64 bits. This type is used for calculations that
  56    --  do not need to preserve the precision of type Duration and that need a
  57    --  larger Julian Day range than the Modified Julian Day provides, because
  58    --  of the algorithms used
  59 
  60    type Julian_Day is
  61      delta Duration'Small / (86_400.0 / 2.0 ** 5)
  62      range 2415_385.5 .. 2488_069.5;
  63    for Julian_Day'Small use Duration'Small / (86_400.0 / 2.0 ** 5);
  64 
  65    function Trunc (Arg : Time) return Integer;
  66    --  Truncate Time
  67 
  68    function Trunc (Arg : Duration) return Integer;
  69    --  Truncate Duration
  70 
  71    function Trunc (Arg : Julian_Day'Base) return Integer;
  72    --  Truncate Julian Day
  73 
  74    function Valid_Date
  75      (D : Day_Number;
  76       M : Month_Number;
  77       Y : Year_Number) return Boolean;
  78    --  Check for valid Gregorian calendar date
  79 
  80    ---------
  81    -- "+" --
  82    ---------
  83 
  84    function "+" (Left : Time; Right : Duration) return Time is
  85       pragma Unsuppress (Overflow_Check, Time);
  86       Result : Time;
  87    begin
  88       Result := Left + Time (Right / Secs_Per_Day);
  89       return Result;
  90    exception
  91       when Constraint_Error =>
  92          raise Time_Error;
  93    end "+";
  94 
  95    function "+" (Left : Duration; Right : Time) return Time is
  96       pragma Unsuppress (Overflow_Check, Time);
  97       Result : Time;
  98    begin
  99       Result := Time (Left / Secs_Per_Day) + Right;
 100       return Result;
 101    exception
 102       when Constraint_Error =>
 103          raise Time_Error;
 104    end "+";
 105 
 106    ---------
 107    -- "-" --
 108    ---------
 109 
 110    function "-" (Left : Time; Right : Duration) return Time is
 111       pragma Unsuppress (Overflow_Check, Time);
 112       Result : Time;
 113    begin
 114       Result  := Left - Time (Right / Secs_Per_Day);
 115       return Result;
 116    exception
 117       when Constraint_Error =>
 118          raise Time_Error;
 119    end "-";
 120 
 121    function "-" (Left : Time; Right : Time) return Duration is
 122       pragma Unsuppress (Overflow_Check, Time);
 123       Temp   : Time;
 124       Result : Duration;
 125    begin
 126       Temp  := Left - Right;
 127       Result := Duration (Secs_Per_Day * Temp);
 128       return Result;
 129    exception
 130       when Constraint_Error =>
 131          raise Time_Error;
 132    end "-";
 133 
 134    ---------
 135    -- "<" --
 136    ---------
 137 
 138    function "<" (Left, Right : Time) return Boolean is
 139       use type Modified_Julian_Day;
 140    begin
 141       return Modified_Julian_Day (Left) < Modified_Julian_Day (Right);
 142    end "<";
 143 
 144    ----------
 145    -- "<=" --
 146    ----------
 147 
 148    function "<=" (Left, Right : Time) return Boolean is
 149       use type Modified_Julian_Day;
 150    begin
 151       return Modified_Julian_Day (Left) <= Modified_Julian_Day (Right);
 152    end "<=";
 153 
 154    ---------
 155    -- ">" --
 156    ---------
 157 
 158    function ">" (Left, Right : Time) return Boolean is
 159       use type Modified_Julian_Day;
 160    begin
 161       return  Modified_Julian_Day (Left) > Modified_Julian_Day (Right);
 162    end ">";
 163 
 164    ----------
 165    -- ">=" --
 166    ----------
 167 
 168    function ">=" (Left, Right : Time) return Boolean is
 169       use type Modified_Julian_Day;
 170    begin
 171       return Modified_Julian_Day (Left) >= Modified_Julian_Day (Right);
 172    end ">=";
 173 
 174    -----------
 175    -- Clock --
 176    -----------
 177 
 178    function Clock return Time is separate;
 179 
 180    ---------
 181    -- Day --
 182    ---------
 183 
 184    function Day (Date : Time) return Day_Number is
 185       DY : Year_Number;
 186       DM : Month_Number;
 187       DD : Day_Number;
 188       DS : Day_Duration;
 189    begin
 190       Split (Date, DY, DM, DD, DS);
 191       return DD;
 192    end Day;
 193 
 194    -----------
 195    -- Month --
 196    -----------
 197 
 198    function Month (Date : Time) return Month_Number is
 199       DY : Year_Number;
 200       DM : Month_Number;
 201       DD : Day_Number;
 202       DS : Day_Duration;
 203    begin
 204       Split (Date, DY, DM, DD, DS);
 205       return DM;
 206    end Month;
 207 
 208    -------------
 209    -- Seconds --
 210    -------------
 211 
 212    function Seconds (Date : Time) return Day_Duration is
 213       DY : Year_Number;
 214       DM : Month_Number;
 215       DD : Day_Number;
 216       DS : Day_Duration;
 217    begin
 218       Split (Date, DY, DM, DD, DS);
 219       return DS;
 220    end Seconds;
 221 
 222    -----------
 223    -- Split --
 224    -----------
 225 
 226    procedure Split
 227      (Date    : Time;
 228       Year    : out Year_Number;
 229       Month   : out Month_Number;
 230       Day     : out Day_Number;
 231       Seconds : out Day_Duration)
 232    is
 233       --  Algorithm is the standard astronomical one for conversion
 234       --  from a Julian Day number to the Gregorian calendar date.
 235       --  Adapted from J. Meeus' "Astronomical Algorithms" pp 63 - 4.
 236 
 237       --  No need to check for Trunc (Date) < 2299_161 (Ada "Time" is
 238       --  always a Gregorian date).
 239 
 240       --  Split off fractional part before losing precision:
 241 
 242       F : constant Time := Date - Time (Trunc (Date));
 243 
 244       --  Do remainder of calcs on full Julian day number with less precision
 245       --  in fractional part (not necessary for these calcs)
 246 
 247       JD_Date : constant Julian_Day :=
 248         Julian_Day'Base (Date) +
 249         Julian_Day'Base'(240_0000.5);
 250 
 251       Z  : constant Integer := Trunc (JD_Date + Julian_Day'Base (0.5));
 252 
 253       A, B, C, D, E : Integer;
 254 
 255       Alpha : constant Integer :=
 256         Trunc
 257           (Julian_Day'Base
 258                ((Julian_Day'Base (Z) -
 259                   Julian_Day'Base'(1867_216.25)) /
 260                   Julian_Day'Base'(36524.25)));
 261 
 262    begin
 263       --  Generate intermediate values
 264 
 265       A := Z + 1 + Alpha - Alpha / 4;
 266       B := A + 1524;
 267       C := Trunc (Julian_Day'Base
 268                    ((Julian_Day'Base (B) - Julian_Day'Base'(122.1))
 269                      / Julian_Day'Base'(365.25)));
 270       D := Trunc (Julian_Day'Base
 271                    (Julian_Day'Base'(365.25) * Julian_Day'Base (C)));
 272       E := Trunc (Duration (Duration (B - D) / 30.6001));
 273 
 274       --  Generate results from intermediate values
 275 
 276       Month := E - (if E < 14 then 1 else 13);
 277       Year  := C - (if Month > 2 then 4716 else 4715);
 278       Day   := B - D - Trunc (Duration (30.6001 * Duration (E)));
 279 
 280       --  Restore seconds from precise fractional part
 281 
 282       Seconds := Day_Duration (86_400.0 * F);
 283    end Split;
 284 
 285    -------------
 286    -- Time_Of --
 287    -------------
 288 
 289    function Time_Of
 290      (Year    : Year_Number;
 291       Month   : Month_Number;
 292       Day     : Day_Number;
 293       Seconds : Day_Duration := 0.0) return Time
 294    is
 295       --  This is an adaptation of the standard astronomical algorithm for
 296       --  conversion from a Gregorian calendar date to a Julian day number.
 297       --  Taken from J. Meeus' "Astronomical Algorithms" pp 60 - 1.
 298 
 299       Month_Num   : Natural := Month;
 300       Year_Num    : Integer := Year;
 301       A, B        : Integer;
 302 
 303       type Day_Type is delta Modified_Julian_Day'Delta range 0.0 .. 32.0;
 304       for Day_Type'Small use Modified_Julian_Day'Small;
 305 
 306       Day_Val : constant Day_Type :=
 307         Day_Type (Day) + Day_Type (Seconds / Secs_Per_Day);
 308 
 309       subtype Month_Fixed is Duration range 4.0 .. 15.0;
 310 
 311    begin
 312       --  Check for valid date
 313 
 314       if not Valid_Date (Day, Month, Year) then
 315          raise Time_Error;
 316       end if;
 317 
 318       if Month_Num <= 2 then
 319          Year_Num := Year_Num - 1;
 320          Month_Num := Month_Num + 12;
 321       end if;
 322 
 323       A := Year_Num / 100;
 324       B := 2 - A + A / 4;
 325 
 326       return Time'Base (Day_Val)
 327         + Time
 328         (Julian_Day'Base
 329          (
 330           (B
 331            + Trunc (Duration (30.6001 * Month_Fixed (Month_Num + 1)))
 332            + Trunc (Julian_Day'Base (Julian_Day'Base'(365.25)
 333                                 * Julian_Day'Base (Year_Num + 4716)))))
 334          - Julian_Day'Base'(1524.5) - Julian_Day'Base'(240_0000.5));
 335    end Time_Of;
 336 
 337    -----------
 338    -- Trunc --
 339    -----------
 340 
 341    function Trunc (Arg : Time) return Integer is
 342       Rounded : constant Integer := Integer (Arg);
 343       Sign    : constant Integer := Rounded / abs (Rounded);
 344    begin
 345       if abs (Time (Rounded)) > abs (Arg) then
 346          return Rounded - Sign;
 347       else
 348          return Rounded;
 349       end if;
 350    end Trunc;
 351 
 352    function Trunc (Arg : Duration) return Integer is
 353       Rounded : constant Integer := Integer (Arg);
 354    begin
 355       if Rounded = 0 or else abs (Duration (Rounded)) <= abs (Arg) then
 356          return Rounded;
 357       else
 358          return Rounded - Rounded / abs (Rounded);
 359       end if;
 360    end Trunc;
 361 
 362    function Trunc (Arg : Julian_Day'Base) return Integer is
 363       Rounded : constant Integer := Integer (Arg);
 364    begin
 365       if Rounded = 0 or else abs (Julian_Day'Base (Rounded)) <= abs (Arg) then
 366          return Rounded;
 367       else
 368          return Rounded - Rounded / abs (Rounded);
 369       end if;
 370    end Trunc;
 371 
 372    ----------------
 373    -- Valid_Date --
 374    ----------------
 375 
 376    function Valid_Date
 377      (D : Day_Number;
 378       M : Month_Number;
 379       Y : Year_Number) return Boolean
 380    is
 381    begin
 382       --  Check that input values have valid representations. This check is not
 383       --  strictly required, since the only way we could fail this test is if
 384       --  the Time_Of caller suppressed checks, in which case we have erroneous
 385       --  execution. However, raising Time_Error in this case seems a friendly
 386       --  way to handle the erroneous action.
 387 
 388       if not (Y'Valid and then M'Valid and then D'Valid) then
 389          return False;
 390       end if;
 391 
 392       --  Deal with checking day according to month
 393 
 394       case M is
 395          when    4  |  6  |  9  | 11  =>
 396 
 397             --  Apr | Jun | Sep | Nov
 398 
 399             return D <= 30;
 400 
 401             --  Note: lower bound OK due to 'Valid. Lower bound check would be
 402             --  optimized away anyway, and resulted in a compilation warning.
 403 
 404          when    2  =>
 405 
 406             --  Feb
 407 
 408             --  Do leap year check. Note that we do not need to check centuries
 409             --  due to the limited range of Year_Number.
 410 
 411             if Y mod 4 = 0 then
 412                return D <= 29;
 413 
 414                --  Note: lower bound OK due to 'Valid
 415             else
 416                return D <= 28;
 417 
 418                --  Note: lower bound OK due to 'Valid
 419             end if;
 420 
 421          when    1  |  3  |  5  |  7  |  8  | 10  | 12  =>
 422 
 423             --  Jan | Mar | May | Jul | Aug | Oct | Dec
 424 
 425             return True;
 426       end case;
 427    end Valid_Date;
 428 
 429    ----------
 430    -- Year --
 431    ----------
 432 
 433    function Year (Date : Time) return Year_Number is
 434       DY : Year_Number;
 435       DM : Month_Number;
 436       DD : Day_Number;
 437       DS : Day_Duration;
 438    begin
 439       Split (Date, DY, DM, DD, DS);
 440       return DY;
 441    end Year;
 442 
 443 --  Start of elaboration code for Ada.Calendar
 444 
 445 begin
 446    Radix_Time := Time_Of (1970, 1, 1, 0.0);
 447 
 448 end Ada.Calendar;