libgfortran/intrinsics/date_and_time.c

   1 /* Implementation of the DATE_AND_TIME intrinsic.
   2    Copyright (C) 2003, 2004, 2005, 2006, 2007, 2009, 2010, 2011
   3    Free Software Foundation, Inc.
   4    Contributed by Steven Bosscher.
   5
   6 This file is part of the GNU Fortran runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libgfortran.h"
  28 #include <string.h>
  29 #include <assert.h>
  30 #include <stdlib.h>
  31
  32 #include "time_1.h"
  33
  34 #ifndef abs
  35 #define abs(x) ((x)>=0 ? (x) : -(x))
  36 #endif
  37
  38
  39 /* If the re-entrant version of gmtime is not available, provide a
  40    fallback implementation.  On some targets where the _r version is
  41    not available, gmtime uses thread-local storage so it's
  42    threadsafe.  */
  43
  44 #ifndef HAVE_GMTIME_R
  45 /* If _POSIX is defined gmtime_r gets defined by mingw-w64 headers.  */
  46 #ifdef gmtime_r
  47 #undef gmtime_r
  48 #endif
  49
  50 static struct tm *
  51 gmtime_r (const time_t * timep, struct tm * result)
  52 {
  53   *result = *gmtime (timep);
  54   return result;
  55 }
  56 #endif
  57
  58
  59 /* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
  60
  61    Description: Returns data on the real-time clock and date in a form
  62    compatible with the representations defined in ISO 8601:1988.
  63
  64    Class: Non-elemental subroutine.
  65
  66    Arguments:
  67
  68    DATE (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 CCYYMMDD, where CC is the century, YY the year within the
  71    century, MM the month within the year, and DD the day within the
  72    month.  If there is no date available, they are assigned blanks.
  73
  74    TIME (optional) shall be scalar and of type default character.
  75    It is an INTENT(OUT) argument. It is assigned a value of the
  76    form hhmmss.sss, where hh is the hour of the day, mm is the
  77    minutes of the hour, and ss.sss is the seconds and milliseconds
  78    of the minute.  If there is no clock available, they are assigned
  79    blanks.
  80
  81    ZONE (optional) shall be scalar and of type default character.
  82    It is an INTENT(OUT) argument.  It is assigned a value of the
  83    form [+-]hhmm, where hh and mm are the time difference with
  84    respect to Coordinated Universal Time (UTC) in hours and parts
  85    of an hour expressed in minutes, respectively.  If there is no
  86    clock available, they are assigned blanks.
  87
  88    VALUES (optional) shall be of type default integer and of rank
  89    one. It is an INTENT(OUT) argument. Its size shall be at least
  90    8. The values returned in VALUES are as follows:
  91
  92       VALUES(1) the year (for example, 2003), or -HUGE(0) if there is
  93       no date available;
  94
  95       VALUES(2) the month of the year, or -HUGE(0) if there
  96       is no date available;
  97
  98       VALUES(3) the day of the month, or -HUGE(0) if there is no date
  99       available;
 100
 101       VALUES(4) the time difference with respect to Coordinated
 102       Universal Time (UTC) in minutes, or -HUGE(0) if this information
 103       is not available;
 104
 105       VALUES(5) the hour of the day, in the range of 0 to 23, or
 106       -HUGE(0) if there is no clock;
 107
 108       VALUES(6) the minutes of the hour, in the range 0 to 59, or
 109       -HUGE(0) if there is no clock;
 110
 111       VALUES(7) the seconds of the minute, in the range 0 to 60, or
 112       -HUGE(0) if there is no clock;
 113
 114       VALUES(8) the milliseconds of the second, in the range 0 to
 115       999, or -HUGE(0) if there is no clock.
 116
 117    NULL pointer represent missing OPTIONAL arguments.  All arguments
 118    have INTENT(OUT).  Because of the -i8 option, we must implement
 119    VALUES for INTEGER(kind=4) and INTEGER(kind=8).
 120
 121    Based on libU77's date_time_.c.
 122
 123    TODO :
 124    - Check year boundaries.
 125 */
 126 #define DATE_LEN 8
 127 #define TIME_LEN 10
 128 #define ZONE_LEN 5
 129 #define VALUES_SIZE 8
 130
 131 extern void date_and_time (char *, char *, char *, gfc_array_i4 *,
 132                            GFC_INTEGER_4, GFC_INTEGER_4, GFC_INTEGER_4);
 133 export_proto(date_and_time);
 134
 135 void
 136 date_and_time (char *__date, char *__time, char *__zone,
 137                gfc_array_i4 *__values, GFC_INTEGER_4 __date_len,
 138                GFC_INTEGER_4 __time_len, GFC_INTEGER_4 __zone_len)
 139 {
 140   int i;
 141   char date[DATE_LEN + 1];
 142   char timec[TIME_LEN + 1];
 143   char zone[ZONE_LEN + 1];
 144   GFC_INTEGER_4 values[VALUES_SIZE];
 145
 146 #ifndef HAVE_NO_DATE_TIME
 147   time_t lt;
 148   struct tm local_time;
 149   struct tm UTC_time;
 150
 151   long usecs;
 152
 153   if (!gf_gettime (&lt, &usecs))
 154     {
 155       values[7] = usecs / 1000;
 156
 157       localtime_r (&lt, &local_time);
 158       gmtime_r (&lt, &UTC_time);
 159
 160       /* All arguments can be derived from VALUES.  */
 161       values[0] = 1900 + local_time.tm_year;
 162       values[1] = 1 + local_time.tm_mon;
 163       values[2] = local_time.tm_mday;
 164       values[3] = (local_time.tm_min - UTC_time.tm_min +
 165                    60 * (local_time.tm_hour - UTC_time.tm_hour +
 166                      24 * (local_time.tm_yday - UTC_time.tm_yday)));
 167       values[4] = local_time.tm_hour;
 168       values[5] = local_time.tm_min;
 169       values[6] = local_time.tm_sec;
 170
 171 #if HAVE_SNPRINTF
 172       if (__date)
 173         snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
 174                   values[0], values[1], values[2]);
 175       if (__time)
 176         snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
 177                   values[4], values[5], values[6], values[7]);
 178
 179       if (__zone)
 180         snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
 181                   values[3] / 60, abs (values[3] % 60));
 182 #else
 183       if (__date)
 184         sprintf (date, "%04d%02d%02d", values[0], values[1], values[2]);
 185
 186       if (__time)
 187         sprintf (timec, "%02d%02d%02d.%03d",
 188                  values[4], values[5], values[6], values[7]);
 189
 190       if (__zone)
 191         sprintf (zone, "%+03d%02d",
 192                  values[3] / 60, abs (values[3] % 60));
 193 #endif
 194     }
 195   else
 196     {
 197       memset (date, ' ', DATE_LEN);
 198       date[DATE_LEN] = '\0';
 199
 200       memset (timec, ' ', TIME_LEN);
 201       timec[TIME_LEN] = '\0';
 202
 203       memset (zone, ' ', ZONE_LEN);
 204       zone[ZONE_LEN] = '\0';
 205
 206       for (i = 0; i < VALUES_SIZE; i++)
 207         values[i] = - GFC_INTEGER_4_HUGE;
 208     }
 209 #else /* if defined HAVE_NO_DATE_TIME  */
 210   /* We really have *nothing* to return, so return blanks and HUGE(0).  */
 211
 212   memset (date, ' ', DATE_LEN);
 213   date[DATE_LEN] = '\0';
 214
 215   memset (timec, ' ', TIME_LEN);
 216   timec[TIME_LEN] = '\0';
 217
 218   memset (zone, ' ', ZONE_LEN);
 219   zone[ZONE_LEN] = '\0';
 220
 221   for (i = 0; i < VALUES_SIZE; i++)
 222     values[i] = - GFC_INTEGER_4_HUGE;
 223 #endif  /* HAVE_NO_DATE_TIME  */
 224
 225   /* Copy the values into the arguments.  */
 226   if (__values)
 227     {
 228       index_type len, delta, elt_size;
 229
 230       elt_size = GFC_DESCRIPTOR_SIZE (__values);
 231       len = GFC_DESCRIPTOR_EXTENT(__values,0);
 232       delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 233       if (delta == 0)
 234         delta = 1;
 235
 236       if (unlikely (len < VALUES_SIZE))
 237           runtime_error ("Incorrect extent in VALUE argument to"
 238                          " DATE_AND_TIME intrinsic: is %ld, should"
 239                          " be >=%ld", (long int) len, (long int) VALUES_SIZE);
 240
 241       /* Cope with different type kinds.  */
 242       if (elt_size == 4)
 243         {
 244           GFC_INTEGER_4 *vptr4 = __values->data;
 245
 246           for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
 247             *vptr4 = values[i];
 248         }
 249       else if (elt_size == 8)
 250         {
 251           GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data;
 252
 253           for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
 254             {
 255               if (values[i] == - GFC_INTEGER_4_HUGE)
 256                 *vptr8 = - GFC_INTEGER_8_HUGE;
 257               else
 258                 *vptr8 = values[i];
 259             }
 260         }
 261       else
 262         abort ();
 263     }
 264
 265   if (__zone)
 266     fstrcpy (__zone, __zone_len, zone, ZONE_LEN);
 267
 268   if (__time)
 269     fstrcpy (__time, __time_len, timec, TIME_LEN);
 270
 271   if (__date)
 272     fstrcpy (__date, __date_len, date, DATE_LEN);
 273 }
 274
 275
 276 /* SECNDS (X) - Non-standard
 277
 278    Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
 279    in seconds.
 280
 281    Class: Non-elemental subroutine.
 282
 283    Arguments:
 284
 285    X must be REAL(4) and the result is of the same type.  The accuracy is system
 286    dependent.
 287
 288    Usage:
 289
 290         T = SECNDS (X)
 291
 292    yields the time in elapsed seconds since X.  If X is 0.0, T is the time in
 293    seconds since midnight. Note that a time that spans midnight but is less than
 294    24hours will be calculated correctly.  */
 295
 296 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
 297 export_proto(secnds);
 298
 299 GFC_REAL_4
 300 secnds (GFC_REAL_4 *x)
 301 {
 302   GFC_INTEGER_4 values[VALUES_SIZE];
 303   GFC_REAL_4 temp1, temp2;
 304
 305   /* Make the INTEGER*4 array for passing to date_and_time.  */
 306   gfc_array_i4 *avalues = internal_malloc_size (sizeof (gfc_array_i4));
 307   avalues->data = &values[0];
 308   GFC_DESCRIPTOR_DTYPE (avalues) = ((BT_REAL << GFC_DTYPE_TYPE_SHIFT)
 309                                         & GFC_DTYPE_TYPE_MASK) +
 310                                     (4 << GFC_DTYPE_SIZE_SHIFT);
 311
 312   GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1);
 313
 314   date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
 315
 316   free (avalues);
 317
 318   temp1 = 3600.0 * (GFC_REAL_4)values[4] +
 319             60.0 * (GFC_REAL_4)values[5] +
 320                    (GFC_REAL_4)values[6] +
 321            0.001 * (GFC_REAL_4)values[7];
 322   temp2 = fmod (*x, 86400.0);
 323   temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0);
 324   return temp1 - temp2;
 325 }
 326
 327
 328
 329 /* ITIME(X) - Non-standard
 330
 331    Description: Returns the current local time hour, minutes, and seconds
 332    in elements 1, 2, and 3 of X, respectively.  */
 333
 334 static void
 335 itime0 (int x[3])
 336 {
 337 #ifndef HAVE_NO_DATE_TIME
 338   time_t lt;
 339   struct tm local_time;
 340
 341   lt = time (NULL);
 342
 343   if (lt != (time_t) -1)
 344     {
 345       localtime_r (&lt, &local_time);
 346
 347       x[0] = local_time.tm_hour;
 348       x[1] = local_time.tm_min;
 349       x[2] = local_time.tm_sec;
 350     }
 351 #else
 352   x[0] = x[1] = x[2] = -1;
 353 #endif
 354 }
 355
 356 extern void itime_i4 (gfc_array_i4 *);
 357 export_proto(itime_i4);
 358
 359 void
 360 itime_i4 (gfc_array_i4 *__values)
 361 {
 362   int x[3], i;
 363   index_type len, delta;
 364   GFC_INTEGER_4 *vptr;
 365
 366   /* Call helper function.  */
 367   itime0(x);
 368
 369   /* Copy the value into the array.  */
 370   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 371   assert (len >= 3);
 372   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 373   if (delta == 0)
 374     delta = 1;
 375
 376   vptr = __values->data;
 377   for (i = 0; i < 3; i++, vptr += delta)
 378     *vptr = x[i];
 379 }
 380
 381
 382 extern void itime_i8 (gfc_array_i8 *);
 383 export_proto(itime_i8);
 384
 385 void
 386 itime_i8 (gfc_array_i8 *__values)
 387 {
 388   int x[3], i;
 389   index_type len, delta;
 390   GFC_INTEGER_8 *vptr;
 391
 392   /* Call helper function.  */
 393   itime0(x);
 394
 395   /* Copy the value into the array.  */
 396   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 397   assert (len >= 3);
 398   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 399   if (delta == 0)
 400     delta = 1;
 401
 402   vptr = __values->data;
 403   for (i = 0; i < 3; i++, vptr += delta)
 404     *vptr = x[i];
 405 }
 406
 407
 408
 409 /* IDATE(X) - Non-standard
 410
 411    Description: Fills TArray with the numerical values at the current
 412    local time. The day (in the range 1-31), month (in the range 1-12),
 413    and year appear in elements 1, 2, and 3 of X, respectively.
 414    The year has four significant digits.  */
 415
 416 static void
 417 idate0 (int x[3])
 418 {
 419 #ifndef HAVE_NO_DATE_TIME
 420   time_t lt;
 421   struct tm local_time;
 422
 423   lt = time (NULL);
 424
 425   if (lt != (time_t) -1)
 426     {
 427       localtime_r (&lt, &local_time);
 428
 429       x[0] = local_time.tm_mday;
 430       x[1] = 1 + local_time.tm_mon;
 431       x[2] = 1900 + local_time.tm_year;
 432     }
 433 #else
 434   x[0] = x[1] = x[2] = -1;
 435 #endif
 436 }
 437
 438 extern void idate_i4 (gfc_array_i4 *);
 439 export_proto(idate_i4);
 440
 441 void
 442 idate_i4 (gfc_array_i4 *__values)
 443 {
 444   int x[3], i;
 445   index_type len, delta;
 446   GFC_INTEGER_4 *vptr;
 447
 448   /* Call helper function.  */
 449   idate0(x);
 450
 451   /* Copy the value into the array.  */
 452   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 453   assert (len >= 3);
 454   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 455   if (delta == 0)
 456     delta = 1;
 457
 458   vptr = __values->data;
 459   for (i = 0; i < 3; i++, vptr += delta)
 460     *vptr = x[i];
 461 }
 462
 463
 464 extern void idate_i8 (gfc_array_i8 *);
 465 export_proto(idate_i8);
 466
 467 void
 468 idate_i8 (gfc_array_i8 *__values)
 469 {
 470   int x[3], i;
 471   index_type len, delta;
 472   GFC_INTEGER_8 *vptr;
 473
 474   /* Call helper function.  */
 475   idate0(x);
 476
 477   /* Copy the value into the array.  */
 478   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 479   assert (len >= 3);
 480   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 481   if (delta == 0)
 482     delta = 1;
 483
 484   vptr = __values->data;
 485   for (i = 0; i < 3; i++, vptr += delta)
 486     *vptr = x[i];
 487 }
 488
 489
 490
 491 /* GMTIME(STIME, TARRAY) - Non-standard
 492
 493    Description: Given a system time value STime, fills TArray with values
 494    extracted from it appropriate to the GMT time zone using gmtime_r(3).
 495
 496    The array elements are as follows:
 497
 498       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 499       2. Minutes after the hour, range 0-59
 500       3. Hours past midnight, range 0-23
 501       4. Day of month, range 0-31
 502       5. Number of months since January, range 0-11
 503       6. Years since 1900
 504       7. Number of days since Sunday, range 0-6
 505       8. Days since January 1
 506       9. Daylight savings indicator: positive if daylight savings is in effect,
 507          zero if not, and negative if the information isn't available.  */
 508
 509 static void
 510 gmtime_0 (const time_t * t, int x[9])
 511 {
 512   struct tm lt;
 513
 514   gmtime_r (t, &lt);
 515   x[0] = lt.tm_sec;
 516   x[1] = lt.tm_min;
 517   x[2] = lt.tm_hour;
 518   x[3] = lt.tm_mday;
 519   x[4] = lt.tm_mon;
 520   x[5] = lt.tm_year;
 521   x[6] = lt.tm_wday;
 522   x[7] = lt.tm_yday;
 523   x[8] = lt.tm_isdst;
 524 }
 525
 526 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 527 export_proto(gmtime_i4);
 528
 529 void
 530 gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 531 {
 532   int x[9], i;
 533   index_type len, delta;
 534   GFC_INTEGER_4 *vptr;
 535   time_t tt;
 536
 537   /* Call helper function.  */
 538   tt = (time_t) *t;
 539   gmtime_0(&tt, x);
 540
 541   /* Copy the values into the array.  */
 542   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 543   assert (len >= 9);
 544   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 545   if (delta == 0)
 546     delta = 1;
 547
 548   vptr = tarray->data;
 549   for (i = 0; i < 9; i++, vptr += delta)
 550     *vptr = x[i];
 551 }
 552
 553 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 554 export_proto(gmtime_i8);
 555
 556 void
 557 gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 558 {
 559   int x[9], i;
 560   index_type len, delta;
 561   GFC_INTEGER_8 *vptr;
 562   time_t tt;
 563
 564   /* Call helper function.  */
 565   tt = (time_t) *t;
 566   gmtime_0(&tt, x);
 567
 568   /* Copy the values into the array.  */
 569   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 570   assert (len >= 9);
 571   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 572   if (delta == 0)
 573     delta = 1;
 574
 575   vptr = tarray->data;
 576   for (i = 0; i < 9; i++, vptr += delta)
 577     *vptr = x[i];
 578 }
 579
 580
 581
 582
 583 /* LTIME(STIME, TARRAY) - Non-standard
 584
 585    Description: Given a system time value STime, fills TArray with values
 586    extracted from it appropriate to the local time zone using localtime_r(3).
 587
 588    The array elements are as follows:
 589
 590       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 591       2. Minutes after the hour, range 0-59
 592       3. Hours past midnight, range 0-23
 593       4. Day of month, range 0-31
 594       5. Number of months since January, range 0-11
 595       6. Years since 1900
 596       7. Number of days since Sunday, range 0-6
 597       8. Days since January 1
 598       9. Daylight savings indicator: positive if daylight savings is in effect,
 599          zero if not, and negative if the information isn't available.  */
 600
 601 static void
 602 ltime_0 (const time_t * t, int x[9])
 603 {
 604   struct tm lt;
 605
 606   localtime_r (t, &lt);
 607   x[0] = lt.tm_sec;
 608   x[1] = lt.tm_min;
 609   x[2] = lt.tm_hour;
 610   x[3] = lt.tm_mday;
 611   x[4] = lt.tm_mon;
 612   x[5] = lt.tm_year;
 613   x[6] = lt.tm_wday;
 614   x[7] = lt.tm_yday;
 615   x[8] = lt.tm_isdst;
 616 }
 617
 618 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 619 export_proto(ltime_i4);
 620
 621 void
 622 ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 623 {
 624   int x[9], i;
 625   index_type len, delta;
 626   GFC_INTEGER_4 *vptr;
 627   time_t tt;
 628
 629   /* Call helper function.  */
 630   tt = (time_t) *t;
 631   ltime_0(&tt, x);
 632
 633   /* Copy the values into the array.  */
 634   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 635   assert (len >= 9);
 636   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 637   if (delta == 0)
 638     delta = 1;
 639
 640   vptr = tarray->data;
 641   for (i = 0; i < 9; i++, vptr += delta)
 642     *vptr = x[i];
 643 }
 644
 645 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 646 export_proto(ltime_i8);
 647
 648 void
 649 ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 650 {
 651   int x[9], i;
 652   index_type len, delta;
 653   GFC_INTEGER_8 *vptr;
 654   time_t tt;
 655
 656   /* Call helper function.  */
 657   tt = (time_t) * t;
 658   ltime_0(&tt, x);
 659
 660   /* Copy the values into the array.  */
 661   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 662   assert (len >= 9);
 663   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 664   if (delta == 0)
 665     delta = 1;
 666
 667   vptr = tarray->data;
 668   for (i = 0; i < 9; i++, vptr += delta)
 669     *vptr = x[i];
 670 }
 671
 672