1 /* Implementation of the DATE_AND_TIME intrinsic.
2 Copyright (C) 2003-2023 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher.
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #include "libgfortran.h"
27 #include <string.h>
28 #include <assert.h>
29
30 #include "time_1.h"
31
32
33 /* If the re-entrant version of gmtime is not available, provide a
34 fallback implementation. On some targets where the _r version is
35 not available, gmtime uses thread-local storage so it's
36 threadsafe. */
37
38 #ifndef HAVE_GMTIME_R
39 /* If _POSIX is defined gmtime_r gets defined by mingw-w64 headers. */
40 #ifdef gmtime_r
41 #undef gmtime_r
42 #endif
43
44 static struct tm *
45 gmtime_r (const time_t * timep, struct tm * result)
46 {
47 *result = *gmtime (timep);
48 return result;
49 }
50 #endif
51
52
53 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
54
55 Description: Returns data on the real-time clock and date in a form
56 compatible with the representations defined in ISO 8601:1988.
57
58 Class: Non-elemental subroutine.
59
60 Arguments:
61
62 DATE (optional) shall be scalar and of type default character.
63 It is an INTENT(OUT) argument. It is assigned a value of the
64 form CCYYMMDD, where CC is the century, YY the year within the
65 century, MM the month within the year, and DD the day within the
66 month. If there is no date available, they are assigned blanks.
67
68 TIME (optional) shall be scalar and of type default character.
69 It is an INTENT(OUT) argument. It is assigned a value of the
70 form hhmmss.sss, where hh is the hour of the day, mm is the
71 minutes of the hour, and ss.sss is the seconds and milliseconds
72 of the minute. If there is no clock available, they are assigned
73 blanks.
74
75 ZONE (optional) shall be scalar and of type default character.
76 It is an INTENT(OUT) argument. It is assigned a value of the
77 form [+-]hhmm, where hh and mm are the time difference with
78 respect to Coordinated Universal Time (UTC) in hours and parts
79 of an hour expressed in minutes, respectively. If there is no
80 clock available, they are assigned blanks.
81
82 VALUES (optional) shall be of type default integer and of rank
83 one. It is an INTENT(OUT) argument. Its size shall be at least
84 8. The values returned in VALUES are as follows:
85
86 VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
87 no date available;
88
89 VALUES(2) the month of the year, or -HUGE(0) if there
90 is no date available;
91
92 VALUES(3) the day of the month, or -HUGE(0) if there is no date
93 available;
94
95 VALUES(4) the time difference with respect to Coordinated
96 Universal Time (UTC) in minutes, or -HUGE(0) if this information
97 is not available;
98
99 VALUES(5) the hour of the day, in the range of 0 to 23, or
100 -HUGE(0) if there is no clock;
101
102 VALUES(6) the minutes of the hour, in the range 0 to 59, or
103 -HUGE(0) if there is no clock;
104
105 VALUES(7) the seconds of the minute, in the range 0 to 60, or
106 -HUGE(0) if there is no clock;
107
108 VALUES(8) the milliseconds of the second, in the range 0 to
109 999, or -HUGE(0) if there is no clock.
110
111 NULL pointer represent missing OPTIONAL arguments. All arguments
112 have INTENT(OUT). Because of the -i8 option, we must implement
113 VALUES for INTEGER(kind=4) and INTEGER(kind=8).
114
115 Based on libU77's date_time_.c.
116 */
117 #define DATE_LEN 8
118 #define TIME_LEN 10
119 #define ZONE_LEN 5
120 #define VALUES_SIZE 8
121
122 extern void date_and_time (char *, char *, char *, gfc_array_i4 *,
123 GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
124 export_proto(date_and_time);
125
126 void
127 date_and_time (char *__date, char *__time, char *__zone,
128 gfc_array_i4 *__values, GFC_INTEGER_4 __date_len,
129 GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len)
130 {
131 int i, delta_day;
132 char date[DATE_LEN + 1];
133 char timec[TIME_LEN + 1];
134 char zone[ZONE_LEN + 1];
135 GFC_INTEGER_4 values[VALUES_SIZE];
136
137 time_t lt;
138 struct tm local_time;
139 struct tm UTC_time;
140
141 long usecs;
142
143 if (!gf_gettime (<, &usecs))
144 {
145 values[7] = usecs / 1000;
146
147 localtime_r (<, &local_time);
148 gmtime_r (<, &UTC_time);
149
150 /* All arguments can be derived from VALUES. */
151 values[0] = 1900 + local_time.tm_year;
152 values[1] = 1 + local_time.tm_mon;
153 values[2] = local_time.tm_mday;
154
155 /* Day difference with UTC should always be -1, 0 or +1.
156 Near year boundaries, we may obtain a large positive (+364,
157 or +365 on leap years) or negative (-364, or -365 on leap years)
158 number, which we have to handle.
159 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98507
160 */
161 delta_day = local_time.tm_yday - UTC_time.tm_yday;
162 if (delta_day < -1)
163 delta_day = 1;
164 else if (delta_day > 1)
165 delta_day = -1;
166
167 values[3] = local_time.tm_min - UTC_time.tm_min
168 + 60 * (local_time.tm_hour - UTC_time.tm_hour + 24 * delta_day);
169
170 values[4] = local_time.tm_hour;
171 values[5] = local_time.tm_min;
172 values[6] = local_time.tm_sec;
173
174 if (__date)
175 snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
176 values[0], values[1], values[2]);
177 if (__time)
178 snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
179 values[4], values[5], values[6], values[7]);
180
181 if (__zone)
182 snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
183 values[3] / 60, abs (values[3] % 60));
184 }
185 else
186 {
187 memset (date, ' ', DATE_LEN);
188 date[DATE_LEN] = '\0';
189
190 memset (timec, ' ', TIME_LEN);
191 timec[TIME_LEN] = '\0';
192
193 memset (zone, ' ', ZONE_LEN);
194 zone[ZONE_LEN] = '\0';
195
196 for (i = 0; i < VALUES_SIZE; i++)
197 values[i] = - GFC_INTEGER_4_HUGE;
198 }
199
200 /* Copy the values into the arguments. */
201 if (__values)
202 {
203 index_type len, delta, elt_size;
204
205 elt_size = GFC_DESCRIPTOR_SIZE (__values);
206 len = GFC_DESCRIPTOR_EXTENT(__values,0);
207 delta = GFC_DESCRIPTOR_STRIDE(__values,0);
208 if (delta == 0)
209 delta = 1;
210
211 if (unlikely (len < VALUES_SIZE))
212 runtime_error ("Incorrect extent in VALUE argument to"
213 " DATE_AND_TIME intrinsic: is %ld, should"
214 " be >=%ld", (long int) len, (long int) VALUES_SIZE);
215
216 /* Cope with different type kinds. */
217 if (elt_size == 4)
218 {
219 GFC_INTEGER_4 *vptr4 = __values->base_addr;
220
221 for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
222 *vptr4 = values[i];
223 }
224 else if (elt_size == 8)
225 {
226 GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->base_addr;
227
228 for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
229 {
230 if (values[i] == - GFC_INTEGER_4_HUGE)
231 *vptr8 = - GFC_INTEGER_8_HUGE;
232 else
233 *vptr8 = values[i];
234 }
235 }
236 else
237 abort ();
238 }
239
240 if (__zone)
241 fstrcpy (__zone, __zone_len, zone, ZONE_LEN);
242
243 if (__time)
244 fstrcpy (__time, __time_len, timec, TIME_LEN);
245
246 if (__date)
247 fstrcpy (__date, __date_len, date, DATE_LEN);
248 }
249
250
251 /* SECNDS (X) - Non-standard
252
253 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
254 in seconds.
255
256 Class: Non-elemental subroutine.
257
258 Arguments:
259
260 X must be REAL(4) and the result is of the same type. The accuracy is system
261 dependent.
262
263 Usage:
264
265 T = SECNDS (X)
266
267 yields the time in elapsed seconds since X. If X is 0.0, T is the time in
268 seconds since midnight. Note that a time that spans midnight but is less than
269 24hours will be calculated correctly. */
270
271 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
272 export_proto(secnds);
273
274 GFC_REAL_4
275 secnds (GFC_REAL_4 *x)
276 {
277 GFC_INTEGER_4 values[VALUES_SIZE];
278 GFC_REAL_4 temp1, temp2;
279
280 /* Make the INTEGER*4 array for passing to date_and_time, with enough space
281 for a rank-one array. */
282 gfc_array_i4 *avalues = xmalloc (sizeof (gfc_array_i4)
283 + sizeof (descriptor_dimension));
284 avalues->base_addr = &values[0];
285 GFC_DESCRIPTOR_DTYPE (avalues).type = BT_REAL;
286 GFC_DESCRIPTOR_DTYPE (avalues).elem_len = 4;
287 GFC_DESCRIPTOR_DTYPE (avalues).rank = 1;
288 GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1);
289
290 date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
291
292 free (avalues);
293
294 temp1 = 3600.0 * (GFC_REAL_4)values[4] +
295 60.0 * (GFC_REAL_4)values[5] +
296 (GFC_REAL_4)values[6] +
297 0.001 * (GFC_REAL_4)values[7];
298 temp2 = fmod (*x, 86400.0);
299 temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0);
300 return temp1 - temp2;
301 }
302
303
304
305 /* ITIME(X) - Non-standard
306
307 Description: Returns the current local time hour, minutes, and seconds
308 in elements 1, 2, and 3 of X, respectively. */
309
310 static void
311 itime0 (int x[3])
312 {
313 time_t lt;
314 struct tm local_time;
315
316 lt = time (NULL);
317
318 if (lt != (time_t) -1)
319 {
320 localtime_r (<, &local_time);
321
322 x[0] = local_time.tm_hour;
323 x[1] = local_time.tm_min;
324 x[2] = local_time.tm_sec;
325 }
326 }
327
328 extern void itime_i4 (gfc_array_i4 *);
329 export_proto(itime_i4);
330
331 void
332 itime_i4 (gfc_array_i4 *__values)
333 {
334 int x[3], i;
335 index_type len, delta;
336 GFC_INTEGER_4 *vptr;
337
338 /* Call helper function. */
339 itime0(x);
340
341 /* Copy the value into the array. */
342 len = GFC_DESCRIPTOR_EXTENT(__values,0);
343 assert (len >= 3);
344 delta = GFC_DESCRIPTOR_STRIDE(__values,0);
345 if (delta == 0)
346 delta = 1;
347
348 vptr = __values->base_addr;
349 for (i = 0; i < 3; i++, vptr += delta)
350 *vptr = x[i];
351 }
352
353
354 extern void itime_i8 (gfc_array_i8 *);
355 export_proto(itime_i8);
356
357 void
358 itime_i8 (gfc_array_i8 *__values)
359 {
360 int x[3], i;
361 index_type len, delta;
362 GFC_INTEGER_8 *vptr;
363
364 /* Call helper function. */
365 itime0(x);
366
367 /* Copy the value into the array. */
368 len = GFC_DESCRIPTOR_EXTENT(__values,0);
369 assert (len >= 3);
370 delta = GFC_DESCRIPTOR_STRIDE(__values,0);
371 if (delta == 0)
372 delta = 1;
373
374 vptr = __values->base_addr;
375 for (i = 0; i < 3; i++, vptr += delta)
376 *vptr = x[i];
377 }
378
379
380
381 /* IDATE(X) - Non-standard
382
383 Description: Fills TArray with the numerical values at the current
384 local time. The day (in the range 1-31), month (in the range 1-12),
385 and year appear in elements 1, 2, and 3 of X, respectively.
386 The year has four significant digits. */
387
388 static void
389 idate0 (int x[3])
390 {
391 time_t lt;
392 struct tm local_time;
393
394 lt = time (NULL);
395
396 if (lt != (time_t) -1)
397 {
398 localtime_r (<, &local_time);
399
400 x[0] = local_time.tm_mday;
401 x[1] = 1 + local_time.tm_mon;
402 x[2] = 1900 + local_time.tm_year;
403 }
404 }
405
406 extern void idate_i4 (gfc_array_i4 *);
407 export_proto(idate_i4);
408
409 void
410 idate_i4 (gfc_array_i4 *__values)
411 {
412 int x[3], i;
413 index_type len, delta;
414 GFC_INTEGER_4 *vptr;
415
416 /* Call helper function. */
417 idate0(x);
418
419 /* Copy the value into the array. */
420 len = GFC_DESCRIPTOR_EXTENT(__values,0);
421 assert (len >= 3);
422 delta = GFC_DESCRIPTOR_STRIDE(__values,0);
423 if (delta == 0)
424 delta = 1;
425
426 vptr = __values->base_addr;
427 for (i = 0; i < 3; i++, vptr += delta)
428 *vptr = x[i];
429 }
430
431
432 extern void idate_i8 (gfc_array_i8 *);
433 export_proto(idate_i8);
434
435 void
436 idate_i8 (gfc_array_i8 *__values)
437 {
438 int x[3], i;
439 index_type len, delta;
440 GFC_INTEGER_8 *vptr;
441
442 /* Call helper function. */
443 idate0(x);
444
445 /* Copy the value into the array. */
446 len = GFC_DESCRIPTOR_EXTENT(__values,0);
447 assert (len >= 3);
448 delta = GFC_DESCRIPTOR_STRIDE(__values,0);
449 if (delta == 0)
450 delta = 1;
451
452 vptr = __values->base_addr;
453 for (i = 0; i < 3; i++, vptr += delta)
454 *vptr = x[i];
455 }
456
457
458
459 /* GMTIME(STIME, TARRAY) - Non-standard
460
461 Description: Given a system time value STime, fills TArray with values
462 extracted from it appropriate to the GMT time zone using gmtime_r(3).
463
464 The array elements are as follows:
465
466 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
467 2. Minutes after the hour, range 0-59
468 3. Hours past midnight, range 0-23
469 4. Day of month, range 1-31
470 5. Number of months since January, range 0-11
471 6. Years since 1900
472 7. Number of days since Sunday, range 0-6
473 8. Days since January 1, range 0-365
474 9. Daylight savings indicator: positive if daylight savings is in effect,
475 zero if not, and negative if the information isn't available. */
476
477 static void
478 gmtime_0 (const time_t * t, int x[9])
479 {
480 struct tm lt;
481
482 gmtime_r (t, <);
483 x[0] = lt.tm_sec;
484 x[1] = lt.tm_min;
485 x[2] = lt.tm_hour;
486 x[3] = lt.tm_mday;
487 x[4] = lt.tm_mon;
488 x[5] = lt.tm_year;
489 x[6] = lt.tm_wday;
490 x[7] = lt.tm_yday;
491 x[8] = lt.tm_isdst;
492 }
493
494 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
495 export_proto(gmtime_i4);
496
497 void
498 gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
499 {
500 int x[9], i;
501 index_type len, delta;
502 GFC_INTEGER_4 *vptr;
503 time_t tt;
504
505 /* Call helper function. */
506 tt = (time_t) *t;
507 gmtime_0(&tt, x);
508
509 /* Copy the values into the array. */
510 len = GFC_DESCRIPTOR_EXTENT(tarray,0);
511 assert (len >= 9);
512 delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
513 if (delta == 0)
514 delta = 1;
515
516 vptr = tarray->base_addr;
517 for (i = 0; i < 9; i++, vptr += delta)
518 *vptr = x[i];
519 }
520
521 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
522 export_proto(gmtime_i8);
523
524 void
525 gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
526 {
527 int x[9], i;
528 index_type len, delta;
529 GFC_INTEGER_8 *vptr;
530 time_t tt;
531
532 /* Call helper function. */
533 tt = (time_t) *t;
534 gmtime_0(&tt, x);
535
536 /* Copy the values into the array. */
537 len = GFC_DESCRIPTOR_EXTENT(tarray,0);
538 assert (len >= 9);
539 delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
540 if (delta == 0)
541 delta = 1;
542
543 vptr = tarray->base_addr;
544 for (i = 0; i < 9; i++, vptr += delta)
545 *vptr = x[i];
546 }
547
548
549
550
551 /* LTIME(STIME, TARRAY) - Non-standard
552
553 Description: Given a system time value STime, fills TArray with values
554 extracted from it appropriate to the local time zone using localtime_r(3).
555
556 The array elements are as follows:
557
558 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
559 2. Minutes after the hour, range 0-59
560 3. Hours past midnight, range 0-23
561 4. Day of month, range 1-31
562 5. Number of months since January, range 0-11
563 6. Years since 1900
564 7. Number of days since Sunday, range 0-6
565 8. Days since January 1, range 0-365
566 9. Daylight savings indicator: positive if daylight savings is in effect,
567 zero if not, and negative if the information isn't available. */
568
569 static void
570 ltime_0 (const time_t * t, int x[9])
571 {
572 struct tm lt;
573
574 localtime_r (t, <);
575 x[0] = lt.tm_sec;
576 x[1] = lt.tm_min;
577 x[2] = lt.tm_hour;
578 x[3] = lt.tm_mday;
579 x[4] = lt.tm_mon;
580 x[5] = lt.tm_year;
581 x[6] = lt.tm_wday;
582 x[7] = lt.tm_yday;
583 x[8] = lt.tm_isdst;
584 }
585
586 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
587 export_proto(ltime_i4);
588
589 void
590 ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
591 {
592 int x[9], i;
593 index_type len, delta;
594 GFC_INTEGER_4 *vptr;
595 time_t tt;
596
597 /* Call helper function. */
598 tt = (time_t) *t;
599 ltime_0(&tt, x);
600
601 /* Copy the values into the array. */
602 len = GFC_DESCRIPTOR_EXTENT(tarray,0);
603 assert (len >= 9);
604 delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
605 if (delta == 0)
606 delta = 1;
607
608 vptr = tarray->base_addr;
609 for (i = 0; i < 9; i++, vptr += delta)
610 *vptr = x[i];
611 }
612
613 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
614 export_proto(ltime_i8);
615
616 void
617 ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
618 {
619 int x[9], i;
620 index_type len, delta;
621 GFC_INTEGER_8 *vptr;
622 time_t tt;
623
624 /* Call helper function. */
625 tt = (time_t) * t;
626 ltime_0(&tt, x);
627
628 /* Copy the values into the array. */
629 len = GFC_DESCRIPTOR_EXTENT(tarray,0);
630 assert (len >= 9);
631 delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
632 if (delta == 0)
633 delta = 1;
634
635 vptr = tarray->base_addr;
636 for (i = 0; i < 9; i++, vptr += delta)
637 *vptr = x[i];
638 }
639
640