1 /* Implementation of the DATE_AND_TIME intrinsic.
2 Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Steven Bosscher.
5 This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING. If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
36 #include "libgfortran.h"
38 #undef HAVE_NO_DATE_TIME
39 #if TIME_WITH_SYS_TIME
40 # include <sys/time.h>
44 # include <sys/time.h>
49 # define HAVE_NO_DATE_TIME
50 # endif /* HAVE_TIME_H */
51 # endif /* HAVE_SYS_TIME_H */
52 #endif /* TIME_WITH_SYS_TIME */
55 #define abs(x) ((x)>=0 ? (x) : -(x))
58 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
60 Description: Returns data on the real-time clock and date in a form
61 compatible with the representations defined in ISO 8601:1988.
63 Class: Non-elemental subroutine.
67 DATE (optional) shall be scalar and of type default character, and
68 shall be of length at least 8 in order to contain the complete
69 value. It is an INTENT(OUT) argument. Its leftmost 8 characters
70 are assigned a value of the form CCYYMMDD, where CC is the century,
71 YY the year within the century, MM the month within the year, and
72 DD the day within the month. If there is no date available, they
75 TIME (optional) shall be scalar and of type default character, and
76 shall be of length at least 10 in order to contain the complete
77 value. It is an INTENT(OUT) argument. Its leftmost 10 characters
78 are assigned a value of the form hhmmss.sss, where hh is the hour
79 of the day, mm is the minutes of the hour, and ss.sss is the
80 seconds and milliseconds of the minute. If there is no clock
81 available, they are assigned blanks.
83 ZONE (optional) shall be scalar and of type default character, and
84 shall be of length at least 5 in order to contain the complete
85 value. It is an INTENT(OUT) argument. Its leftmost 5 characters
86 are assigned a value of the form [+-]hhmm, where hh and mm are the
87 time difference with respect to Coordinated Universal Time (UTC) in
88 hours and parts of an hour expressed in minutes, respectively. If
89 there is no clock available, they are assigned blanks.
91 VALUES (optional) shall be of type default integer and of rank
92 one. It is an INTENT(OUT) argument. Its size shall be at least
93 8. The values returned in VALUES are as follows:
95 VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
98 VALUES(2) the month of the year, or -HUGE(0) if there
101 VALUES(3) the day of the month, or -HUGE(0) if there is no date
104 VALUES(4) the time difference with respect to Coordinated
105 Universal Time (UTC) in minutes, or -HUGE(0) if this information
108 VALUES(5) the hour of the day, in the range of 0 to 23, or
109 -HUGE(0) if there is no clock;
111 VALUES(6) the minutes of the hour, in the range 0 to 59, or
112 -HUGE(0) if there is no clock;
114 VALUES(7) the seconds of the minute, in the range 0 to 60, or
115 -HUGE(0) if there is no clock;
117 VALUES(8) the milliseconds of the second, in the range 0 to
118 999, or -HUGE(0) if there is no clock.
120 NULL pointer represent missing OPTIONAL arguments. All arguments
121 have INTENT(OUT). Because of the -i8 option, we must implement
122 VALUES for INTEGER(kind=4) and INTEGER(kind=8).
124 Based on libU77's date_time_.c.
127 - Check year boundaries.
132 #define VALUES_SIZE 8
134 extern void date_and_time (char *, char *, char *, gfc_array_i4
*,
135 GFC_INTEGER_4
, GFC_INTEGER_4
, GFC_INTEGER_4
);
136 export_proto(date_and_time
);
139 date_and_time (char *__date
, char *__time
, char *__zone
,
140 gfc_array_i4
*__values
, GFC_INTEGER_4 __date_len
,
141 GFC_INTEGER_4 __time_len
, GFC_INTEGER_4 __zone_len
)
144 char date
[DATE_LEN
+ 1];
145 char timec
[TIME_LEN
+ 1];
146 char zone
[ZONE_LEN
+ 1];
147 GFC_INTEGER_4 values
[VALUES_SIZE
];
149 #ifndef HAVE_NO_DATE_TIME
151 struct tm local_time
;
154 #if HAVE_GETTIMEOFDAY
158 if (!gettimeofday (&tp
, NULL
))
161 values
[7] = tp
.tv_usec
/ 1000;
172 #endif /* HAVE_GETTIMEOFDAY */
174 if (lt
!= (time_t) -1)
176 local_time
= *localtime (<
);
177 UTC_time
= *gmtime (<
);
179 /* All arguments can be derived from VALUES. */
180 values
[0] = 1900 + local_time
.tm_year
;
181 values
[1] = 1 + local_time
.tm_mon
;
182 values
[2] = local_time
.tm_mday
;
183 values
[3] = (local_time
.tm_min
- UTC_time
.tm_min
+
184 60 * (local_time
.tm_hour
- UTC_time
.tm_hour
+
185 24 * (local_time
.tm_yday
- UTC_time
.tm_yday
)));
186 values
[4] = local_time
.tm_hour
;
187 values
[5] = local_time
.tm_min
;
188 values
[6] = local_time
.tm_sec
;
192 snprintf (date
, DATE_LEN
+ 1, "%04d%02d%02d",
193 values
[0], values
[1], values
[2]);
195 snprintf (timec
, TIME_LEN
+ 1, "%02d%02d%02d.%03d",
196 values
[4], values
[5], values
[6], values
[7]);
199 snprintf (zone
, ZONE_LEN
+ 1, "%+03d%02d",
200 values
[3] / 60, abs (values
[3] % 60));
203 sprintf (date
, "%04d%02d%02d", values
[0], values
[1], values
[2]);
206 sprintf (timec
, "%02d%02d%02d.%03d",
207 values
[4], values
[5], values
[6], values
[7]);
210 sprintf (zone
, "%+03d%02d",
211 values
[3] / 60, abs (values
[3] % 60));
216 memset (date
, ' ', DATE_LEN
);
217 date
[DATE_LEN
] = '\0';
219 memset (timec
, ' ', TIME_LEN
);
220 timec
[TIME_LEN
] = '\0';
222 memset (zone
, ' ', ZONE_LEN
);
223 zone
[ZONE_LEN
] = '\0';
225 for (i
= 0; i
< VALUES_SIZE
; i
++)
226 values
[i
] = - GFC_INTEGER_4_HUGE
;
228 #else /* if defined HAVE_NO_DATE_TIME */
229 /* We really have *nothing* to return, so return blanks and HUGE(0). */
231 memset (date
, ' ', DATE_LEN
);
232 date
[DATE_LEN
] = '\0';
234 memset (timec
, ' ', TIME_LEN
);
235 timec
[TIME_LEN
] = '\0';
237 memset (zone
, ' ', ZONE_LEN
);
238 zone
[ZONE_LEN
] = '\0';
240 for (i
= 0; i
< VALUES_SIZE
; i
++)
241 values
[i
] = - GFC_INTEGER_4_HUGE
;
242 #endif /* HAVE_NO_DATE_TIME */
244 /* Copy the values into the arguments. */
247 size_t len
, delta
, elt_size
;
249 elt_size
= GFC_DESCRIPTOR_SIZE (__values
);
250 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
251 delta
= __values
->dim
[0].stride
;
255 assert (len
>= VALUES_SIZE
);
256 /* Cope with different type kinds. */
259 GFC_INTEGER_4
*vptr4
= __values
->data
;
261 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr4
+= delta
)
264 else if (elt_size
== 8)
266 GFC_INTEGER_8
*vptr8
= (GFC_INTEGER_8
*)__values
->data
;
268 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr8
+= delta
)
270 if (values
[i
] == - GFC_INTEGER_4_HUGE
)
271 *vptr8
= - GFC_INTEGER_8_HUGE
;
282 assert (__zone_len
>= ZONE_LEN
);
283 fstrcpy (__zone
, ZONE_LEN
, zone
, ZONE_LEN
);
288 assert (__time_len
>= TIME_LEN
);
289 fstrcpy (__time
, TIME_LEN
, timec
, TIME_LEN
);
294 assert (__date_len
>= DATE_LEN
);
295 fstrcpy (__date
, DATE_LEN
, date
, DATE_LEN
);
300 /* SECNDS (X) - Non-standard
302 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
305 Class: Non-elemental subroutine.
309 X must be REAL(4) and the result is of the same type. The accuracy is system
316 yields the time in elapsed seconds since X. If X is 0.0, T is the time in
317 seconds since midnight. Note that a time that spans midnight but is less than
318 24hours will be calculated correctly. */
320 extern GFC_REAL_4
secnds (GFC_REAL_4
*);
321 export_proto(secnds
);
324 secnds (GFC_REAL_4
*x
)
326 GFC_INTEGER_4 values
[VALUES_SIZE
];
327 GFC_REAL_4 temp1
, temp2
;
329 /* Make the INTEGER*4 array for passing to date_and_time. */
330 gfc_array_i4
*avalues
= internal_malloc_size (sizeof (gfc_array_i4
));
331 avalues
->data
= &values
[0];
332 GFC_DESCRIPTOR_DTYPE (avalues
) = ((GFC_DTYPE_REAL
<< GFC_DTYPE_TYPE_SHIFT
)
333 & GFC_DTYPE_TYPE_MASK
) +
334 (4 << GFC_DTYPE_SIZE_SHIFT
);
336 avalues
->dim
[0].ubound
= 7;
337 avalues
->dim
[0].lbound
= 0;
338 avalues
->dim
[0].stride
= 1;
340 date_and_time (NULL
, NULL
, NULL
, avalues
, 0, 0, 0);
344 temp1
= 3600.0 * (GFC_REAL_4
)values
[4] +
345 60.0 * (GFC_REAL_4
)values
[5] +
346 (GFC_REAL_4
)values
[6] +
347 0.001 * (GFC_REAL_4
)values
[7];
348 temp2
= fmod (*x
, 86400.0);
349 temp2
= (temp1
- temp2
>= 0.0) ? temp2
: (temp2
- 86400.0);
350 return temp1
- temp2
;
355 /* ITIME(X) - Non-standard
357 Description: Returns the current local time hour, minutes, and seconds
358 in elements 1, 2, and 3 of X, respectively. */
363 #ifndef HAVE_NO_DATE_TIME
365 struct tm local_time
;
369 if (lt
!= (time_t) -1)
371 local_time
= *localtime (<
);
373 x
[0] = local_time
.tm_hour
;
374 x
[1] = local_time
.tm_min
;
375 x
[2] = local_time
.tm_sec
;
378 x
[0] = x
[1] = x
[2] = -1;
382 extern void itime_i4 (gfc_array_i4
*);
383 export_proto(itime_i4
);
386 itime_i4 (gfc_array_i4
*__values
)
392 /* Call helper function. */
395 /* Copy the value into the array. */
396 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
398 delta
= __values
->dim
[0].stride
;
402 vptr
= __values
->data
;
403 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
408 extern void itime_i8 (gfc_array_i8
*);
409 export_proto(itime_i8
);
412 itime_i8 (gfc_array_i8
*__values
)
418 /* Call helper function. */
421 /* Copy the value into the array. */
422 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
424 delta
= __values
->dim
[0].stride
;
428 vptr
= __values
->data
;
429 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
435 /* IDATE(X) - Non-standard
437 Description: Fills TArray with the numerical values at the current
438 local time. The day (in the range 1-31), month (in the range 1-12),
439 and year appear in elements 1, 2, and 3 of X, respectively.
440 The year has four significant digits. */
445 #ifndef HAVE_NO_DATE_TIME
447 struct tm local_time
;
451 if (lt
!= (time_t) -1)
453 local_time
= *localtime (<
);
455 x
[0] = local_time
.tm_mday
;
456 x
[1] = 1 + local_time
.tm_mon
;
457 x
[2] = 1900 + local_time
.tm_year
;
460 x
[0] = x
[1] = x
[2] = -1;
464 extern void idate_i4 (gfc_array_i4
*);
465 export_proto(idate_i4
);
468 idate_i4 (gfc_array_i4
*__values
)
474 /* Call helper function. */
477 /* Copy the value into the array. */
478 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
480 delta
= __values
->dim
[0].stride
;
484 vptr
= __values
->data
;
485 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
490 extern void idate_i8 (gfc_array_i8
*);
491 export_proto(idate_i8
);
494 idate_i8 (gfc_array_i8
*__values
)
500 /* Call helper function. */
503 /* Copy the value into the array. */
504 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
506 delta
= __values
->dim
[0].stride
;
510 vptr
= __values
->data
;
511 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
517 /* GMTIME(STIME, TARRAY) - Non-standard
519 Description: Given a system time value STime, fills TArray with values
520 extracted from it appropriate to the GMT time zone using gmtime(3).
522 The array elements are as follows:
524 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
525 2. Minutes after the hour, range 0-59
526 3. Hours past midnight, range 0-23
527 4. Day of month, range 0-31
528 5. Number of months since January, range 0-11
530 7. Number of days since Sunday, range 0-6
531 8. Days since January 1
532 9. Daylight savings indicator: positive if daylight savings is in effect,
533 zero if not, and negative if the information isn't available. */
536 gmtime_0 (const time_t * t
, int x
[9])
552 extern void gmtime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
553 export_proto(gmtime_i4
);
556 gmtime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
563 /* Call helper function. */
567 /* Copy the values into the array. */
568 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
570 delta
= tarray
->dim
[0].stride
;
575 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
579 extern void gmtime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
580 export_proto(gmtime_i8
);
583 gmtime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
590 /* Call helper function. */
594 /* Copy the values into the array. */
595 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
597 delta
= tarray
->dim
[0].stride
;
602 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
609 /* LTIME(STIME, TARRAY) - Non-standard
611 Description: Given a system time value STime, fills TArray with values
612 extracted from it appropriate to the local time zone using localtime(3).
614 The array elements are as follows:
616 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
617 2. Minutes after the hour, range 0-59
618 3. Hours past midnight, range 0-23
619 4. Day of month, range 0-31
620 5. Number of months since January, range 0-11
622 7. Number of days since Sunday, range 0-6
623 8. Days since January 1
624 9. Daylight savings indicator: positive if daylight savings is in effect,
625 zero if not, and negative if the information isn't available. */
628 ltime_0 (const time_t * t
, int x
[9])
644 extern void ltime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
645 export_proto(ltime_i4
);
648 ltime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
655 /* Call helper function. */
659 /* Copy the values into the array. */
660 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
662 delta
= tarray
->dim
[0].stride
;
667 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
671 extern void ltime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
672 export_proto(ltime_i8
);
675 ltime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
682 /* Call helper function. */
686 /* Copy the values into the array. */
687 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
689 delta
= tarray
->dim
[0].stride
;
694 for (i
= 0; i
< 9; i
++, vptr
+= delta
)