1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . C A L E N D A R --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the Alpha/VMS version
36 with System
.Aux_DEC
; use System
.Aux_DEC
;
38 package body Ada
.Calendar
is
40 ------------------------------
41 -- Use of Pragma Unsuppress --
42 ------------------------------
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.
52 ------------------------
53 -- Local Declarations --
54 ------------------------
56 Ada_Year_Min
: constant := 1901;
57 Ada_Year_Max
: constant := 2099;
59 -- Some basic constants used throughout
61 function To_Relative_Time
(D
: Duration) return Time
;
63 function To_Relative_Time
(D
: Duration) return Time
is
65 return Time
(Long_Integer'Integer_Value (D
) / 100);
72 function "+" (Left
: Time
; Right
: Duration) return Time
is
73 pragma Unsuppress
(Overflow_Check
);
75 return (Left
+ To_Relative_Time
(Right
));
78 when Constraint_Error
=>
82 function "+" (Left
: Duration; Right
: Time
) return Time
is
83 pragma Unsuppress
(Overflow_Check
);
85 return (To_Relative_Time
(Left
) + Right
);
88 when Constraint_Error
=>
96 function "-" (Left
: Time
; Right
: Duration) return Time
is
97 pragma Unsuppress
(Overflow_Check
);
99 return Left
- To_Relative_Time
(Right
);
102 when Constraint_Error
=>
106 function "-" (Left
: Time
; Right
: Time
) return Duration is
107 pragma Unsuppress
(Overflow_Check
);
109 return Duration'Fixed_Value
110 ((Long_Integer (Left
) - Long_Integer (Right
)) * 100);
113 when Constraint_Error
=>
121 function "<" (Left
, Right
: Time
) return Boolean is
123 return Long_Integer (Left
) < Long_Integer (Right
);
130 function "<=" (Left
, Right
: Time
) return Boolean is
132 return Long_Integer (Left
) <= Long_Integer (Right
);
139 function ">" (Left
, Right
: Time
) return Boolean is
141 return Long_Integer (Left
) > Long_Integer (Right
);
148 function ">=" (Left
, Right
: Time
) return Boolean is
150 return Long_Integer (Left
) >= Long_Integer (Right
);
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.
163 function Clock
return Time
is
165 return Time
(OSP
.OS_Clock
);
172 function Day
(Date
: Time
) return Day_Number
is
179 Split
(Date
, DY
, DM
, DD
, DS
);
187 function Month
(Date
: Time
) return Month_Number
is
194 Split
(Date
, DY
, DM
, DD
, DS
);
202 function Seconds
(Date
: Time
) return Day_Duration
is
209 Split
(Date
, DY
, DM
, DD
, DS
);
219 Year
: out Year_Number
;
220 Month
: out Month_Number
;
221 Day
: out Day_Number
;
222 Seconds
: out Day_Duration
)
225 Status
: out Unsigned_Longword
;
226 Timbuf
: out Unsigned_Word_Array
;
229 pragma Interface
(External
, Numtim
);
231 pragma Import_Valued_Procedure
(Numtim
, "SYS$NUMTIM",
232 (Unsigned_Longword
, Unsigned_Word_Array
, Time
),
233 (Value
, Reference
, Reference
));
235 Status
: Unsigned_Longword
;
236 Timbuf
: Unsigned_Word_Array
(1 .. 7);
238 Subsecs
: constant Time
:= Date
mod 10_000_000
;
239 Date_Secs
: constant Time
:= Date
- Subsecs
;
242 Numtim
(Status
, Timbuf
, Date_Secs
);
245 or else Timbuf
(1) not in Ada_Year_Min
.. Ada_Year_Max
250 Seconds
:= Day_Duration
(Timbuf
(6)
251 + 60 * (Timbuf
(5) + 60 * Timbuf
(4)))
252 + Duration (Subsecs
) / 10_000_000
.0
;
254 Day
:= Integer (Timbuf
(3));
255 Month
:= Integer (Timbuf
(2));
256 Year
:= Integer (Timbuf
(1));
259 -----------------------
260 -- Split_With_Offset --
261 -----------------------
263 procedure Split_With_Offset
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)
273 end Split_With_Offset
;
281 Month
: Month_Number
;
283 Seconds
: Day_Duration
:= 0.0)
287 procedure Cvt_Vectim
(
288 Status
: out Unsigned_Longword
;
289 Input_Time
: Unsigned_Word_Array
;
290 Resultant_Time
: out Time
);
292 pragma Interface
(External
, Cvt_Vectim
);
294 pragma Import_Valued_Procedure
(Cvt_Vectim
, "LIB$CVT_VECTIM",
295 (Unsigned_Longword
, Unsigned_Word_Array
, Time
),
296 (Value
, Reference
, Reference
));
298 Status
: Unsigned_Longword
;
299 Timbuf
: Unsigned_Word_Array
(1 .. 7);
302 Day_Hack
: Boolean := False;
303 Subsecs
: Day_Duration
;
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).
313 or else not Month 'Valid
314 or else not Day
'Valid
315 or else not Seconds'Valid
317 raise Constraint_Error;
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.
324 if Seconds > 0.0 then
325 Int_Secs := Integer (Seconds - 0.5);
327 Int_Secs := Integer (Seconds);
330 Subsecs := Seconds - Day_Duration (Int_Secs);
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.
335 if Int_Secs = 86_400 then
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);
348 Cvt_Vectim (Status, Timbuf, Date);
350 if Status mod 2 /= 1 then
355 Date := Date + 10_000_000 * 86_400;
358 Date := Date + Time (10_000_000.0 * Subsecs);
366 function Year (Date : Time) return Year_Number is
373 Split (Date, DY, DM, DD, DS);
381 -- The package that is used by the Ada 2005 children of Ada.Calendar:
382 -- Ada.Calendar.Arithmetic and Ada.Calendar.Formatting.
384 package body Leap_Sec_Ops is
386 --------------------------
387 -- Cumulative_Leap_Secs --
388 --------------------------
390 procedure Cumulative_Leap_Secs
393 Leaps_Between : out Duration;
394 Next_Leap_Sec : out Time)
398 end Cumulative_Leap_Secs;
400 ----------------------
401 -- All_Leap_Seconds --
402 ----------------------
404 function All_Leap_Seconds return Duration is
408 end All_Leap_Seconds;
410 -- Start of processing in package Leap_Sec_Ops