1 /* Implementation of the DATE_AND_TIME intrinsic.
2 Copyright (C) 2003, 2004, 2005, 2006, 2007 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. */
31 #include "libgfortran.h"
36 #undef HAVE_NO_DATE_TIME
37 #if TIME_WITH_SYS_TIME
38 # include <sys/time.h>
42 # include <sys/time.h>
47 # define HAVE_NO_DATE_TIME
48 # endif /* HAVE_TIME_H */
49 # endif /* HAVE_SYS_TIME_H */
50 #endif /* TIME_WITH_SYS_TIME */
53 #define abs(x) ((x)>=0 ? (x) : -(x))
56 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
58 Description: Returns data on the real-time clock and date in a form
59 compatible with the representations defined in ISO 8601:1988.
61 Class: Non-elemental subroutine.
65 DATE (optional) shall be scalar and of type default character, and
66 shall be of length at least 8 in order to contain the complete
67 value. It is an INTENT(OUT) argument. Its leftmost 8 characters
68 are assigned a value of the form CCYYMMDD, where CC is the century,
69 YY the year within the century, MM the month within the year, and
70 DD the day within the month. If there is no date available, they
73 TIME (optional) shall be scalar and of type default character, and
74 shall be of length at least 10 in order to contain the complete
75 value. It is an INTENT(OUT) argument. Its leftmost 10 characters
76 are assigned a value of the form hhmmss.sss, where hh is the hour
77 of the day, mm is the minutes of the hour, and ss.sss is the
78 seconds and milliseconds of the minute. If there is no clock
79 available, they are assigned blanks.
81 ZONE (optional) shall be scalar and of type default character, and
82 shall be of length at least 5 in order to contain the complete
83 value. It is an INTENT(OUT) argument. Its leftmost 5 characters
84 are assigned a value of the form [+-]hhmm, where hh and mm are the
85 time difference with respect to Coordinated Universal Time (UTC) in
86 hours and parts of an hour expressed in minutes, respectively. If
87 there is no clock available, they are assigned blanks.
89 VALUES (optional) shall be of type default integer and of rank
90 one. It is an INTENT(OUT) argument. Its size shall be at least
91 8. The values returned in VALUES are as follows:
93 VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
96 VALUES(2) the month of the year, or -HUGE(0) if there
99 VALUES(3) the day of the month, or -HUGE(0) if there is no date
102 VALUES(4) the time difference with respect to Coordinated
103 Universal Time (UTC) in minutes, or -HUGE(0) if this information
106 VALUES(5) the hour of the day, in the range of 0 to 23, or
107 -HUGE(0) if there is no clock;
109 VALUES(6) the minutes of the hour, in the range 0 to 59, or
110 -HUGE(0) if there is no clock;
112 VALUES(7) the seconds of the minute, in the range 0 to 60, or
113 -HUGE(0) if there is no clock;
115 VALUES(8) the milliseconds of the second, in the range 0 to
116 999, or -HUGE(0) if there is no clock.
118 NULL pointer represent missing OPTIONAL arguments. All arguments
119 have INTENT(OUT). Because of the -i8 option, we must implement
120 VALUES for INTEGER(kind=4) and INTEGER(kind=8).
122 Based on libU77's date_time_.c.
125 - Check year boundaries.
130 #define VALUES_SIZE 8
132 extern void date_and_time (char *, char *, char *, gfc_array_i4
*,
133 GFC_INTEGER_4
, GFC_INTEGER_4
, GFC_INTEGER_4
);
134 export_proto(date_and_time
);
137 date_and_time (char *__date
, char *__time
, char *__zone
,
138 gfc_array_i4
*__values
, GFC_INTEGER_4 __date_len
,
139 GFC_INTEGER_4 __time_len
, GFC_INTEGER_4 __zone_len
)
142 char date
[DATE_LEN
+ 1];
143 char timec
[TIME_LEN
+ 1];
144 char zone
[ZONE_LEN
+ 1];
145 GFC_INTEGER_4 values
[VALUES_SIZE
];
147 #ifndef HAVE_NO_DATE_TIME
149 struct tm local_time
;
152 #if HAVE_GETTIMEOFDAY
156 if (!gettimeofday (&tp
, NULL
))
159 values
[7] = tp
.tv_usec
/ 1000;
170 #endif /* HAVE_GETTIMEOFDAY */
172 if (lt
!= (time_t) -1)
174 local_time
= *localtime (<
);
175 UTC_time
= *gmtime (<
);
177 /* All arguments can be derived from VALUES. */
178 values
[0] = 1900 + local_time
.tm_year
;
179 values
[1] = 1 + local_time
.tm_mon
;
180 values
[2] = local_time
.tm_mday
;
181 values
[3] = (local_time
.tm_min
- UTC_time
.tm_min
+
182 60 * (local_time
.tm_hour
- UTC_time
.tm_hour
+
183 24 * (local_time
.tm_yday
- UTC_time
.tm_yday
)));
184 values
[4] = local_time
.tm_hour
;
185 values
[5] = local_time
.tm_min
;
186 values
[6] = local_time
.tm_sec
;
190 snprintf (date
, DATE_LEN
+ 1, "%04d%02d%02d",
191 values
[0], values
[1], values
[2]);
193 snprintf (timec
, TIME_LEN
+ 1, "%02d%02d%02d.%03d",
194 values
[4], values
[5], values
[6], values
[7]);
197 snprintf (zone
, ZONE_LEN
+ 1, "%+03d%02d",
198 values
[3] / 60, abs (values
[3] % 60));
201 sprintf (date
, "%04d%02d%02d", values
[0], values
[1], values
[2]);
204 sprintf (timec
, "%02d%02d%02d.%03d",
205 values
[4], values
[5], values
[6], values
[7]);
208 sprintf (zone
, "%+03d%02d",
209 values
[3] / 60, abs (values
[3] % 60));
214 memset (date
, ' ', DATE_LEN
);
215 date
[DATE_LEN
] = '\0';
217 memset (timec
, ' ', TIME_LEN
);
218 timec
[TIME_LEN
] = '\0';
220 memset (zone
, ' ', ZONE_LEN
);
221 zone
[ZONE_LEN
] = '\0';
223 for (i
= 0; i
< VALUES_SIZE
; i
++)
224 values
[i
] = - GFC_INTEGER_4_HUGE
;
226 #else /* if defined HAVE_NO_DATE_TIME */
227 /* We really have *nothing* to return, so return blanks and HUGE(0). */
229 memset (date
, ' ', DATE_LEN
);
230 date
[DATE_LEN
] = '\0';
232 memset (timec
, ' ', TIME_LEN
);
233 timec
[TIME_LEN
] = '\0';
235 memset (zone
, ' ', ZONE_LEN
);
236 zone
[ZONE_LEN
] = '\0';
238 for (i
= 0; i
< VALUES_SIZE
; i
++)
239 values
[i
] = - GFC_INTEGER_4_HUGE
;
240 #endif /* HAVE_NO_DATE_TIME */
242 /* Copy the values into the arguments. */
245 size_t len
, delta
, elt_size
;
247 elt_size
= GFC_DESCRIPTOR_SIZE (__values
);
248 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
249 delta
= __values
->dim
[0].stride
;
253 assert (len
>= VALUES_SIZE
);
254 /* Cope with different type kinds. */
257 GFC_INTEGER_4
*vptr4
= __values
->data
;
259 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr4
+= delta
)
262 else if (elt_size
== 8)
264 GFC_INTEGER_8
*vptr8
= (GFC_INTEGER_8
*)__values
->data
;
266 for (i
= 0; i
< VALUES_SIZE
; i
++, vptr8
+= delta
)
268 if (values
[i
] == - GFC_INTEGER_4_HUGE
)
269 *vptr8
= - GFC_INTEGER_8_HUGE
;
280 assert (__zone_len
>= ZONE_LEN
);
281 fstrcpy (__zone
, ZONE_LEN
, zone
, ZONE_LEN
);
286 assert (__time_len
>= TIME_LEN
);
287 fstrcpy (__time
, TIME_LEN
, timec
, TIME_LEN
);
292 assert (__date_len
>= DATE_LEN
);
293 fstrcpy (__date
, DATE_LEN
, date
, DATE_LEN
);
298 /* SECNDS (X) - Non-standard
300 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
303 Class: Non-elemental subroutine.
307 X must be REAL(4) and the result is of the same type. The accuracy is system
314 yields the time in elapsed seconds since X. If X is 0.0, T is the time in
315 seconds since midnight. Note that a time that spans midnight but is less than
316 24hours will be calculated correctly. */
318 extern GFC_REAL_4
secnds (GFC_REAL_4
*);
319 export_proto(secnds
);
322 secnds (GFC_REAL_4
*x
)
324 GFC_INTEGER_4 values
[VALUES_SIZE
];
325 GFC_REAL_4 temp1
, temp2
;
327 /* Make the INTEGER*4 array for passing to date_and_time. */
328 gfc_array_i4
*avalues
= internal_malloc_size (sizeof (gfc_array_i4
));
329 avalues
->data
= &values
[0];
330 GFC_DESCRIPTOR_DTYPE (avalues
) = ((GFC_DTYPE_REAL
<< GFC_DTYPE_TYPE_SHIFT
)
331 & GFC_DTYPE_TYPE_MASK
) +
332 (4 << GFC_DTYPE_SIZE_SHIFT
);
334 avalues
->dim
[0].ubound
= 7;
335 avalues
->dim
[0].lbound
= 0;
336 avalues
->dim
[0].stride
= 1;
338 date_and_time (NULL
, NULL
, NULL
, avalues
, 0, 0, 0);
342 temp1
= 3600.0 * (GFC_REAL_4
)values
[4] +
343 60.0 * (GFC_REAL_4
)values
[5] +
344 (GFC_REAL_4
)values
[6] +
345 0.001 * (GFC_REAL_4
)values
[7];
346 temp2
= fmod (*x
, 86400.0);
347 temp2
= (temp1
- temp2
>= 0.0) ? temp2
: (temp2
- 86400.0);
348 return temp1
- temp2
;
353 /* ITIME(X) - Non-standard
355 Description: Returns the current local time hour, minutes, and seconds
356 in elements 1, 2, and 3 of X, respectively. */
361 #ifndef HAVE_NO_DATE_TIME
363 struct tm local_time
;
367 if (lt
!= (time_t) -1)
369 local_time
= *localtime (<
);
371 x
[0] = local_time
.tm_hour
;
372 x
[1] = local_time
.tm_min
;
373 x
[2] = local_time
.tm_sec
;
376 x
[0] = x
[1] = x
[2] = -1;
380 extern void itime_i4 (gfc_array_i4
*);
381 export_proto(itime_i4
);
384 itime_i4 (gfc_array_i4
*__values
)
390 /* Call helper function. */
393 /* Copy the value into the array. */
394 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
396 delta
= __values
->dim
[0].stride
;
400 vptr
= __values
->data
;
401 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
406 extern void itime_i8 (gfc_array_i8
*);
407 export_proto(itime_i8
);
410 itime_i8 (gfc_array_i8
*__values
)
416 /* Call helper function. */
419 /* Copy the value into the array. */
420 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
422 delta
= __values
->dim
[0].stride
;
426 vptr
= __values
->data
;
427 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
433 /* IDATE(X) - Non-standard
435 Description: Fills TArray with the numerical values at the current
436 local time. The day (in the range 1-31), month (in the range 1-12),
437 and year appear in elements 1, 2, and 3 of X, respectively.
438 The year has four significant digits. */
443 #ifndef HAVE_NO_DATE_TIME
445 struct tm local_time
;
449 if (lt
!= (time_t) -1)
451 local_time
= *localtime (<
);
453 x
[0] = local_time
.tm_mday
;
454 x
[1] = 1 + local_time
.tm_mon
;
455 x
[2] = 1900 + local_time
.tm_year
;
458 x
[0] = x
[1] = x
[2] = -1;
462 extern void idate_i4 (gfc_array_i4
*);
463 export_proto(idate_i4
);
466 idate_i4 (gfc_array_i4
*__values
)
472 /* Call helper function. */
475 /* Copy the value into the array. */
476 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
478 delta
= __values
->dim
[0].stride
;
482 vptr
= __values
->data
;
483 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
488 extern void idate_i8 (gfc_array_i8
*);
489 export_proto(idate_i8
);
492 idate_i8 (gfc_array_i8
*__values
)
498 /* Call helper function. */
501 /* Copy the value into the array. */
502 len
= __values
->dim
[0].ubound
+ 1 - __values
->dim
[0].lbound
;
504 delta
= __values
->dim
[0].stride
;
508 vptr
= __values
->data
;
509 for (i
= 0; i
< 3; i
++, vptr
+= delta
)
515 /* GMTIME(STIME, TARRAY) - Non-standard
517 Description: Given a system time value STime, fills TArray with values
518 extracted from it appropriate to the GMT time zone using gmtime(3).
520 The array elements are as follows:
522 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
523 2. Minutes after the hour, range 0-59
524 3. Hours past midnight, range 0-23
525 4. Day of month, range 0-31
526 5. Number of months since January, range 0-11
528 7. Number of days since Sunday, range 0-6
529 8. Days since January 1
530 9. Daylight savings indicator: positive if daylight savings is in effect,
531 zero if not, and negative if the information isn't available. */
534 gmtime_0 (const time_t * t
, int x
[9])
550 extern void gmtime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
551 export_proto(gmtime_i4
);
554 gmtime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
561 /* Call helper function. */
565 /* Copy the values into the array. */
566 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
568 delta
= tarray
->dim
[0].stride
;
573 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
577 extern void gmtime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
578 export_proto(gmtime_i8
);
581 gmtime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
588 /* Call helper function. */
592 /* Copy the values into the array. */
593 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
595 delta
= tarray
->dim
[0].stride
;
600 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
607 /* LTIME(STIME, TARRAY) - Non-standard
609 Description: Given a system time value STime, fills TArray with values
610 extracted from it appropriate to the local time zone using localtime(3).
612 The array elements are as follows:
614 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
615 2. Minutes after the hour, range 0-59
616 3. Hours past midnight, range 0-23
617 4. Day of month, range 0-31
618 5. Number of months since January, range 0-11
620 7. Number of days since Sunday, range 0-6
621 8. Days since January 1
622 9. Daylight savings indicator: positive if daylight savings is in effect,
623 zero if not, and negative if the information isn't available. */
626 ltime_0 (const time_t * t
, int x
[9])
642 extern void ltime_i4 (GFC_INTEGER_4
*, gfc_array_i4
*);
643 export_proto(ltime_i4
);
646 ltime_i4 (GFC_INTEGER_4
* t
, gfc_array_i4
* tarray
)
653 /* Call helper function. */
657 /* Copy the values into the array. */
658 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
660 delta
= tarray
->dim
[0].stride
;
665 for (i
= 0; i
< 9; i
++, vptr
+= delta
)
669 extern void ltime_i8 (GFC_INTEGER_8
*, gfc_array_i8
*);
670 export_proto(ltime_i8
);
673 ltime_i8 (GFC_INTEGER_8
* t
, gfc_array_i8
* tarray
)
680 /* Call helper function. */
684 /* Copy the values into the array. */
685 len
= tarray
->dim
[0].ubound
+ 1 - tarray
->dim
[0].lbound
;
687 delta
= tarray
->dim
[0].stride
;
692 for (i
= 0; i
< 9; i
++, vptr
+= delta
)