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-2006, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 : 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    -- Split_With_Offset --
 261    -----------------------
 262
 263    procedure Split_With_Offset
 264      (Date    : Time;
 265       Year    : out Year_Number;
 266       Month   : out Month_Number;
 267       Day     : out Day_Number;
 268       Seconds : out Day_Duration;
 269       Offset  : out Long_Integer)
 270    is
 271    begin
 272       raise Unimplemented;
 273    end Split_With_Offset;
 274
 275    -------------
 276    -- Time_Of --
 277    -------------
 278
 279    function Time_Of
 280      (Year    : Year_Number;
 281       Month   : Month_Number;
 282       Day     : Day_Number;
 283       Seconds : Day_Duration := 0.0)
 284       return    Time
 285    is
 286
 287       procedure Cvt_Vectim (
 288         Status         : out Unsigned_Longword;
 289         Input_Time     : Unsigned_Word_Array;
 290         Resultant_Time : out Time);
 291
 292       pragma Interface (External, Cvt_Vectim);
 293
 294       pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM",
 295         (Unsigned_Longword, Unsigned_Word_Array, Time),
 296         (Value, Reference, Reference));
 297
 298       Status      : Unsigned_Longword;
 299       Timbuf      : Unsigned_Word_Array (1 .. 7);
 300       Date        : Time;
 301       Int_Secs    : Integer;
 302       Day_Hack    : Boolean := False;
 303       Subsecs     : Day_Duration;
 304
 305    begin
 306       --  The following checks are redundant with respect to the constraint
 307       --  error checks that should normally be made on parameters, but we
 308       --  decide to raise Constraint_Error in any case if bad values come
 309       --  in (as a result of checks being off in the caller, or for other
 310       --  erroneous or bounded error cases).
 311
 312       if        not Year   'Valid
 313         or else not Month  'Valid
 314         or else not Day    'Valid
 315         or else not Seconds'Valid
 316       then
 317          raise Constraint_Error;
 318       end if;
 319
 320       --  Truncate seconds value by subtracting 0.5 and rounding,
 321       --  but be careful with 0.0 since that will give -1.0 unless
 322       --  it is treated specially.
 323
 324       if Seconds > 0.0 then
 325          Int_Secs := Integer (Seconds - 0.5);
 326       else
 327          Int_Secs := Integer (Seconds);
 328       end if;
 329
 330       Subsecs := Seconds - Day_Duration (Int_Secs);
 331
 332       --  Cvt_Vectim barfs on the largest Day_Duration, so trick it by
 333       --  setting it to zero and then adding the difference after conversion.
 334
 335       if Int_Secs = 86_400 then
 336          Int_Secs := 0;
 337          Day_Hack := True;
 338       end if;
 339
 340       Timbuf (7) := 0;
 341       Timbuf (6) := Unsigned_Word (Int_Secs mod 60);
 342       Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60);
 343       Timbuf (4) := Unsigned_Word (Int_Secs / 3600);
 344       Timbuf (3) := Unsigned_Word (Day);
 345       Timbuf (2) := Unsigned_Word (Month);
 346       Timbuf (1) := Unsigned_Word (Year);
 347
 348       Cvt_Vectim (Status, Timbuf, Date);
 349
 350       if Status mod 2 /= 1 then
 351          raise Time_Error;
 352       end if;
 353
 354       if Day_Hack then
 355          Date := Date + 10_000_000 * 86_400;
 356       end if;
 357
 358       Date := Date + Time (10_000_000.0 * Subsecs);
 359       return Date;
 360    end Time_Of;
 361
 362    ----------
 363    -- Year --
 364    ----------
 365
 366    function Year (Date : Time) return Year_Number is
 367       DY : Year_Number;
 368       DM : Month_Number;
 369       DD : Day_Number;
 370       DS : Day_Duration;
 371
 372    begin
 373       Split (Date, DY, DM, DD, DS);
 374       return DY;
 375    end Year;
 376
 377    -------------------
 378    --  Leap_Sec_Ops --
 379    -------------------
 380
 381    --  The package that is used by the Ada 2005 children of Ada.Calendar:
 382    --  Ada.Calendar.Arithmetic and Ada.Calendar.Formatting.
 383
 384    package body Leap_Sec_Ops is
 385
 386       --------------------------
 387       -- Cumulative_Leap_Secs --
 388       --------------------------
 389
 390       procedure Cumulative_Leap_Secs
 391         (Start_Date    : Time;
 392          End_Date      : Time;
 393          Leaps_Between : out Duration;
 394          Next_Leap_Sec : out Time)
 395       is
 396       begin
 397          raise Unimplemented;
 398       end Cumulative_Leap_Secs;
 399
 400       ----------------------
 401       -- All_Leap_Seconds --
 402       ----------------------
 403
 404       function All_Leap_Seconds return Duration is
 405       begin
 406          raise Unimplemented;
 407          return 0.0;
 408       end All_Leap_Seconds;
 409
 410    --  Start of processing in package Leap_Sec_Ops
 411
 412    begin
 413       null;
 414    end Leap_Sec_Ops;
 415
 416 end Ada.Calendar;