File : a-calend-cert.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) 2004-2015, AdaCore --
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 3, 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is the rts-cert version of this package
33
34 with Interfaces.C; use Interfaces.C;
35 with Ada.Unchecked_Conversion;
36
37 package body Ada.Calendar with
38 SPARK_Mode => Off
39 is
40
41 ------------------------
42 -- Local Declarations --
43 ------------------------
44
45 Secs_Per_Day : constant := 86_400.0;
46 -- Number of seconds in a day
47
48 Radix_Time : Time;
49 -- This is the zero point for time values. Time_Of returns 1 Jan 1970,
50 -- 0 UTC for this value. The time at which the board boots is given this
51 -- conventional Time value. The BSP can adjust the initial real time
52 -- relative to this value.
53
54 -- Julian day range covers Ada.Time range requirement with smallest
55 -- possible delta within 64 bits. This type is used for calculations that
56 -- do not need to preserve the precision of type Duration and that need a
57 -- larger Julian Day range than the Modified Julian Day provides, because
58 -- of the algorithms used
59
60 type Julian_Day is
61 delta Duration'Small / (86_400.0 / 2.0 ** 5)
62 range 2415_385.5 .. 2488_069.5;
63 for Julian_Day'Small use Duration'Small / (86_400.0 / 2.0 ** 5);
64
65 function Trunc (Arg : Time) return Integer;
66 -- Truncate Time
67
68 function Trunc (Arg : Duration) return Integer;
69 -- Truncate Duration
70
71 function Trunc (Arg : Julian_Day'Base) return Integer;
72 -- Truncate Julian Day
73
74 function Valid_Date
75 (D : Day_Number;
76 M : Month_Number;
77 Y : Year_Number) return Boolean;
78 -- Check for valid Gregorian calendar date
79
80 ---------
81 -- "+" --
82 ---------
83
84 function "+" (Left : Time; Right : Duration) return Time is
85 pragma Unsuppress (Overflow_Check, Time);
86 Result : Time;
87 begin
88 Result := Left + Time (Right / Secs_Per_Day);
89 return Result;
90 exception
91 when Constraint_Error =>
92 raise Time_Error;
93 end "+";
94
95 function "+" (Left : Duration; Right : Time) return Time is
96 pragma Unsuppress (Overflow_Check, Time);
97 Result : Time;
98 begin
99 Result := Time (Left / Secs_Per_Day) + Right;
100 return Result;
101 exception
102 when Constraint_Error =>
103 raise Time_Error;
104 end "+";
105
106 ---------
107 -- "-" --
108 ---------
109
110 function "-" (Left : Time; Right : Duration) return Time is
111 pragma Unsuppress (Overflow_Check, Time);
112 Result : Time;
113 begin
114 Result := Left - Time (Right / Secs_Per_Day);
115 return Result;
116 exception
117 when Constraint_Error =>
118 raise Time_Error;
119 end "-";
120
121 function "-" (Left : Time; Right : Time) return Duration is
122 pragma Unsuppress (Overflow_Check, Time);
123 Temp : Time;
124 Result : Duration;
125 begin
126 Temp := Left - Right;
127 Result := Duration (Secs_Per_Day * Temp);
128 return Result;
129 exception
130 when Constraint_Error =>
131 raise Time_Error;
132 end "-";
133
134 ---------
135 -- "<" --
136 ---------
137
138 function "<" (Left, Right : Time) return Boolean is
139 use type Modified_Julian_Day;
140 begin
141 return Modified_Julian_Day (Left) < Modified_Julian_Day (Right);
142 end "<";
143
144 ----------
145 -- "<=" --
146 ----------
147
148 function "<=" (Left, Right : Time) return Boolean is
149 use type Modified_Julian_Day;
150 begin
151 return Modified_Julian_Day (Left) <= Modified_Julian_Day (Right);
152 end "<=";
153
154 ---------
155 -- ">" --
156 ---------
157
158 function ">" (Left, Right : Time) return Boolean is
159 use type Modified_Julian_Day;
160 begin
161 return Modified_Julian_Day (Left) > Modified_Julian_Day (Right);
162 end ">";
163
164 ----------
165 -- ">=" --
166 ----------
167
168 function ">=" (Left, Right : Time) return Boolean is
169 use type Modified_Julian_Day;
170 begin
171 return Modified_Julian_Day (Left) >= Modified_Julian_Day (Right);
172 end ">=";
173
174 -----------
175 -- Clock --
176 -----------
177
178 function Clock return Time is separate;
179
180 ---------
181 -- Day --
182 ---------
183
184 function Day (Date : Time) return Day_Number is
185 DY : Year_Number;
186 DM : Month_Number;
187 DD : Day_Number;
188 DS : Day_Duration;
189 begin
190 Split (Date, DY, DM, DD, DS);
191 return DD;
192 end Day;
193
194 -----------
195 -- Month --
196 -----------
197
198 function Month (Date : Time) return Month_Number is
199 DY : Year_Number;
200 DM : Month_Number;
201 DD : Day_Number;
202 DS : Day_Duration;
203 begin
204 Split (Date, DY, DM, DD, DS);
205 return DM;
206 end Month;
207
208 -------------
209 -- Seconds --
210 -------------
211
212 function Seconds (Date : Time) return Day_Duration is
213 DY : Year_Number;
214 DM : Month_Number;
215 DD : Day_Number;
216 DS : Day_Duration;
217 begin
218 Split (Date, DY, DM, DD, DS);
219 return DS;
220 end Seconds;
221
222 -----------
223 -- Split --
224 -----------
225
226 procedure Split
227 (Date : Time;
228 Year : out Year_Number;
229 Month : out Month_Number;
230 Day : out Day_Number;
231 Seconds : out Day_Duration)
232 is
233 -- Algorithm is the standard astronomical one for conversion
234 -- from a Julian Day number to the Gregorian calendar date.
235 -- Adapted from J. Meeus' "Astronomical Algorithms" pp 63 - 4.
236
237 -- No need to check for Trunc (Date) < 2299_161 (Ada "Time" is
238 -- always a Gregorian date).
239
240 -- Split off fractional part before losing precision:
241
242 F : constant Time := Date - Time (Trunc (Date));
243
244 -- Do remainder of calcs on full Julian day number with less precision
245 -- in fractional part (not necessary for these calcs)
246
247 JD_Date : constant Julian_Day :=
248 Julian_Day'Base (Date) +
249 Julian_Day'Base'(240_0000.5);
250
251 Z : constant Integer := Trunc (JD_Date + Julian_Day'Base (0.5));
252
253 A, B, C, D, E : Integer;
254
255 Alpha : constant Integer :=
256 Trunc
257 (Julian_Day'Base
258 ((Julian_Day'Base (Z) -
259 Julian_Day'Base'(1867_216.25)) /
260 Julian_Day'Base'(36524.25)));
261
262 begin
263 -- Generate intermediate values
264
265 A := Z + 1 + Alpha - Alpha / 4;
266 B := A + 1524;
267 C := Trunc (Julian_Day'Base
268 ((Julian_Day'Base (B) - Julian_Day'Base'(122.1))
269 / Julian_Day'Base'(365.25)));
270 D := Trunc (Julian_Day'Base
271 (Julian_Day'Base'(365.25) * Julian_Day'Base (C)));
272 E := Trunc (Duration (Duration (B - D) / 30.6001));
273
274 -- Generate results from intermediate values
275
276 Month := E - (if E < 14 then 1 else 13);
277 Year := C - (if Month > 2 then 4716 else 4715);
278 Day := B - D - Trunc (Duration (30.6001 * Duration (E)));
279
280 -- Restore seconds from precise fractional part
281
282 Seconds := Day_Duration (86_400.0 * F);
283 end Split;
284
285 -------------
286 -- Time_Of --
287 -------------
288
289 function Time_Of
290 (Year : Year_Number;
291 Month : Month_Number;
292 Day : Day_Number;
293 Seconds : Day_Duration := 0.0) return Time
294 is
295 -- This is an adaptation of the standard astronomical algorithm for
296 -- conversion from a Gregorian calendar date to a Julian day number.
297 -- Taken from J. Meeus' "Astronomical Algorithms" pp 60 - 1.
298
299 Month_Num : Natural := Month;
300 Year_Num : Integer := Year;
301 A, B : Integer;
302
303 type Day_Type is delta Modified_Julian_Day'Delta range 0.0 .. 32.0;
304 for Day_Type'Small use Modified_Julian_Day'Small;
305
306 Day_Val : constant Day_Type :=
307 Day_Type (Day) + Day_Type (Seconds / Secs_Per_Day);
308
309 subtype Month_Fixed is Duration range 4.0 .. 15.0;
310
311 begin
312 -- Check for valid date
313
314 if not Valid_Date (Day, Month, Year) then
315 raise Time_Error;
316 end if;
317
318 if Month_Num <= 2 then
319 Year_Num := Year_Num - 1;
320 Month_Num := Month_Num + 12;
321 end if;
322
323 A := Year_Num / 100;
324 B := 2 - A + A / 4;
325
326 return Time'Base (Day_Val)
327 + Time
328 (Julian_Day'Base
329 (
330 (B
331 + Trunc (Duration (30.6001 * Month_Fixed (Month_Num + 1)))
332 + Trunc (Julian_Day'Base (Julian_Day'Base'(365.25)
333 * Julian_Day'Base (Year_Num + 4716)))))
334 - Julian_Day'Base'(1524.5) - Julian_Day'Base'(240_0000.5));
335 end Time_Of;
336
337 -----------
338 -- Trunc --
339 -----------
340
341 function Trunc (Arg : Time) return Integer is
342 Rounded : constant Integer := Integer (Arg);
343 Sign : constant Integer := Rounded / abs (Rounded);
344 begin
345 if abs (Time (Rounded)) > abs (Arg) then
346 return Rounded - Sign;
347 else
348 return Rounded;
349 end if;
350 end Trunc;
351
352 function Trunc (Arg : Duration) return Integer is
353 Rounded : constant Integer := Integer (Arg);
354 begin
355 if Rounded = 0 or else abs (Duration (Rounded)) <= abs (Arg) then
356 return Rounded;
357 else
358 return Rounded - Rounded / abs (Rounded);
359 end if;
360 end Trunc;
361
362 function Trunc (Arg : Julian_Day'Base) return Integer is
363 Rounded : constant Integer := Integer (Arg);
364 begin
365 if Rounded = 0 or else abs (Julian_Day'Base (Rounded)) <= abs (Arg) then
366 return Rounded;
367 else
368 return Rounded - Rounded / abs (Rounded);
369 end if;
370 end Trunc;
371
372 ----------------
373 -- Valid_Date --
374 ----------------
375
376 function Valid_Date
377 (D : Day_Number;
378 M : Month_Number;
379 Y : Year_Number) return Boolean
380 is
381 begin
382 -- Check that input values have valid representations. This check is not
383 -- strictly required, since the only way we could fail this test is if
384 -- the Time_Of caller suppressed checks, in which case we have erroneous
385 -- execution. However, raising Time_Error in this case seems a friendly
386 -- way to handle the erroneous action.
387
388 if not (Y'Valid and then M'Valid and then D'Valid) then
389 return False;
390 end if;
391
392 -- Deal with checking day according to month
393
394 case M is
395 when 4 | 6 | 9 | 11 =>
396
397 -- Apr | Jun | Sep | Nov
398
399 return D <= 30;
400
401 -- Note: lower bound OK due to 'Valid. Lower bound check would be
402 -- optimized away anyway, and resulted in a compilation warning.
403
404 when 2 =>
405
406 -- Feb
407
408 -- Do leap year check. Note that we do not need to check centuries
409 -- due to the limited range of Year_Number.
410
411 if Y mod 4 = 0 then
412 return D <= 29;
413
414 -- Note: lower bound OK due to 'Valid
415 else
416 return D <= 28;
417
418 -- Note: lower bound OK due to 'Valid
419 end if;
420
421 when 1 | 3 | 5 | 7 | 8 | 10 | 12 =>
422
423 -- Jan | Mar | May | Jul | Aug | Oct | Dec
424
425 return True;
426 end case;
427 end Valid_Date;
428
429 ----------
430 -- Year --
431 ----------
432
433 function Year (Date : Time) return Year_Number is
434 DY : Year_Number;
435 DM : Month_Number;
436 DD : Day_Number;
437 DS : Day_Duration;
438 begin
439 Split (Date, DY, DM, DD, DS);
440 return DY;
441 end Year;
442
443 -- Start of elaboration code for Ada.Calendar
444
445 begin
446 Radix_Time := Time_Of (1970, 1, 1, 0.0);
447
448 end Ada.Calendar;