libgfortran/intrinsics/date_and_time.c

   1 /* Implementation of the DATE_AND_TIME intrinsic.
   2    Copyright (C) 2003-2018 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.  */
 271   gfc_array_i4 *avalues = xmalloc (sizeof (gfc_array_i4));
 272   avalues->base_addr = &values[0];
 273   GFC_DESCRIPTOR_DTYPE (avalues).type = BT_REAL;
 274   GFC_DESCRIPTOR_DTYPE (avalues).elem_len = 4;
 275   GFC_DESCRIPTOR_DTYPE (avalues).rank = 1;
 276   GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1);
 277
 278   date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
 279
 280   free (avalues);
 281
 282   temp1 = 3600.0 * (GFC_REAL_4)values[4] +
 283             60.0 * (GFC_REAL_4)values[5] +
 284                    (GFC_REAL_4)values[6] +
 285            0.001 * (GFC_REAL_4)values[7];
 286   temp2 = fmod (*x, 86400.0);
 287   temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0);
 288   return temp1 - temp2;
 289 }
 290
 291
 292
 293 /* ITIME(X) - Non-standard
 294
 295    Description: Returns the current local time hour, minutes, and seconds
 296    in elements 1, 2, and 3 of X, respectively.  */
 297
 298 static void
 299 itime0 (int x[3])
 300 {
 301   time_t lt;
 302   struct tm local_time;
 303
 304   lt = time (NULL);
 305
 306   if (lt != (time_t) -1)
 307     {
 308       localtime_r (&lt, &local_time);
 309
 310       x[0] = local_time.tm_hour;
 311       x[1] = local_time.tm_min;
 312       x[2] = local_time.tm_sec;
 313     }
 314 }
 315
 316 extern void itime_i4 (gfc_array_i4 *);
 317 export_proto(itime_i4);
 318
 319 void
 320 itime_i4 (gfc_array_i4 *__values)
 321 {
 322   int x[3], i;
 323   index_type len, delta;
 324   GFC_INTEGER_4 *vptr;
 325
 326   /* Call helper function.  */
 327   itime0(x);
 328
 329   /* Copy the value into the array.  */
 330   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 331   assert (len >= 3);
 332   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 333   if (delta == 0)
 334     delta = 1;
 335
 336   vptr = __values->base_addr;
 337   for (i = 0; i < 3; i++, vptr += delta)
 338     *vptr = x[i];
 339 }
 340
 341
 342 extern void itime_i8 (gfc_array_i8 *);
 343 export_proto(itime_i8);
 344
 345 void
 346 itime_i8 (gfc_array_i8 *__values)
 347 {
 348   int x[3], i;
 349   index_type len, delta;
 350   GFC_INTEGER_8 *vptr;
 351
 352   /* Call helper function.  */
 353   itime0(x);
 354
 355   /* Copy the value into the array.  */
 356   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 357   assert (len >= 3);
 358   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 359   if (delta == 0)
 360     delta = 1;
 361
 362   vptr = __values->base_addr;
 363   for (i = 0; i < 3; i++, vptr += delta)
 364     *vptr = x[i];
 365 }
 366
 367
 368
 369 /* IDATE(X) - Non-standard
 370
 371    Description: Fills TArray with the numerical values at the current
 372    local time. The day (in the range 1-31), month (in the range 1-12),
 373    and year appear in elements 1, 2, and 3 of X, respectively.
 374    The year has four significant digits.  */
 375
 376 static void
 377 idate0 (int x[3])
 378 {
 379   time_t lt;
 380   struct tm local_time;
 381
 382   lt = time (NULL);
 383
 384   if (lt != (time_t) -1)
 385     {
 386       localtime_r (&lt, &local_time);
 387
 388       x[0] = local_time.tm_mday;
 389       x[1] = 1 + local_time.tm_mon;
 390       x[2] = 1900 + local_time.tm_year;
 391     }
 392 }
 393
 394 extern void idate_i4 (gfc_array_i4 *);
 395 export_proto(idate_i4);
 396
 397 void
 398 idate_i4 (gfc_array_i4 *__values)
 399 {
 400   int x[3], i;
 401   index_type len, delta;
 402   GFC_INTEGER_4 *vptr;
 403
 404   /* Call helper function.  */
 405   idate0(x);
 406
 407   /* Copy the value into the array.  */
 408   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 409   assert (len >= 3);
 410   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 411   if (delta == 0)
 412     delta = 1;
 413
 414   vptr = __values->base_addr;
 415   for (i = 0; i < 3; i++, vptr += delta)
 416     *vptr = x[i];
 417 }
 418
 419
 420 extern void idate_i8 (gfc_array_i8 *);
 421 export_proto(idate_i8);
 422
 423 void
 424 idate_i8 (gfc_array_i8 *__values)
 425 {
 426   int x[3], i;
 427   index_type len, delta;
 428   GFC_INTEGER_8 *vptr;
 429
 430   /* Call helper function.  */
 431   idate0(x);
 432
 433   /* Copy the value into the array.  */
 434   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 435   assert (len >= 3);
 436   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 437   if (delta == 0)
 438     delta = 1;
 439
 440   vptr = __values->base_addr;
 441   for (i = 0; i < 3; i++, vptr += delta)
 442     *vptr = x[i];
 443 }
 444
 445
 446
 447 /* GMTIME(STIME, TARRAY) - Non-standard
 448
 449    Description: Given a system time value STime, fills TArray with values
 450    extracted from it appropriate to the GMT time zone using gmtime_r(3).
 451
 452    The array elements are as follows:
 453
 454       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 455       2. Minutes after the hour, range 0-59
 456       3. Hours past midnight, range 0-23
 457       4. Day of month, range 1-31
 458       5. Number of months since January, range 0-11
 459       6. Years since 1900
 460       7. Number of days since Sunday, range 0-6
 461       8. Days since January 1, range 0-365
 462       9. Daylight savings indicator: positive if daylight savings is in effect,
 463          zero if not, and negative if the information isn't available.  */
 464
 465 static void
 466 gmtime_0 (const time_t * t, int x[9])
 467 {
 468   struct tm lt;
 469
 470   gmtime_r (t, &lt);
 471   x[0] = lt.tm_sec;
 472   x[1] = lt.tm_min;
 473   x[2] = lt.tm_hour;
 474   x[3] = lt.tm_mday;
 475   x[4] = lt.tm_mon;
 476   x[5] = lt.tm_year;
 477   x[6] = lt.tm_wday;
 478   x[7] = lt.tm_yday;
 479   x[8] = lt.tm_isdst;
 480 }
 481
 482 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 483 export_proto(gmtime_i4);
 484
 485 void
 486 gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 487 {
 488   int x[9], i;
 489   index_type len, delta;
 490   GFC_INTEGER_4 *vptr;
 491   time_t tt;
 492
 493   /* Call helper function.  */
 494   tt = (time_t) *t;
 495   gmtime_0(&tt, x);
 496
 497   /* Copy the values into the array.  */
 498   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 499   assert (len >= 9);
 500   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 501   if (delta == 0)
 502     delta = 1;
 503
 504   vptr = tarray->base_addr;
 505   for (i = 0; i < 9; i++, vptr += delta)
 506     *vptr = x[i];
 507 }
 508
 509 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 510 export_proto(gmtime_i8);
 511
 512 void
 513 gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 514 {
 515   int x[9], i;
 516   index_type len, delta;
 517   GFC_INTEGER_8 *vptr;
 518   time_t tt;
 519
 520   /* Call helper function.  */
 521   tt = (time_t) *t;
 522   gmtime_0(&tt, x);
 523
 524   /* Copy the values into the array.  */
 525   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 526   assert (len >= 9);
 527   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 528   if (delta == 0)
 529     delta = 1;
 530
 531   vptr = tarray->base_addr;
 532   for (i = 0; i < 9; i++, vptr += delta)
 533     *vptr = x[i];
 534 }
 535
 536
 537
 538
 539 /* LTIME(STIME, TARRAY) - Non-standard
 540
 541    Description: Given a system time value STime, fills TArray with values
 542    extracted from it appropriate to the local time zone using localtime_r(3).
 543
 544    The array elements are as follows:
 545
 546       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 547       2. Minutes after the hour, range 0-59
 548       3. Hours past midnight, range 0-23
 549       4. Day of month, range 1-31
 550       5. Number of months since January, range 0-11
 551       6. Years since 1900
 552       7. Number of days since Sunday, range 0-6
 553       8. Days since January 1, range 0-365
 554       9. Daylight savings indicator: positive if daylight savings is in effect,
 555          zero if not, and negative if the information isn't available.  */
 556
 557 static void
 558 ltime_0 (const time_t * t, int x[9])
 559 {
 560   struct tm lt;
 561
 562   localtime_r (t, &lt);
 563   x[0] = lt.tm_sec;
 564   x[1] = lt.tm_min;
 565   x[2] = lt.tm_hour;
 566   x[3] = lt.tm_mday;
 567   x[4] = lt.tm_mon;
 568   x[5] = lt.tm_year;
 569   x[6] = lt.tm_wday;
 570   x[7] = lt.tm_yday;
 571   x[8] = lt.tm_isdst;
 572 }
 573
 574 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 575 export_proto(ltime_i4);
 576
 577 void
 578 ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 579 {
 580   int x[9], i;
 581   index_type len, delta;
 582   GFC_INTEGER_4 *vptr;
 583   time_t tt;
 584
 585   /* Call helper function.  */
 586   tt = (time_t) *t;
 587   ltime_0(&tt, x);
 588
 589   /* Copy the values into the array.  */
 590   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 591   assert (len >= 9);
 592   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 593   if (delta == 0)
 594     delta = 1;
 595
 596   vptr = tarray->base_addr;
 597   for (i = 0; i < 9; i++, vptr += delta)
 598     *vptr = x[i];
 599 }
 600
 601 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 602 export_proto(ltime_i8);
 603
 604 void
 605 ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 606 {
 607   int x[9], i;
 608   index_type len, delta;
 609   GFC_INTEGER_8 *vptr;
 610   time_t tt;
 611
 612   /* Call helper function.  */
 613   tt = (time_t) * t;
 614   ltime_0(&tt, x);
 615
 616   /* Copy the values into the array.  */
 617   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 618   assert (len >= 9);
 619   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 620   if (delta == 0)
 621     delta = 1;
 622
 623   vptr = tarray->base_addr;
 624   for (i = 0; i < 9; i++, vptr += delta)
 625     *vptr = x[i];
 626 }
 627
 628