gcc/ada/4vcalend.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) 1992-2000 Free Software Foundation, 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 --  This is the Alpha/VMS version.
  35
  36 with System.Aux_DEC; use System.Aux_DEC;
  37
  38 package body Ada.Calendar is
  39
  40    ------------------------------
  41    -- Use of Pragma Unsuppress --
  42    ------------------------------
  43
  44    --  This implementation of Calendar takes advantage of the permission in
  45    --  Ada 95 of using arithmetic overflow checks to check for out of bounds
  46    --  time values. This means that we must catch the constraint error that
  47    --  results from arithmetic overflow, so we use pragma Unsuppress to make
  48    --  sure that overflow is enabled, using software overflow checking if
  49    --  necessary. That way, compiling Calendar with options to suppress this
  50    --  checking will not affect its correctness.
  51
  52    ------------------------
  53    -- Local Declarations --
  54    ------------------------
  55
  56    Ada_Year_Min : constant := 1901;
  57    Ada_Year_Max : constant := 2099;
  58
  59    --  Some basic constants used throughout
  60
  61    function To_Relative_Time (D : Duration) return Time;
  62
  63    function To_Relative_Time (D : Duration) return Time is
  64    begin
  65       return Time (Long_Integer'Integer_Value (D) / 100);
  66    end To_Relative_Time;
  67
  68    ---------
  69    -- "+" --
  70    ---------
  71
  72    function "+" (Left : Time; Right : Duration) return Time is
  73       pragma Unsuppress (Overflow_Check);
  74    begin
  75       return (Left + To_Relative_Time (Right));
  76
  77    exception
  78       when Constraint_Error =>
  79          raise Time_Error;
  80    end "+";
  81
  82    function "+" (Left : Duration; Right : Time) return Time is
  83       pragma Unsuppress (Overflow_Check);
  84    begin
  85       return (To_Relative_Time (Left) + Right);
  86
  87    exception
  88       when Constraint_Error =>
  89          raise Time_Error;
  90    end "+";
  91
  92    ---------
  93    -- "-" --
  94    ---------
  95
  96    function "-" (Left : Time; Right : Duration)  return Time is
  97       pragma Unsuppress (Overflow_Check);
  98    begin
  99       return Left - To_Relative_Time (Right);
 100
 101    exception
 102       when Constraint_Error =>
 103          raise Time_Error;
 104    end "-";
 105
 106    function "-" (Left : Time; Right : Time) return Duration is
 107       pragma Unsuppress (Overflow_Check);
 108    begin
 109       return Duration'Fixed_Value
 110         ((Long_Integer (Left) - Long_Integer (Right)) * 100);
 111
 112    exception
 113       when Constraint_Error =>
 114          raise Time_Error;
 115    end "-";
 116
 117    ---------
 118    -- "<" --
 119    ---------
 120
 121    function "<" (Left, Right : Time) return Boolean is
 122    begin
 123       return Long_Integer (Left) < Long_Integer (Right);
 124    end "<";
 125
 126    ----------
 127    -- "<=" --
 128    ----------
 129
 130    function "<=" (Left, Right : Time) return Boolean is
 131    begin
 132       return Long_Integer (Left) <= Long_Integer (Right);
 133    end "<=";
 134
 135    ---------
 136    -- ">" --
 137    ---------
 138
 139    function ">" (Left, Right : Time) return Boolean is
 140    begin
 141       return Long_Integer (Left) > Long_Integer (Right);
 142    end ">";
 143
 144    ----------
 145    -- ">=" --
 146    ----------
 147
 148    function ">=" (Left, Right : Time) return Boolean is
 149    begin
 150       return Long_Integer (Left) >= Long_Integer (Right);
 151    end ">=";
 152
 153    -----------
 154    -- Clock --
 155    -----------
 156
 157    --  The Ada.Calendar.Clock function gets the time.
 158    --  Note that on other targets a soft-link is used to get a different clock
 159    --  depending whether tasking is used or not. On VMS this isn't needed
 160    --  since all clock calls end up using SYS$GETTIM, so call the
 161    --  OS_Primitives version for efficiency.
 162
 163    function Clock return Time is
 164    begin
 165       return Time (OSP.OS_Clock);
 166    end Clock;
 167
 168    ---------
 169    -- Day --
 170    ---------
 171
 172    function Day (Date : Time) return Day_Number is
 173       DY : Year_Number;
 174       DM : Month_Number;
 175       DD : Day_Number;
 176       DS : Day_Duration;
 177
 178    begin
 179       Split (Date, DY, DM, DD, DS);
 180       return DD;
 181    end Day;
 182
 183    -----------
 184    -- Month --
 185    -----------
 186
 187    function Month (Date : Time) return Month_Number is
 188       DY : Year_Number;
 189       DM : Month_Number;
 190       DD : Day_Number;
 191       DS : Day_Duration;
 192
 193    begin
 194       Split (Date, DY, DM, DD, DS);
 195       return DM;
 196    end Month;
 197
 198    -------------
 199    -- Seconds --
 200    -------------
 201
 202    function Seconds (Date : Time) return Day_Duration is
 203       DY : Year_Number;
 204       DM : Month_Number;
 205       DD : Day_Number;
 206       DS : Day_Duration;
 207
 208    begin
 209       Split (Date, DY, DM, DD, DS);
 210       return DS;
 211    end Seconds;
 212
 213    -----------
 214    -- Split --
 215    -----------
 216
 217    procedure Split
 218      (Date    : Time;
 219       Year    : out Year_Number;
 220       Month   : out Month_Number;
 221       Day     : out Day_Number;
 222       Seconds : out Day_Duration)
 223    is
 224       procedure Numtim (
 225         Status : out Unsigned_Longword;
 226         Timbuf : out Unsigned_Word_Array;
 227         Timadr : in  Time);
 228
 229       pragma Interface (External, Numtim);
 230
 231       pragma Import_Valued_Procedure (Numtim, "SYS$NUMTIM",
 232         (Unsigned_Longword, Unsigned_Word_Array, Time),
 233         (Value, Reference, Reference));
 234
 235       Status   : Unsigned_Longword;
 236       Timbuf   : Unsigned_Word_Array (1 .. 7);
 237
 238    begin
 239       Numtim (Status, Timbuf, Date);
 240
 241       if Status mod 2 /= 1
 242         or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max
 243       then
 244          raise Time_Error;
 245       end if;
 246
 247       Seconds
 248         := Day_Duration (Timbuf (6) + 60 * (Timbuf (5) + 60 * Timbuf (4)))
 249            + Day_Duration (Timbuf (7)) / 100.0;
 250       Day       := Integer (Timbuf (3));
 251       Month     := Integer (Timbuf (2));
 252       Year      := Integer (Timbuf (1));
 253    end Split;
 254
 255    -------------
 256    -- Time_Of --
 257    -------------
 258
 259    function Time_Of
 260      (Year    : Year_Number;
 261       Month   : Month_Number;
 262       Day     : Day_Number;
 263       Seconds : Day_Duration := 0.0)
 264       return    Time
 265    is
 266
 267       procedure Cvt_Vectim (
 268         Status         : out Unsigned_Longword;
 269         Input_Time     : in  Unsigned_Word_Array;
 270         Resultant_Time : out Time);
 271
 272       pragma Interface (External, Cvt_Vectim);
 273
 274       pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM",
 275         (Unsigned_Longword, Unsigned_Word_Array, Time),
 276         (Value, Reference, Reference));
 277
 278       Status      : Unsigned_Longword;
 279       Timbuf      : Unsigned_Word_Array (1 .. 7);
 280       Date        : Time;
 281       Int_Secs    : Integer;
 282       Day_Hack    : Boolean := False;
 283    begin
 284       --  The following checks are redundant with respect to the constraint
 285       --  error checks that should normally be made on parameters, but we
 286       --  decide to raise Constraint_Error in any case if bad values come
 287       --  in (as a result of checks being off in the caller, or for other
 288       --  erroneous or bounded error cases).
 289
 290       if        not Year   'Valid
 291         or else not Month  'Valid
 292         or else not Day    'Valid
 293         or else not Seconds'Valid
 294       then
 295          raise Constraint_Error;
 296       end if;
 297
 298       --  Truncate seconds value by subtracting 0.5 and rounding,
 299       --  but be careful with 0.0 since that will give -1.0 unless
 300       --  it is treated specially.
 301
 302       if Seconds > 0.0 then
 303          Int_Secs := Integer (Seconds - 0.5);
 304       else
 305          Int_Secs := Integer (Seconds);
 306       end if;
 307
 308       --  Cvt_Vectim barfs on the largest Day_Duration, so trick it by
 309       --  setting it to zero and then adding the difference after conversion.
 310
 311       if Int_Secs = 86_400 then
 312          Int_Secs := 0;
 313          Day_Hack := True;
 314          Timbuf (7) := 0;
 315       else
 316          Timbuf (7) := Unsigned_Word
 317           (100.0 * Duration (Seconds - Day_Duration (Int_Secs)));
 318          --  Cvt_Vectim accurate only to within .01 seconds
 319       end if;
 320
 321       --  Similar hack needed for 86399 and 100/100ths, since that gets
 322       --  treated as 86400 (largest Day_Duration). This can happen because
 323       --  Duration has more accuracy than VMS system time conversion calls
 324       --  can handle.
 325
 326       if Int_Secs = 86_399 and then Timbuf (7) = 100 then
 327          Int_Secs := 0;
 328          Day_Hack := True;
 329          Timbuf (7) := 0;
 330       end if;
 331
 332       Timbuf (6) := Unsigned_Word (Int_Secs mod 60);
 333       Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60);
 334       Timbuf (4) := Unsigned_Word (Int_Secs / 3600);
 335       Timbuf (3) := Unsigned_Word (Day);
 336       Timbuf (2) := Unsigned_Word (Month);
 337       Timbuf (1) := Unsigned_Word (Year);
 338
 339       Cvt_Vectim (Status, Timbuf, Date);
 340
 341       if Status mod 2 /= 1 then
 342          raise Time_Error;
 343       end if;
 344
 345       if Day_Hack then
 346          Date := Date + 10_000_000 * 86_400;
 347       end if;
 348
 349       return Date;
 350
 351    end Time_Of;
 352
 353    ----------
 354    -- Year --
 355    ----------
 356
 357    function Year (Date : Time) return Year_Number is
 358       DY : Year_Number;
 359       DM : Month_Number;
 360       DD : Day_Number;
 361       DS : Day_Duration;
 362
 363    begin
 364       Split (Date, DY, DM, DD, DS);
 365       return DY;
 366    end Year;
 367
 368 end Ada.Calendar;