libgfortran/intrinsics/date_and_time.c

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