1 /* Implementation of the DATE_AND_TIME intrinsic.
2 Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Steven Bosscher.
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
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/>. */
27 #include "libgfortran.h"
32 #undef HAVE_NO_DATE_TIME
33 #if TIME_WITH_SYS_TIME
34 # include <sys/time.h>
38 # include <sys/time.h>
43 # define HAVE_NO_DATE_TIME
44 # endif /* HAVE_TIME_H */
45 # endif /* HAVE_SYS_TIME_H */
46 #endif /* TIME_WITH_SYS_TIME */
49 #define abs(x) ((x)>=0 ? (x) : -(x))
53 /* If the re-entrant versions of localtime and gmtime are not
54 available, provide fallback implementations. On some targets where
55 the _r versions are not available, localtime and gmtime use
56 thread-local storage so they are threadsafe. */
58 #ifndef HAVE_LOCALTIME_R
59 /* If _POSIX is defined localtime_r gets defined by mingw-w64 headers. */
65 localtime_r (const time_t * timep
, struct tm
* result
)
67 *result
= *localtime (timep
);
73 /* If _POSIX is defined gmtime_r gets defined by mingw-w64 headers. */
79 gmtime_r (const time_t * timep
, struct tm
* result
)
81 *result
= *gmtime (timep
);
87 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
89 Description: Returns data on the real-time clock and date in a form
90 compatible with the representations defined in ISO 8601:1988.
92 Class: Non-elemental subroutine.
96 DATE (optional) shall be scalar and of type default character.
97 It is an INTENT(OUT) argument. It is assigned a value of the
98 form CCYYMMDD, where CC is the century, YY the year within the
99 century, MM the month within the year, and DD the day within the
100 month. If there is no date available, they are assigned blanks.
102 TIME (optional) shall be scalar and of type default character.
103 It is an INTENT(OUT) argument. It is assigned a value of the
104 form hhmmss.sss, where hh is the hour of the day, mm is the
105 minutes of the hour, and ss.sss is the seconds and milliseconds
106 of the minute. If there is no clock available, they are assigned
109 ZONE (optional) shall be scalar and of type default character.
110 It is an INTENT(OUT) argument. It is assigned a value of the
111 form [+-]hhmm, where hh and mm are the time difference with
112 respect to Coordinated Universal Time (UTC) in hours and parts
113 of an hour expressed in minutes, respectively. If there is no
114 clock available, they are assigned blanks.
116 VALUES (optional) shall be of type default integer and of rank
117 one. It is an INTENT(OUT) argument. Its size shall be at least
118 8. The values returned in VALUES are as follows:
120 VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
123 VALUES(2) the month of the year, or -HUGE(0) if there
124 is no date available;
126 VALUES(3) the day of the month, or -HUGE(0) if there is no date
129 VALUES(4) the time difference with respect to Coordinated
130 Universal Time (UTC) in minutes, or -HUGE(0) if this information
133 VALUES(5) the hour of the day, in the range of 0 to 23, or
134 -HUGE(0) if there is no clock;
136 VALUES(6) the minutes of the hour, in the range 0 to 59, or
137 -HUGE(0) if there is no clock;
139 VALUES(7) the seconds of the minute, in the range 0 to 60, or
140 -HUGE(0) if there is no clock;
142 VALUES(8) the milliseconds of the second, in the range 0 to
143 999, or -HUGE(0) if there is no clock.
145 NULL pointer represent missing OPTIONAL arguments. All arguments
146 have INTENT(OUT). Because of the -i8 option, we must implement
147 VALUES for INTEGER(kind=4) and INTEGER(kind=8).
149 Based on libU77's date_time_.c.
152 - Check year boundaries.
157 #define VALUES_SIZE 8
159 extern void date_and_time (char *, char *, char *, gfc_array_i4
*,
160 GFC_INTEGER_4
, GFC_INTEGER_4
, GFC_INTEGER_4
);
161 export_proto(date_and_time
);
164 date_and_time (char *__date
, char *__time
, char *__zone
,
165 gfc_array_i4
*__values
, GFC_INTEGER_4 __date_len
,
166 GFC_INTEGER_4 __time_len
, GFC_INTEGER_4 __zone_len
)
169 char date
[DATE_LEN
+ 1];
170 char timec
[TIME_LEN
+ 1];
171 char zone
[ZONE_LEN
+ 1];
172 GFC_INTEGER_4 values
[VALUES_SIZE
];
174 #ifndef HAVE_NO_DATE_TIME
176 struct tm local_time
;
179 #if HAVE_GETTIMEOFDAY
183 if (!gettimeofday (&tp
, NULL
))
186 values
[7] = tp
.tv_usec
/ 1000;
197 #endif /* HAVE_GETTIMEOFDAY */
199 if (lt
!= (time_t) -1)
201 localtime_r (<
, &local_time
);
202 gmtime_r (<
, &UTC_time
);
204 /* All arguments can be derived from VALUES. */
205 values
[0] = 1900 + local_time
.tm_year
;
206 values
[1] = 1 + local_time
.tm_mon
;
207 values
[2] = local_time
.tm_mday
;
208 values
[3] = (local_time
.tm_min
- UTC_time
.tm_min
+
209 60 * (local_time
.tm_hour
- UTC_time
.tm_hour
+
210 24 * (local_time
.tm_yday
- UTC_time
.tm_yday
)));
211 values
[4] = local_time
.tm_hour
;
212 values
[5] = local_time
.tm_min
;
213 values
[6] = local_time
.tm_sec
;
217 snprintf (date
, DATE_LEN
+ 1, "%04d%02d%02d",
218 values
[0], values
[1], values
[2]);
220 snprintf (timec
, TIME_LEN
+ 1, "%02d%02d%02d.%03d",
221 values
[4], values
[5], values
[6], values
[7]);
224 snprintf (zone
, ZONE_LEN
+ 1, "%+03d%02d",
225 values
[3] / 60, abs (values
[3] % 60));
228 sprintf (date
, "%04d%02d%02d", values
[0], values
[1], values
[2]);
231 sprintf (timec
, "%02d%02d%02d.%03d",
232 values
[4], values
[5], values
[6], values
[7]);
235 sprintf (zone
, "%+03d%02d",
236 values
[3] / 60, abs (values
[3] % 60));
241 memset (date
, ' ', DATE_LEN
);
242 date
[DATE_LEN
] = '\0';
244 memset (timec
, ' ', TIME_LEN
);
245 timec
[TIME_LEN
] = '\0';
247 memset (zone
, ' ', ZONE_LEN
);
248 zone
[ZONE_LEN
] = '\0';
250 for (i
= 0; i
< VALUES_SIZE
; i
++)
251 values
[i
] = - GFC_INTEGER_4_HUGE
;
253 #else /* if defined HAVE_NO_DATE_TIME */
254 /* We really have *nothing* to return, so return blanks and HUGE(0). */
256 memset (date
, ' ', DATE_LEN
);
257 date
[DATE_LEN
] = '\0';
259 memset (timec
, ' ', TIME_LEN
);
260 timec
[TIME_LEN
] = '\0';
262 memset (zone
, ' ', ZONE_LEN
);
263 zone
[ZONE_LEN
] = '\0';
265 for (i
= 0; i
< VALUES_SIZE
; i
++)
266 values
[i
] = - GFC_INTEGER_4_HUGE
;
267 #endif /* HAVE_NO_DATE_TIME */
269 /* Copy the values into the arguments. */
272 index_type len
, delta
, elt_size
;
274 elt_size
= GFC_DESCRIPTOR_SIZE (__values
);
275 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
276 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
280 if (unlikely (len
< VALUES_SIZE
))
281 runtime_error ("Incorrect extent in VALUE argument to"
282 " DATE_AND_TIME intrinsic: is %ld, should"
283 " be >=%ld", (long int) len
, (long int) VALUES_SIZE
);
285 /* Cope with different type kinds. */
288 GFC_INTEGER_4
*vptr4
= __values
->data
;
290 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr4
+= delta
)
293 else if (elt_size
== 8)
295 GFC_INTEGER_8
*vptr8
= (GFC_INTEGER_8
*)__values
->data
;
297 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr8
+= delta
)
299 if (values
[i
] == - GFC_INTEGER_4_HUGE
)
300 *vptr8
= - GFC_INTEGER_8_HUGE
;
310 fstrcpy (__zone
, __zone_len
, zone
, ZONE_LEN
);
313 fstrcpy (__time
, __time_len
, timec
, TIME_LEN
);
316 fstrcpy (__date
, __date_len
, date
, DATE_LEN
);
320 /* SECNDS (X) - Non-standard
322 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
325 Class: Non-elemental subroutine.
329 X must be REAL(4) and the result is of the same type. The accuracy is system
336 yields the time in elapsed seconds since X. If X is 0.0, T is the time in
337 seconds since midnight. Note that a time that spans midnight but is less than
338 24hours will be calculated correctly. */
340 extern GFC_REAL_4
secnds (GFC_REAL_4
*);
341 export_proto(secnds
);
344 secnds (GFC_REAL_4
*x
)
346 GFC_INTEGER_4 values
[VALUES_SIZE
];
347 GFC_REAL_4 temp1
, temp2
;
349 /* Make the INTEGER*4 array for passing to date_and_time. */
350 gfc_array_i4
*avalues
= internal_malloc_size (sizeof (gfc_array_i4
));
351 avalues
->data
= &values
[0];
352 GFC_DESCRIPTOR_DTYPE (avalues
) = ((BT_REAL
<< GFC_DTYPE_TYPE_SHIFT
)
353 & GFC_DTYPE_TYPE_MASK
) +
354 (4 << GFC_DTYPE_SIZE_SHIFT
);
356 GFC_DIMENSION_SET(avalues
->dim
[0], 0, 7, 1);
358 date_and_time (NULL
, NULL
, NULL
, avalues
, 0, 0, 0);
362 temp1
= 3600.0 * (GFC_REAL_4
)values
[4] +
363 60.0 * (GFC_REAL_4
)values
[5] +
364 (GFC_REAL_4
)values
[6] +
365 0.001 * (GFC_REAL_4
)values
[7];
366 temp2
= fmod (*x
, 86400.0);
367 temp2
= (temp1
- temp2
>= 0.0) ? temp2
: (temp2
- 86400.0);
368 return temp1
- temp2
;
373 /* ITIME(X) - Non-standard
375 Description: Returns the current local time hour, minutes, and seconds
376 in elements 1, 2, and 3 of X, respectively. */
381 #ifndef HAVE_NO_DATE_TIME
383 struct tm local_time
;
387 if (lt
!= (time_t) -1)
389 localtime_r (<
, &local_time
);
391 x
[0] = local_time
.tm_hour
;
392 x
[1] = local_time
.tm_min
;
393 x
[2] = local_time
.tm_sec
;
396 x
[0] = x
[1] = x
[2] = -1;
400 extern void itime_i4 (gfc_array_i4
*);
401 export_proto(itime_i4
);
404 itime_i4 (gfc_array_i4
*__values
)
407 index_type len
, delta
;
410 /* Call helper function. */
413 /* Copy the value into the array. */
414 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
416 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
420 vptr
= __values
->data
;
421 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
426 extern void itime_i8 (gfc_array_i8
*);
427 export_proto(itime_i8
);
430 itime_i8 (gfc_array_i8
*__values
)
433 index_type len
, delta
;
436 /* Call helper function. */
439 /* Copy the value into the array. */
440 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
442 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
446 vptr
= __values
->data
;
447 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
453 /* IDATE(X) - Non-standard
455 Description: Fills TArray with the numerical values at the current
456 local time. The day (in the range 1-31), month (in the range 1-12),
457 and year appear in elements 1, 2, and 3 of X, respectively.
458 The year has four significant digits. */
463 #ifndef HAVE_NO_DATE_TIME
465 struct tm local_time
;
469 if (lt
!= (time_t) -1)
471 localtime_r (<
, &local_time
);
473 x
[0] = local_time
.tm_mday
;
474 x
[1] = 1 + local_time
.tm_mon
;
475 x
[2] = 1900 + local_time
.tm_year
;
478 x
[0] = x
[1] = x
[2] = -1;
482 extern void idate_i4 (gfc_array_i4
*);
483 export_proto(idate_i4
);
486 idate_i4 (gfc_array_i4
*__values
)
489 index_type len
, delta
;
492 /* Call helper function. */
495 /* Copy the value into the array. */
496 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
498 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
502 vptr
= __values
->data
;
503 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
508 extern void idate_i8 (gfc_array_i8
*);
509 export_proto(idate_i8
);
512 idate_i8 (gfc_array_i8
*__values
)
515 index_type len
, delta
;
518 /* Call helper function. */
521 /* Copy the value into the array. */
522 len
= GFC_DESCRIPTOR_EXTENT(__values
,0);
524 delta
= GFC_DESCRIPTOR_STRIDE(__values
,0);
528 vptr
= __values
->data
;
529 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
535 /* GMTIME(STIME, TARRAY) - Non-standard
537 Description: Given a system time value STime, fills TArray with values
538 extracted from it appropriate to the GMT time zone using gmtime_r(3).
540 The array elements are as follows:
542 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
543 2. Minutes after the hour, range 0-59
544 3. Hours past midnight, range 0-23
545 4. Day of month, range 0-31
546 5. Number of months since January, range 0-11
548 7. Number of days since Sunday, range 0-6
549 8. Days since January 1
550 9. Daylight savings indicator: positive if daylight savings is in effect,
551 zero if not, and negative if the information isn't available. */
554 gmtime_0 (const time_t * t
, int x
[9])
570 extern void gmtime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
571 export_proto(gmtime_i4
);
574 gmtime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
577 index_type len
, delta
;
581 /* Call helper function. */
585 /* Copy the values into the array. */
586 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
588 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
593 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
597 extern void gmtime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
598 export_proto(gmtime_i8
);
601 gmtime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
604 index_type len
, delta
;
608 /* Call helper function. */
612 /* Copy the values into the array. */
613 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
615 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
620 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
627 /* LTIME(STIME, TARRAY) - Non-standard
629 Description: Given a system time value STime, fills TArray with values
630 extracted from it appropriate to the local time zone using localtime_r(3).
632 The array elements are as follows:
634 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
635 2. Minutes after the hour, range 0-59
636 3. Hours past midnight, range 0-23
637 4. Day of month, range 0-31
638 5. Number of months since January, range 0-11
640 7. Number of days since Sunday, range 0-6
641 8. Days since January 1
642 9. Daylight savings indicator: positive if daylight savings is in effect,
643 zero if not, and negative if the information isn't available. */
646 ltime_0 (const time_t * t
, int x
[9])
650 localtime_r (t
, <
);
662 extern void ltime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
663 export_proto(ltime_i4
);
666 ltime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
669 index_type len
, delta
;
673 /* Call helper function. */
677 /* Copy the values into the array. */
678 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
680 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
685 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
689 extern void ltime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
690 export_proto(ltime_i8
);
693 ltime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
696 index_type len
, delta
;
700 /* Call helper function. */
704 /* Copy the values into the array. */
705 len
= GFC_DESCRIPTOR_EXTENT(tarray
,0);
707 delta
= GFC_DESCRIPTOR_STRIDE(tarray
,0);
712 for (i
= 0; i
< 9; i
++, vptr
+= delta
)