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