libgfortran/intrinsics/date_and_time.c

   1 /* Implementation of the DATE_AND_TIME intrinsic.
   2    Copyright (C) 2003-2023 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
  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
  44 static struct tm *
  45 gmtime_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
 122 extern void date_and_time (char *, char *, char *, gfc_array_i4 *,
 123                            GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
 124 export_proto(date_and_time);
 125
 126 void
 127 date_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 (&lt, &usecs))
 144     {
 145       values[7] = usecs / 1000;
 146
 147       localtime_r (&lt, &local_time);
 148       gmtime_r (&lt, &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
 271 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
 272 export_proto(secnds);
 273
 274 GFC_REAL_4
 275 secnds (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
 310 static void
 311 itime0 (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 (&lt, &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
 328 extern void itime_i4 (gfc_array_i4 *);
 329 export_proto(itime_i4);
 330
 331 void
 332 itime_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
 354 extern void itime_i8 (gfc_array_i8 *);
 355 export_proto(itime_i8);
 356
 357 void
 358 itime_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
 388 static void
 389 idate0 (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 (&lt, &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
 406 extern void idate_i4 (gfc_array_i4 *);
 407 export_proto(idate_i4);
 408
 409 void
 410 idate_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
 432 extern void idate_i8 (gfc_array_i8 *);
 433 export_proto(idate_i8);
 434
 435 void
 436 idate_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
 477 static void
 478 gmtime_0 (const time_t * t, int x[9])
 479 {
 480   struct tm lt;
 481
 482   gmtime_r (t, &lt);
 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
 494 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 495 export_proto(gmtime_i4);
 496
 497 void
 498 gmtime_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
 521 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 522 export_proto(gmtime_i8);
 523
 524 void
 525 gmtime_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
 569 static void
 570 ltime_0 (const time_t * t, int x[9])
 571 {
 572   struct tm lt;
 573
 574   localtime_r (t, &lt);
 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
 586 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 587 export_proto(ltime_i4);
 588
 589 void
 590 ltime_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
 613 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 614 export_proto(ltime_i8);
 615
 616 void
 617 ltime_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