gcc/ada/a-calend-vms.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-2003 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       Subsecs   : constant Time := Date mod 10_000_000;
 239       Date_Secs : constant Time := Date - Subsecs;
 240
 241    begin
 242       Numtim (Status, Timbuf, Date_Secs);
 243
 244       if Status mod 2 /= 1
 245         or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max
 246       then
 247          raise Time_Error;
 248       end if;
 249
 250       Seconds := Day_Duration (Timbuf (6)
 251                    + 60 * (Timbuf (5) + 60 * Timbuf (4)))
 252                    + Duration (Subsecs) / 10_000_000.0;
 253
 254       Day   := Integer (Timbuf (3));
 255       Month := Integer (Timbuf (2));
 256       Year  := Integer (Timbuf (1));
 257    end Split;
 258
 259    -------------
 260    -- Time_Of --
 261    -------------
 262
 263    function Time_Of
 264      (Year    : Year_Number;
 265       Month   : Month_Number;
 266       Day     : Day_Number;
 267       Seconds : Day_Duration := 0.0)
 268       return    Time
 269    is
 270
 271       procedure Cvt_Vectim (
 272         Status         : out Unsigned_Longword;
 273         Input_Time     : in  Unsigned_Word_Array;
 274         Resultant_Time : out Time);
 275
 276       pragma Interface (External, Cvt_Vectim);
 277
 278       pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM",
 279         (Unsigned_Longword, Unsigned_Word_Array, Time),
 280         (Value, Reference, Reference));
 281
 282       Status      : Unsigned_Longword;
 283       Timbuf      : Unsigned_Word_Array (1 .. 7);
 284       Date        : Time;
 285       Int_Secs    : Integer;
 286       Day_Hack    : Boolean := False;
 287       Subsecs     : Day_Duration;
 288
 289    begin
 290       --  The following checks are redundant with respect to the constraint
 291       --  error checks that should normally be made on parameters, but we
 292       --  decide to raise Constraint_Error in any case if bad values come
 293       --  in (as a result of checks being off in the caller, or for other
 294       --  erroneous or bounded error cases).
 295
 296       if        not Year   'Valid
 297         or else not Month  'Valid
 298         or else not Day    'Valid
 299         or else not Seconds'Valid
 300       then
 301          raise Constraint_Error;
 302       end if;
 303
 304       --  Truncate seconds value by subtracting 0.5 and rounding,
 305       --  but be careful with 0.0 since that will give -1.0 unless
 306       --  it is treated specially.
 307
 308       if Seconds > 0.0 then
 309          Int_Secs := Integer (Seconds - 0.5);
 310       else
 311          Int_Secs := Integer (Seconds);
 312       end if;
 313
 314       Subsecs := Seconds - Day_Duration (Int_Secs);
 315
 316       --  Cvt_Vectim barfs on the largest Day_Duration, so trick it by
 317       --  setting it to zero and then adding the difference after conversion.
 318
 319       if Int_Secs = 86_400 then
 320          Int_Secs := 0;
 321          Day_Hack := True;
 322       end if;
 323
 324       Timbuf (7) := 0;
 325       Timbuf (6) := Unsigned_Word (Int_Secs mod 60);
 326       Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60);
 327       Timbuf (4) := Unsigned_Word (Int_Secs / 3600);
 328       Timbuf (3) := Unsigned_Word (Day);
 329       Timbuf (2) := Unsigned_Word (Month);
 330       Timbuf (1) := Unsigned_Word (Year);
 331
 332       Cvt_Vectim (Status, Timbuf, Date);
 333
 334       if Status mod 2 /= 1 then
 335          raise Time_Error;
 336       end if;
 337
 338       if Day_Hack then
 339          Date := Date + 10_000_000 * 86_400;
 340       end if;
 341
 342       Date := Date + Time (10_000_000.0 * Subsecs);
 343       return Date;
 344    end Time_Of;
 345
 346    ----------
 347    -- Year --
 348    ----------
 349
 350    function Year (Date : Time) return Year_Number is
 351       DY : Year_Number;
 352       DM : Month_Number;
 353       DD : Day_Number;
 354       DS : Day_Duration;
 355
 356    begin
 357       Split (Date, DY, DM, DD, DS);
 358       return DY;
 359    end Year;
 360
 361 end Ada.Calendar;