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