1/* Implementation of the DATE_AND_TIME intrinsic. 2 Copyright (C) 2003-2022 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#define DATE_LEN 8 118#define TIME_LEN 10 119#define ZONE_LEN 5 120#define VALUES_SIZE 8 121 122extern void date_and_time (char *, char *, char *, gfc_array_i4 *, 123 GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4); 124export_proto(date_and_time); 125 126void 127date_and_time (char *__date, char *__time, char *__zone, 128 gfc_array_i4 *__values, GFC_INTEGER_4 __date_len, 129 GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len) 130{ 131 int i, delta_day; 132 char date[DATE_LEN + 1]; 133 char timec[TIME_LEN + 1]; 134 char zone[ZONE_LEN + 1]; 135 GFC_INTEGER_4 values[VALUES_SIZE]; 136 137 time_t lt; 138 struct tm local_time; 139 struct tm UTC_time; 140 141 long usecs; 142 143 if (!gf_gettime (<, &usecs)) 144 { 145 values[7] = usecs / 1000; 146 147 localtime_r (<, &local_time); 148 gmtime_r (<, &UTC_time); 149 150 /* All arguments can be derived from VALUES. */ 151 values[0] = 1900 + local_time.tm_year; 152 values[1] = 1 + local_time.tm_mon; 153 values[2] = local_time.tm_mday; 154 155 /* Day difference with UTC should always be -1, 0 or +1. 156 Near year boundaries, we may obtain a large positive (+364, 157 or +365 on leap years) or negative (-364, or -365 on leap years) 158 number, which we have to handle. 159 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=98507 160 */ 161 delta_day = local_time.tm_yday - UTC_time.tm_yday; 162 if (delta_day < -1) 163 delta_day = 1; 164 else if (delta_day > 1) 165 delta_day = -1; 166 167 values[3] = local_time.tm_min - UTC_time.tm_min 168 + 60 * (local_time.tm_hour - UTC_time.tm_hour + 24 * delta_day); 169 170 values[4] = local_time.tm_hour; 171 values[5] = local_time.tm_min; 172 values[6] = local_time.tm_sec; 173 174 if (__date) 175 snprintf (date, DATE_LEN + 1, "%04d%02d%02d", 176 values[0], values[1], values[2]); 177 if (__time) 178 snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d", 179 values[4], values[5], values[6], values[7]); 180 181 if (__zone) 182 snprintf (zone, ZONE_LEN + 1, "%+03d%02d", 183 values[3] / 60, abs (values[3] % 60)); 184 } 185 else 186 { 187 memset (date, ' ', DATE_LEN); 188 date[DATE_LEN] = '\0'; 189 190 memset (timec, ' ', TIME_LEN); 191 timec[TIME_LEN] = '\0'; 192 193 memset (zone, ' ', ZONE_LEN); 194 zone[ZONE_LEN] = '\0'; 195 196 for (i = 0; i < VALUES_SIZE; i++) 197 values[i] = - GFC_INTEGER_4_HUGE; 198 } 199 200 /* Copy the values into the arguments. */ 201 if (__values) 202 { 203 index_type len, delta, elt_size; 204 205 elt_size = GFC_DESCRIPTOR_SIZE (__values); 206 len = GFC_DESCRIPTOR_EXTENT(__values,0); 207 delta = GFC_DESCRIPTOR_STRIDE(__values,0); 208 if (delta == 0) 209 delta = 1; 210 211 if (unlikely (len < VALUES_SIZE)) 212 runtime_error ("Incorrect extent in VALUE argument to" 213 " DATE_AND_TIME intrinsic: is %ld, should" 214 " be >=%ld", (long int) len, (long int) VALUES_SIZE); 215 216 /* Cope with different type kinds. */ 217 if (elt_size == 4) 218 { 219 GFC_INTEGER_4 *vptr4 = __values->base_addr; 220 221 for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta) 222 *vptr4 = values[i]; 223 } 224 else if (elt_size == 8) 225 { 226 GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->base_addr; 227 228 for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta) 229 { 230 if (values[i] == - GFC_INTEGER_4_HUGE) 231 *vptr8 = - GFC_INTEGER_8_HUGE; 232 else 233 *vptr8 = values[i]; 234 } 235 } 236 else 237 abort (); 238 } 239 240 if (__zone) 241 fstrcpy (__zone, __zone_len, zone, ZONE_LEN); 242 243 if (__time) 244 fstrcpy (__time, __time_len, timec, TIME_LEN); 245 246 if (__date) 247 fstrcpy (__date, __date_len, date, DATE_LEN); 248} 249 250 251/* SECNDS (X) - Non-standard 252 253 Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4 254 in seconds. 255 256 Class: Non-elemental subroutine. 257 258 Arguments: 259 260 X must be REAL(4) and the result is of the same type. The accuracy is system 261 dependent. 262 263 Usage: 264 265 T = SECNDS (X) 266 267 yields the time in elapsed seconds since X. If X is 0.0, T is the time in 268 seconds since midnight. Note that a time that spans midnight but is less than 269 24hours will be calculated correctly. */ 270 271extern GFC_REAL_4 secnds (GFC_REAL_4 *); 272export_proto(secnds); 273 274GFC_REAL_4 275secnds (GFC_REAL_4 *x) 276{ 277 GFC_INTEGER_4 values[VALUES_SIZE]; 278 GFC_REAL_4 temp1, temp2; 279 280 /* Make the INTEGER*4 array for passing to date_and_time, with enough space 281 for a rank-one array. */ 282 gfc_array_i4 *avalues = xmalloc (sizeof (gfc_array_i4) 283 + sizeof (descriptor_dimension)); 284 avalues->base_addr = &values[0]; 285 GFC_DESCRIPTOR_DTYPE (avalues).type = BT_REAL; 286 GFC_DESCRIPTOR_DTYPE (avalues).elem_len = 4; 287 GFC_DESCRIPTOR_DTYPE (avalues).rank = 1; 288 GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1); 289 290 date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0); 291 292 free (avalues); 293 294 temp1 = 3600.0 * (GFC_REAL_4)values[4] + 295 60.0 * (GFC_REAL_4)values[5] + 296 (GFC_REAL_4)values[6] + 297 0.001 * (GFC_REAL_4)values[7]; 298 temp2 = fmod (*x, 86400.0); 299 temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0); 300 return temp1 - temp2; 301} 302 303 304 305/* ITIME(X) - Non-standard 306 307 Description: Returns the current local time hour, minutes, and seconds 308 in elements 1, 2, and 3 of X, respectively. */ 309 310static void 311itime0 (int x[3]) 312{ 313 time_t lt; 314 struct tm local_time; 315 316 lt = time (NULL); 317 318 if (lt != (time_t) -1) 319 { 320 localtime_r (<, &local_time); 321 322 x[0] = local_time.tm_hour; 323 x[1] = local_time.tm_min; 324 x[2] = local_time.tm_sec; 325 } 326} 327 328extern void itime_i4 (gfc_array_i4 *); 329export_proto(itime_i4); 330 331void 332itime_i4 (gfc_array_i4 *__values) 333{ 334 int x[3], i; 335 index_type len, delta; 336 GFC_INTEGER_4 *vptr; 337 338 /* Call helper function. */ 339 itime0(x); 340 341 /* Copy the value into the array. */ 342 len = GFC_DESCRIPTOR_EXTENT(__values,0); 343 assert (len >= 3); 344 delta = GFC_DESCRIPTOR_STRIDE(__values,0); 345 if (delta == 0) 346 delta = 1; 347 348 vptr = __values->base_addr; 349 for (i = 0; i < 3; i++, vptr += delta) 350 *vptr = x[i]; 351} 352 353 354extern void itime_i8 (gfc_array_i8 *); 355export_proto(itime_i8); 356 357void 358itime_i8 (gfc_array_i8 *__values) 359{ 360 int x[3], i; 361 index_type len, delta; 362 GFC_INTEGER_8 *vptr; 363 364 /* Call helper function. */ 365 itime0(x); 366 367 /* Copy the value into the array. */ 368 len = GFC_DESCRIPTOR_EXTENT(__values,0); 369 assert (len >= 3); 370 delta = GFC_DESCRIPTOR_STRIDE(__values,0); 371 if (delta == 0) 372 delta = 1; 373 374 vptr = __values->base_addr; 375 for (i = 0; i < 3; i++, vptr += delta) 376 *vptr = x[i]; 377} 378 379 380 381/* IDATE(X) - Non-standard 382 383 Description: Fills TArray with the numerical values at the current 384 local time. The day (in the range 1-31), month (in the range 1-12), 385 and year appear in elements 1, 2, and 3 of X, respectively. 386 The year has four significant digits. */ 387 388static void 389idate0 (int x[3]) 390{ 391 time_t lt; 392 struct tm local_time; 393 394 lt = time (NULL); 395 396 if (lt != (time_t) -1) 397 { 398 localtime_r (<, &local_time); 399 400 x[0] = local_time.tm_mday; 401 x[1] = 1 + local_time.tm_mon; 402 x[2] = 1900 + local_time.tm_year; 403 } 404} 405 406extern void idate_i4 (gfc_array_i4 *); 407export_proto(idate_i4); 408 409void 410idate_i4 (gfc_array_i4 *__values) 411{ 412 int x[3], i; 413 index_type len, delta; 414 GFC_INTEGER_4 *vptr; 415 416 /* Call helper function. */ 417 idate0(x); 418 419 /* Copy the value into the array. */ 420 len = GFC_DESCRIPTOR_EXTENT(__values,0); 421 assert (len >= 3); 422 delta = GFC_DESCRIPTOR_STRIDE(__values,0); 423 if (delta == 0) 424 delta = 1; 425 426 vptr = __values->base_addr; 427 for (i = 0; i < 3; i++, vptr += delta) 428 *vptr = x[i]; 429} 430 431 432extern void idate_i8 (gfc_array_i8 *); 433export_proto(idate_i8); 434 435void 436idate_i8 (gfc_array_i8 *__values) 437{ 438 int x[3], i; 439 index_type len, delta; 440 GFC_INTEGER_8 *vptr; 441 442 /* Call helper function. */ 443 idate0(x); 444 445 /* Copy the value into the array. */ 446 len = GFC_DESCRIPTOR_EXTENT(__values,0); 447 assert (len >= 3); 448 delta = GFC_DESCRIPTOR_STRIDE(__values,0); 449 if (delta == 0) 450 delta = 1; 451 452 vptr = __values->base_addr; 453 for (i = 0; i < 3; i++, vptr += delta) 454 *vptr = x[i]; 455} 456 457 458 459/* GMTIME(STIME, TARRAY) - Non-standard 460 461 Description: Given a system time value STime, fills TArray with values 462 extracted from it appropriate to the GMT time zone using gmtime_r(3). 463 464 The array elements are as follows: 465 466 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds 467 2. Minutes after the hour, range 0-59 468 3. Hours past midnight, range 0-23 469 4. Day of month, range 1-31 470 5. Number of months since January, range 0-11 471 6. Years since 1900 472 7. Number of days since Sunday, range 0-6 473 8. Days since January 1, range 0-365 474 9. Daylight savings indicator: positive if daylight savings is in effect, 475 zero if not, and negative if the information isn't available. */ 476 477static void 478gmtime_0 (const time_t * t, int x[9]) 479{ 480 struct tm lt; 481 482 gmtime_r (t, <); 483 x[0] = lt.tm_sec; 484 x[1] = lt.tm_min; 485 x[2] = lt.tm_hour; 486 x[3] = lt.tm_mday; 487 x[4] = lt.tm_mon; 488 x[5] = lt.tm_year; 489 x[6] = lt.tm_wday; 490 x[7] = lt.tm_yday; 491 x[8] = lt.tm_isdst; 492} 493 494extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); 495export_proto(gmtime_i4); 496 497void 498gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray) 499{ 500 int x[9], i; 501 index_type len, delta; 502 GFC_INTEGER_4 *vptr; 503 time_t tt; 504 505 /* Call helper function. */ 506 tt = (time_t) *t; 507 gmtime_0(&tt, x); 508 509 /* Copy the values into the array. */ 510 len = GFC_DESCRIPTOR_EXTENT(tarray,0); 511 assert (len >= 9); 512 delta = GFC_DESCRIPTOR_STRIDE(tarray,0); 513 if (delta == 0) 514 delta = 1; 515 516 vptr = tarray->base_addr; 517 for (i = 0; i < 9; i++, vptr += delta) 518 *vptr = x[i]; 519} 520 521extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); 522export_proto(gmtime_i8); 523 524void 525gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray) 526{ 527 int x[9], i; 528 index_type len, delta; 529 GFC_INTEGER_8 *vptr; 530 time_t tt; 531 532 /* Call helper function. */ 533 tt = (time_t) *t; 534 gmtime_0(&tt, x); 535 536 /* Copy the values into the array. */ 537 len = GFC_DESCRIPTOR_EXTENT(tarray,0); 538 assert (len >= 9); 539 delta = GFC_DESCRIPTOR_STRIDE(tarray,0); 540 if (delta == 0) 541 delta = 1; 542 543 vptr = tarray->base_addr; 544 for (i = 0; i < 9; i++, vptr += delta) 545 *vptr = x[i]; 546} 547 548 549 550 551/* LTIME(STIME, TARRAY) - Non-standard 552 553 Description: Given a system time value STime, fills TArray with values 554 extracted from it appropriate to the local time zone using localtime_r(3). 555 556 The array elements are as follows: 557 558 1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds 559 2. Minutes after the hour, range 0-59 560 3. Hours past midnight, range 0-23 561 4. Day of month, range 1-31 562 5. Number of months since January, range 0-11 563 6. Years since 1900 564 7. Number of days since Sunday, range 0-6 565 8. Days since January 1, range 0-365 566 9. Daylight savings indicator: positive if daylight savings is in effect, 567 zero if not, and negative if the information isn't available. */ 568 569static void 570ltime_0 (const time_t * t, int x[9]) 571{ 572 struct tm lt; 573 574 localtime_r (t, <); 575 x[0] = lt.tm_sec; 576 x[1] = lt.tm_min; 577 x[2] = lt.tm_hour; 578 x[3] = lt.tm_mday; 579 x[4] = lt.tm_mon; 580 x[5] = lt.tm_year; 581 x[6] = lt.tm_wday; 582 x[7] = lt.tm_yday; 583 x[8] = lt.tm_isdst; 584} 585 586extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); 587export_proto(ltime_i4); 588 589void 590ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray) 591{ 592 int x[9], i; 593 index_type len, delta; 594 GFC_INTEGER_4 *vptr; 595 time_t tt; 596 597 /* Call helper function. */ 598 tt = (time_t) *t; 599 ltime_0(&tt, x); 600 601 /* Copy the values into the array. */ 602 len = GFC_DESCRIPTOR_EXTENT(tarray,0); 603 assert (len >= 9); 604 delta = GFC_DESCRIPTOR_STRIDE(tarray,0); 605 if (delta == 0) 606 delta = 1; 607 608 vptr = tarray->base_addr; 609 for (i = 0; i < 9; i++, vptr += delta) 610 *vptr = x[i]; 611} 612 613extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); 614export_proto(ltime_i8); 615 616void 617ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray) 618{ 619 int x[9], i; 620 index_type len, delta; 621 GFC_INTEGER_8 *vptr; 622 time_t tt; 623 624 /* Call helper function. */ 625 tt = (time_t) * t; 626 ltime_0(&tt, x); 627 628 /* Copy the values into the array. */ 629 len = GFC_DESCRIPTOR_EXTENT(tarray,0); 630 assert (len >= 9); 631 delta = GFC_DESCRIPTOR_STRIDE(tarray,0); 632 if (delta == 0) 633 delta = 1; 634 635 vptr = tarray->base_addr; 636 for (i = 0; i < 9; i++, vptr += delta) 637 *vptr = x[i]; 638} 639 640 641