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