1 /* Implementation of the DATE_AND_TIME intrinsic.
2 Copyright (C) 2003-2024 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher.
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
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
39 /* If _POSIX is defined gmtime_r gets defined by mingw-w64 headers. */
45 gmtime_r (const time_t * timep
, struct tm
* result
)
47 *result
= *gmtime (timep
);
53 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
55 Description: Returns data on the real-time clock and date in a form
56 compatible with the representations defined in ISO 8601:1988.
58 Class: Non-elemental subroutine.
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.
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
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.
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:
86 VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
89 VALUES(2) the month of the year, or -HUGE(0) if there
92 VALUES(3) the day of the month, or -HUGE(0) if there is no date
95 VALUES(4) the time difference with respect to Coordinated
96 Universal Time (UTC) in minutes, or -HUGE(0) if this information
99 VALUES(5) the hour of the day, in the range of 0 to 23, or
100 -HUGE(0) if there is no clock;
102 VALUES(6) the minutes of the hour, in the range 0 to 59, or
103 -HUGE(0) if there is no clock;
105 VALUES(7) the seconds of the minute, in the range 0 to 60, or
106 -HUGE(0) if there is no clock;
108 VALUES(8) the milliseconds of the second, in the range 0 to
109 999, or -HUGE(0) if there is no clock.
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).
115 Based on libU77's date_time_.c.
120 #define VALUES_SIZE 8
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
);
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
)
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
];
138 struct tm local_time
;
143 if (!gf_gettime (<
, &usecs
))
145 values
[7] = usecs
/ 1000;
147 localtime_r (<
, &local_time
);
148 gmtime_r (<
, &UTC_time
);
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
;
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
161 delta_day
= local_time
.tm_yday
- UTC_time
.tm_yday
;
164 else if (delta_day
> 1)
167 values
[3] = local_time
.tm_min
- UTC_time
.tm_min
168 + 60 * (local_time
.tm_hour
- UTC_time
.tm_hour
+ 24 * delta_day
);
170 values
[4] = local_time
.tm_hour
;
171 values
[5] = local_time
.tm_min
;
172 values
[6] = local_time
.tm_sec
;
175 snprintf (date
, DATE_LEN
+ 1, "%04d%02d%02d",
176 values
[0], values
[1], values
[2]);
178 snprintf (timec
, TIME_LEN
+ 1, "%02d%02d%02d.%03d",
179 values
[4], values
[5], values
[6], values
[7]);
182 snprintf (zone
, ZONE_LEN
+ 1, "%+03d%02d",
183 values
[3] / 60, abs (values
[3] % 60));
187 memset (date
, ' ', DATE_LEN
);
188 date
[DATE_LEN
] = '\0';
190 memset (timec
, ' ', TIME_LEN
);
191 timec
[TIME_LEN
] = '\0';
193 memset (zone
, ' ', ZONE_LEN
);
194 zone
[ZONE_LEN
] = '\0';
196 for (i
= 0; i
< VALUES_SIZE
; i
++)
197 values
[i
] = - GFC_INTEGER_4_HUGE
;
200 /* Copy the values into the arguments. */
203 index_type len
, delta
, elt_size
;
205 elt_size
= GFC_DESCRIPTOR_SIZE (__values
);
206 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
207 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
211 if (unlikely (len
< VALUES_SIZE
))
212 runtime_error ("Incorrect extent in VALUES argument to"
213 " DATE_AND_TIME intrinsic: is %ld, should"
214 " be >=%ld", (long int) len
, (long int) VALUES_SIZE
);
216 /* Cope with different type kinds. */
219 GFC_INTEGER_4
*vptr4
= __values
->base_addr
;
221 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr4
+= delta
)
224 else if (elt_size
== 8)
226 GFC_INTEGER_8
*vptr8
= (GFC_INTEGER_8
*)__values
->base_addr
;
228 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr8
+= delta
)
230 if (values
[i
] == - GFC_INTEGER_4_HUGE
)
231 *vptr8
= - GFC_INTEGER_8_HUGE
;
236 else if (elt_size
== 2)
238 GFC_INTEGER_2
*vptr2
= (GFC_INTEGER_2
*)__values
->base_addr
;
240 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr2
+= delta
)
242 if (values
[i
] == - GFC_INTEGER_4_HUGE
)
243 *vptr2
= - GFC_INTEGER_2_HUGE
;
245 *vptr2
= (GFC_INTEGER_2
) values
[i
];
248 #if defined (HAVE_GFC_INTEGER_16)
249 else if (elt_size
== 16)
251 GFC_INTEGER_16
*vptr16
= (GFC_INTEGER_16
*)__values
->base_addr
;
253 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr16
+= delta
)
255 if (values
[i
] == - GFC_INTEGER_4_HUGE
)
256 *vptr16
= - GFC_INTEGER_16_HUGE
;
267 fstrcpy (__zone
, __zone_len
, zone
, ZONE_LEN
);
270 fstrcpy (__time
, __time_len
, timec
, TIME_LEN
);
273 fstrcpy (__date
, __date_len
, date
, DATE_LEN
);
277 /* SECNDS (X) - Non-standard
279 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
282 Class: Non-elemental subroutine.
286 X must be REAL(4) and the result is of the same type. The accuracy is system
293 yields the time in elapsed seconds since X. If X is 0.0, T is the time in
294 seconds since midnight. Note that a time that spans midnight but is less than
295 24hours will be calculated correctly. */
297 extern GFC_REAL_4
secnds (GFC_REAL_4
*);
298 export_proto(secnds
);
301 secnds (GFC_REAL_4
*x
)
303 GFC_INTEGER_4 values
[VALUES_SIZE
];
304 GFC_REAL_4 temp1
, temp2
;
306 /* Make the INTEGER*4 array for passing to date_and_time, with enough space
307 for a rank-one array. */
308 gfc_array_i4
*avalues
= xmalloc (sizeof (gfc_array_i4
)
309 + sizeof (descriptor_dimension
));
310 avalues
->base_addr
= &values
[0];
311 GFC_DESCRIPTOR_DTYPE (avalues
).type
= BT_REAL
;
312 GFC_DESCRIPTOR_DTYPE (avalues
).elem_len
= 4;
313 GFC_DESCRIPTOR_DTYPE (avalues
).rank
= 1;
314 GFC_DIMENSION_SET(avalues
->dim
[0], 0, 7, 1);
316 date_and_time (NULL
, NULL
, NULL
, avalues
, 0, 0, 0);
320 temp1
= 3600.0 * (GFC_REAL_4
)values
[4] +
321 60.0 * (GFC_REAL_4
)values
[5] +
322 (GFC_REAL_4
)values
[6] +
323 0.001 * (GFC_REAL_4
)values
[7];
324 temp2
= fmod (*x
, 86400.0);
325 temp2
= (temp1
- temp2
>= 0.0) ? temp2
: (temp2
- 86400.0);
326 return temp1
- temp2
;
331 /* ITIME(X) - Non-standard
333 Description: Returns the current local time hour, minutes, and seconds
334 in elements 1, 2, and 3 of X, respectively. */
340 struct tm local_time
;
344 if (lt
!= (time_t) -1)
346 localtime_r (<
, &local_time
);
348 x
[0] = local_time
.tm_hour
;
349 x
[1] = local_time
.tm_min
;
350 x
[2] = local_time
.tm_sec
;
354 extern void itime_i4 (gfc_array_i4
*);
355 export_proto(itime_i4
);
358 itime_i4 (gfc_array_i4
*__values
)
361 index_type len
, delta
;
364 /* Call helper function. */
367 /* Copy the value into the array. */
368 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
370 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
374 vptr
= __values
->base_addr
;
375 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
380 extern void itime_i8 (gfc_array_i8
*);
381 export_proto(itime_i8
);
384 itime_i8 (gfc_array_i8
*__values
)
387 index_type len
, delta
;
390 /* Call helper function. */
393 /* Copy the value into the array. */
394 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
396 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
400 vptr
= __values
->base_addr
;
401 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
407 /* IDATE(X) - Non-standard
409 Description: Fills TArray with the numerical values at the current
410 local time. The day (in the range 1-31), month (in the range 1-12),
411 and year appear in elements 1, 2, and 3 of X, respectively.
412 The year has four significant digits. */
418 struct tm local_time
;
422 if (lt
!= (time_t) -1)
424 localtime_r (<
, &local_time
);
426 x
[0] = local_time
.tm_mday
;
427 x
[1] = 1 + local_time
.tm_mon
;
428 x
[2] = 1900 + local_time
.tm_year
;
432 extern void idate_i4 (gfc_array_i4
*);
433 export_proto(idate_i4
);
436 idate_i4 (gfc_array_i4
*__values
)
439 index_type len
, delta
;
442 /* Call helper function. */
445 /* Copy the value into the array. */
446 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
448 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
452 vptr
= __values
->base_addr
;
453 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
458 extern void idate_i8 (gfc_array_i8
*);
459 export_proto(idate_i8
);
462 idate_i8 (gfc_array_i8
*__values
)
465 index_type len
, delta
;
468 /* Call helper function. */
471 /* Copy the value into the array. */
472 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
474 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
478 vptr
= __values
->base_addr
;
479 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
485 /* GMTIME(STIME, TARRAY) - Non-standard
487 Description: Given a system time value STime, fills TArray with values
488 extracted from it appropriate to the GMT time zone using gmtime_r(3).
490 The array elements are as follows:
492 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
493 2. Minutes after the hour, range 0-59
494 3. Hours past midnight, range 0-23
495 4. Day of month, range 1-31
496 5. Number of months since January, range 0-11
498 7. Number of days since Sunday, range 0-6
499 8. Days since January 1, range 0-365
500 9. Daylight savings indicator: positive if daylight savings is in effect,
501 zero if not, and negative if the information isn't available. */
504 gmtime_0 (const time_t * t
, int x
[9])
520 extern void gmtime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
521 export_proto(gmtime_i4
);
524 gmtime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
527 index_type len
, delta
;
531 /* Call helper function. */
535 /* Copy the values into the array. */
536 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
538 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
542 vptr
= tarray
->base_addr
;
543 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
547 extern void gmtime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
548 export_proto(gmtime_i8
);
551 gmtime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
554 index_type len
, delta
;
558 /* Call helper function. */
562 /* Copy the values into the array. */
563 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
565 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
569 vptr
= tarray
->base_addr
;
570 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
577 /* LTIME(STIME, TARRAY) - Non-standard
579 Description: Given a system time value STime, fills TArray with values
580 extracted from it appropriate to the local time zone using localtime_r(3).
582 The array elements are as follows:
584 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
585 2. Minutes after the hour, range 0-59
586 3. Hours past midnight, range 0-23
587 4. Day of month, range 1-31
588 5. Number of months since January, range 0-11
590 7. Number of days since Sunday, range 0-6
591 8. Days since January 1, range 0-365
592 9. Daylight savings indicator: positive if daylight savings is in effect,
593 zero if not, and negative if the information isn't available. */
596 ltime_0 (const time_t * t
, int x
[9])
600 localtime_r (t
, <
);
612 extern void ltime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
613 export_proto(ltime_i4
);
616 ltime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
619 index_type len
, delta
;
623 /* Call helper function. */
627 /* Copy the values into the array. */
628 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
630 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
634 vptr
= tarray
->base_addr
;
635 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
639 extern void ltime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
640 export_proto(ltime_i8
);
643 ltime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
646 index_type len
, delta
;
650 /* Call helper function. */
654 /* Copy the values into the array. */
655 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
657 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
661 vptr
= tarray
->base_addr
;
662 for (i
= 0; i
< 9; i
++, vptr
+= delta
)