libgfortran/intrinsics/date_and_time.c

   1 /* Implementation of the DATE_AND_TIME intrinsic.
   2    Copyright (C) 2003-2021 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    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
 125 extern void date_and_time (char *, char *, char *, gfc_array_i4 *,
 126                            GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
 127 export_proto(date_and_time);
 128
 129 void
 130 date_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 (&lt, &usecs))
 147     {
 148       values[7] = usecs / 1000;
 149
 150       localtime_r (&lt, &local_time);
 151       gmtime_r (&lt, &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
 261 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
 262 export_proto(secnds);
 263
 264 GFC_REAL_4
 265 secnds (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
 300 static void
 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 (&lt, &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
 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
 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
 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 (&lt, &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
 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
 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 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
 467 static void
 468 gmtime_0 (const time_t * t, int x[9])
 469 {
 470   struct tm lt;
 471
 472   gmtime_r (t, &lt);
 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
 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
 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 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
 559 static void
 560 ltime_0 (const time_t * t, int x[9])
 561 {
 562   struct tm lt;
 563
 564   localtime_r (t, &lt);
 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
 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
 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