1/* Implementation of the DATE_AND_TIME intrinsic. 2 Copyright (C) 2003-2020 Free Software Foundation, Inc. 3 Contributed by Steven Bosscher. 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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 30#include "time_1.h" 31 32 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 36 threadsafe. */ 37 38#ifndef HAVE_GMTIME_R 39/* If _POSIX is defined gmtime_r gets defined by mingw-w64 headers. */ 40#ifdef gmtime_r 41#undef gmtime_r 42#endif 43 44static struct tm * 45gmtime_r (const time_t * timep, struct tm * result) 46{ 47 *result = *gmtime (timep); 48 return result; 49} 50#endif 51 52 53/* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES]) 54 55 Description: Returns data on the real-time clock and date in a form 56 compatible with the representations defined in ISO 8601:1988. 57 58 Class: Non-elemental subroutine. 59 60 Arguments: 61 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. 67 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 73 blanks. 74 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. 81 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: 85 86 VALUES(1) the year (for example, 2003), or -HUGE(0) if there is 87 no date available; 88 89 VALUES(2) the month of the year, or -HUGE(0) if there 90 is no date available; 91 92 VALUES(3) the day of the month, or -HUGE(0) if there is no date 93 available; 94 95 VALUES(4) the time difference with respect to Coordinated 96 Universal Time (UTC) in minutes, or -HUGE(0) if this information 97 is not available; 98 99 VALUES(5) the hour of the day, in the range of 0 to 23, or 100 -HUGE(0) if there is no clock; 101 102 VALUES(6) the minutes of the hour, in the range 0 to 59, or 103 -HUGE(0) if there is no clock; 104 105 VALUES(7) the seconds of the minute, in the range 0 to 60, or 106 -HUGE(0) if there is no clock; 107 108 VALUES(8) the milliseconds of the second, in the range 0 to 109 999, or -HUGE(0) if there is no clock. 110 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). 114 115 Based on libU77's date_time_.c. 116 117 TODO : 118 - Check year boundaries. 119*/ 120#define DATE_LEN 8 121#define TIME_LEN 10 122#define ZONE_LEN 5 123#define VALUES_SIZE 8 124 125extern void date_and_time (char *, char *, char *, gfc_array_i4 *, 126 GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4); 127export_proto(date_and_time); 128 129void 130date_and_time (char *__date, char *__time, char *__zone, 131 gfc_array_i4 *__values, GFC_INTEGER_4 __date_len, 132 GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len) 133{ 134 int i; 135 char date[DATE_LEN + 1]; 136 char timec[TIME_LEN + 1]; 137 char zone[ZONE_LEN + 1]; 138 GFC_INTEGER_4 values[VALUES_SIZE]; 139 140 time_t lt; 141 struct tm local_time; 142 struct tm UTC_time; 143 144 long usecs; 145 146 if (!gf_gettime (<, &usecs)) 147 { 148 values[7] = usecs / 1000; 149 150 localtime_r (<, &local_time); 151 gmtime_r (<, &UTC_time); 152 153 /* All arguments can be derived from VALUES. */ 154 values[0] = 1900 + local_time.tm_year; 155 values[1] = 1 + local_time.tm_mon; 156 values[2] = local_time.tm_mday; 157 values[3] = (local_time.tm_min - UTC_time.tm_min + 158 60 * (local_time.tm_hour - UTC_time.tm_hour + 159 24 * (local_time.tm_yday - UTC_time.tm_yday))); 160 values[4] = local_time.tm_hour; 161 values[5] = local_time.tm_min; 162 values[6] = local_time.tm_sec; 163 164 if (__date) 165 snprintf (date, DATE_LEN + 1, "%04d%02d%02d", 166 values[0], values[1], values[2]); 167 if (__time) 168 snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d", 169 values[4], values[5], values[6], values[7]); 170 171 if (__zone) 172 snprintf (zone, ZONE_LEN + 1, "%+03d%02d", 173 values[3] / 60, abs (values[3] % 60)); 174 } 175 else 176 { 177 memset (date, ' ', DATE_LEN); 178 date[DATE_LEN] = '\0'; 179 180 memset (timec, ' ', TIME_LEN); 181 timec[TIME_LEN] = '\0'; 182 183 memset (zone, ' ', ZONE_LEN); 184 zone[ZONE_LEN] = '\0'; 185 186 for (i = 0; i < VALUES_SIZE; i++) 187 values[i] = - GFC_INTEGER_4_HUGE; 188 } 189 190 /* Copy the values into the arguments. */ 191 if (__values) 192 { 193 index_type len, delta, elt_size; 194 195 elt_size = GFC_DESCRIPTOR_SIZE (__values); 196 len = GFC_DESCRIPTOR_EXTENT(__values,0); 197 delta = GFC_DESCRIPTOR_STRIDE(__values,0); 198 if (delta == 0) 199 delta = 1; 200 201 if (unlikely (len < VALUES_SIZE)) 202 runtime_error ("Incorrect extent in VALUE argument to" 203 " DATE_AND_TIME intrinsic: is %ld, should" 204 " be >=%ld", (long int) len, (long int) VALUES_SIZE); 205 206 /* Cope with different type kinds. */ 207 if (elt_size == 4) 208 { 209 GFC_INTEGER_4 *vptr4 = __values->base_addr; 210 211 for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta) 212 *vptr4 = values[i]; 213 } 214 else if (elt_size == 8) 215 { 216 GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->base_addr; 217 218 for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta) 219 { 220 if (values[i] == - GFC_INTEGER_4_HUGE) 221 *vptr8 = - GFC_INTEGER_8_HUGE; 222 else 223 *vptr8 = values[i]; 224 } 225 } 226 else 227 abort (); 228 } 229 230 if (__zone) 231 fstrcpy (__zone, __zone_len, zone, ZONE_LEN); 232 233 if (__time) 234 fstrcpy (__time, __time_len, timec, TIME_LEN); 235 236 if (__date) 237 fstrcpy (__date, __date_len, date, DATE_LEN); 238} 239 240 241/* SECNDS (X) - Non-standard 242 243 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4 244 in seconds. 245 246 Class: Non-elemental subroutine. 247 248 Arguments: 249 250 X must be REAL(4) and the result is of the same type. The accuracy is system 251 dependent. 252 253 Usage: 254 255 T = SECNDS (X) 256 257 yields the time in elapsed seconds since X. If X is 0.0, T is the time in 258 seconds since midnight. Note that a time that spans midnight but is less than 259 24hours will be calculated correctly. */ 260 261extern GFC_REAL_4 secnds (GFC_REAL_4 *); 262export_proto(secnds); 263 264GFC_REAL_4 265secnds (GFC_REAL_4 *x) 266{ 267 GFC_INTEGER_4 values[VALUES_SIZE]; 268 GFC_REAL_4 temp1, temp2; 269 270 /* Make the INTEGER*4 array for passing to date_and_time, with enough space 271 for a rank-one array. */ 272 gfc_array_i4 *avalues = xmalloc (sizeof (gfc_array_i4) 273 + sizeof (descriptor_dimension)); 274 avalues->base_addr = &values[0]; 275 GFC_DESCRIPTOR_DTYPE (avalues).type = BT_REAL; 276 GFC_DESCRIPTOR_DTYPE (avalues).elem_len = 4; 277 GFC_DESCRIPTOR_DTYPE (avalues).rank = 1; 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 300static void 301itime0 (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 318extern void itime_i4 (gfc_array_i4 *); 319export_proto(itime_i4); 320 321void 322itime_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 344extern void itime_i8 (gfc_array_i8 *); 345export_proto(itime_i8); 346 347void 348itime_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 378static void 379idate0 (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 396extern void idate_i4 (gfc_array_i4 *); 397export_proto(idate_i4); 398 399void 400idate_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 422extern void idate_i8 (gfc_array_i8 *); 423export_proto(idate_i8); 424 425void 426idate_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 1-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, range 0-365 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 467static void 468gmtime_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 484extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); 485export_proto(gmtime_i4); 486 487void 488gmtime_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 511extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); 512export_proto(gmtime_i8); 513 514void 515gmtime_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 1-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, range 0-365 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 559static void 560ltime_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 576extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); 577export_proto(ltime_i4); 578 579void 580ltime_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 603extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); 604export_proto(ltime_i8); 605 606void 607ltime_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