1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . C A L E N D A R --
10 -- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
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. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 -- This is the Alpha/VMS version.
37 with System
.Aux_DEC
; use System
.Aux_DEC
;
39 package body Ada
.Calendar
is
41 ------------------------------
42 -- Use of Pragma Unsuppress --
43 ------------------------------
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.
53 ------------------------
54 -- Local Declarations --
55 ------------------------
57 Ada_Year_Min
: constant := 1901;
58 Ada_Year_Max
: constant := 2099;
60 -- Some basic constants used throughout
62 function To_Relative_Time
(D
: Duration) return Time
;
64 function To_Relative_Time
(D
: Duration) return Time
is
66 return Time
(Long_Integer'Integer_Value (D
) / 100);
73 function "+" (Left
: Time
; Right
: Duration) return Time
is
74 pragma Unsuppress
(Overflow_Check
);
76 return (Left
+ To_Relative_Time
(Right
));
79 when Constraint_Error
=>
83 function "+" (Left
: Duration; Right
: Time
) return Time
is
84 pragma Unsuppress
(Overflow_Check
);
86 return (To_Relative_Time
(Left
) + Right
);
89 when Constraint_Error
=>
97 function "-" (Left
: Time
; Right
: Duration) return Time
is
98 pragma Unsuppress
(Overflow_Check
);
100 return Left
- To_Relative_Time
(Right
);
103 when Constraint_Error
=>
107 function "-" (Left
: Time
; Right
: Time
) return Duration is
108 pragma Unsuppress
(Overflow_Check
);
110 return Duration'Fixed_Value
111 ((Long_Integer (Left
) - Long_Integer (Right
)) * 100);
114 when Constraint_Error
=>
122 function "<" (Left
, Right
: Time
) return Boolean is
124 return Long_Integer (Left
) < Long_Integer (Right
);
131 function "<=" (Left
, Right
: Time
) return Boolean is
133 return Long_Integer (Left
) <= Long_Integer (Right
);
140 function ">" (Left
, Right
: Time
) return Boolean is
142 return Long_Integer (Left
) > Long_Integer (Right
);
149 function ">=" (Left
, Right
: Time
) return Boolean is
151 return Long_Integer (Left
) >= Long_Integer (Right
);
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.
164 function Clock
return Time
is
166 return Time
(OSP
.OS_Clock
);
173 function Day
(Date
: Time
) return Day_Number
is
180 Split
(Date
, DY
, DM
, DD
, DS
);
188 function Month
(Date
: Time
) return Month_Number
is
195 Split
(Date
, DY
, DM
, DD
, DS
);
203 function Seconds
(Date
: Time
) return Day_Duration
is
210 Split
(Date
, DY
, DM
, DD
, DS
);
220 Year
: out Year_Number
;
221 Month
: out Month_Number
;
222 Day
: out Day_Number
;
223 Seconds
: out Day_Duration
)
226 Status
: out Unsigned_Longword
;
227 Timbuf
: out Unsigned_Word_Array
;
230 pragma Interface
(External
, Numtim
);
232 pragma Import_Valued_Procedure
(Numtim
, "SYS$NUMTIM",
233 (Unsigned_Longword
, Unsigned_Word_Array
, Time
),
234 (Value
, Reference
, Reference
));
236 Status
: Unsigned_Longword
;
237 Timbuf
: Unsigned_Word_Array
(1 .. 7);
240 Numtim
(Status
, Timbuf
, Date
);
243 or else Timbuf
(1) not in Ada_Year_Min
.. Ada_Year_Max
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));
262 Month
: Month_Number
;
264 Seconds
: Day_Duration
:= 0.0)
268 procedure Cvt_Vectim
(
269 Status
: out Unsigned_Longword
;
270 Input_Time
: in Unsigned_Word_Array
;
271 Resultant_Time
: out Time
);
273 pragma Interface
(External
, Cvt_Vectim
);
275 pragma Import_Valued_Procedure
(Cvt_Vectim
, "LIB$CVT_VECTIM",
276 (Unsigned_Longword
, Unsigned_Word_Array
, Time
),
277 (Value
, Reference
, Reference
));
279 Status
: Unsigned_Longword
;
280 Timbuf
: Unsigned_Word_Array
(1 .. 7);
283 Day_Hack
: Boolean := False;
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).
292 or else not Month 'Valid
293 or else not Day
'Valid
294 or else not Seconds'Valid
296 raise Constraint_Error;
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.
303 if Seconds > 0.0 then
304 Int_Secs := Integer (Seconds - 0.5);
306 Int_Secs := Integer (Seconds);
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.
312 if Int_Secs = 86_400 then
317 Timbuf (7) := Unsigned_Word
318 (100.0 * Duration (Seconds - Day_Duration (Int_Secs)));
319 -- Cvt_Vectim accurate only to within .01 seconds
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
327 if Int_Secs = 86_399 and then Timbuf (7) = 100 then
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);
340 Cvt_Vectim (Status, Timbuf, Date);
342 if Status mod 2 /= 1 then
347 Date := Date + 10_000_000 * 86_400;
358 function Year (Date : Time) return Year_Number is
365 Split (Date, DY, DM, DD, DS);