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 (__date)
 172         snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
 173                   values[0], values[1], values[2]);
 174       if (__time)
 175         snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
 176                   values[4], values[5], values[6], values[7]);
 177
 178       if (__zone)
 179         snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
 180                   values[3] / 60, abs (values[3] % 60));
 181     }
 182   else
 183     {
 184       memset (date, ' ', DATE_LEN);
 185       date[DATE_LEN] = '\0';
 186
 187       memset (timec, ' ', TIME_LEN);
 188       timec[TIME_LEN] = '\0';
 189
 190       memset (zone, ' ', ZONE_LEN);
 191       zone[ZONE_LEN] = '\0';
 192
 193       for (i = 0; i < VALUES_SIZE; i++)
 194         values[i] = - GFC_INTEGER_4_HUGE;
 195     }
 196 #else /* if defined HAVE_NO_DATE_TIME  */
 197   /* We really have *nothing* to return, so return blanks and HUGE(0).  */
 198
 199   memset (date, ' ', DATE_LEN);
 200   date[DATE_LEN] = '\0';
 201
 202   memset (timec, ' ', TIME_LEN);
 203   timec[TIME_LEN] = '\0';
 204
 205   memset (zone, ' ', ZONE_LEN);
 206   zone[ZONE_LEN] = '\0';
 207
 208   for (i = 0; i < VALUES_SIZE; i++)
 209     values[i] = - GFC_INTEGER_4_HUGE;
 210 #endif  /* HAVE_NO_DATE_TIME  */
 211
 212   /* Copy the values into the arguments.  */
 213   if (__values)
 214     {
 215       index_type len, delta, elt_size;
 216
 217       elt_size = GFC_DESCRIPTOR_SIZE (__values);
 218       len = GFC_DESCRIPTOR_EXTENT(__values,0);
 219       delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 220       if (delta == 0)
 221         delta = 1;
 222
 223       if (unlikely (len < VALUES_SIZE))
 224           runtime_error ("Incorrect extent in VALUE argument to"
 225                          " DATE_AND_TIME intrinsic: is %ld, should"
 226                          " be >=%ld", (long int) len, (long int) VALUES_SIZE);
 227
 228       /* Cope with different type kinds.  */
 229       if (elt_size == 4)
 230         {
 231           GFC_INTEGER_4 *vptr4 = __values->data;
 232
 233           for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
 234             *vptr4 = values[i];
 235         }
 236       else if (elt_size == 8)
 237         {
 238           GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data;
 239
 240           for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
 241             {
 242               if (values[i] == - GFC_INTEGER_4_HUGE)
 243                 *vptr8 = - GFC_INTEGER_8_HUGE;
 244               else
 245                 *vptr8 = values[i];
 246             }
 247         }
 248       else
 249         abort ();
 250     }
 251
 252   if (__zone)
 253     fstrcpy (__zone, __zone_len, zone, ZONE_LEN);
 254
 255   if (__time)
 256     fstrcpy (__time, __time_len, timec, TIME_LEN);
 257
 258   if (__date)
 259     fstrcpy (__date, __date_len, date, DATE_LEN);
 260 }
 261
 262
 263 /* SECNDS (X) - Non-standard
 264
 265    Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4
 266    in seconds.
 267
 268    Class: Non-elemental subroutine.
 269
 270    Arguments:
 271
 272    X must be REAL(4) and the result is of the same type.  The accuracy is system
 273    dependent.
 274
 275    Usage:
 276
 277         T = SECNDS (X)
 278
 279    yields the time in elapsed seconds since X.  If X is 0.0, T is the time in
 280    seconds since midnight. Note that a time that spans midnight but is less than
 281    24hours will be calculated correctly.  */
 282
 283 extern GFC_REAL_4 secnds (GFC_REAL_4 *);
 284 export_proto(secnds);
 285
 286 GFC_REAL_4
 287 secnds (GFC_REAL_4 *x)
 288 {
 289   GFC_INTEGER_4 values[VALUES_SIZE];
 290   GFC_REAL_4 temp1, temp2;
 291
 292   /* Make the INTEGER*4 array for passing to date_and_time.  */
 293   gfc_array_i4 *avalues = internal_malloc_size (sizeof (gfc_array_i4));
 294   avalues->data = &values[0];
 295   GFC_DESCRIPTOR_DTYPE (avalues) = ((BT_REAL << GFC_DTYPE_TYPE_SHIFT)
 296                                         & GFC_DTYPE_TYPE_MASK) +
 297                                     (4 << GFC_DTYPE_SIZE_SHIFT);
 298
 299   GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1);
 300
 301   date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);
 302
 303   free (avalues);
 304
 305   temp1 = 3600.0 * (GFC_REAL_4)values[4] +
 306             60.0 * (GFC_REAL_4)values[5] +
 307                    (GFC_REAL_4)values[6] +
 308            0.001 * (GFC_REAL_4)values[7];
 309   temp2 = fmod (*x, 86400.0);
 310   temp2 = (temp1 - temp2 >= 0.0) ? temp2 : (temp2 - 86400.0);
 311   return temp1 - temp2;
 312 }
 313
 314
 315
 316 /* ITIME(X) - Non-standard
 317
 318    Description: Returns the current local time hour, minutes, and seconds
 319    in elements 1, 2, and 3 of X, respectively.  */
 320
 321 static void
 322 itime0 (int x[3])
 323 {
 324 #ifndef HAVE_NO_DATE_TIME
 325   time_t lt;
 326   struct tm local_time;
 327
 328   lt = time (NULL);
 329
 330   if (lt != (time_t) -1)
 331     {
 332       localtime_r (&lt, &local_time);
 333
 334       x[0] = local_time.tm_hour;
 335       x[1] = local_time.tm_min;
 336       x[2] = local_time.tm_sec;
 337     }
 338 #else
 339   x[0] = x[1] = x[2] = -1;
 340 #endif
 341 }
 342
 343 extern void itime_i4 (gfc_array_i4 *);
 344 export_proto(itime_i4);
 345
 346 void
 347 itime_i4 (gfc_array_i4 *__values)
 348 {
 349   int x[3], i;
 350   index_type len, delta;
 351   GFC_INTEGER_4 *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->data;
 364   for (i = 0; i < 3; i++, vptr += delta)
 365     *vptr = x[i];
 366 }
 367
 368
 369 extern void itime_i8 (gfc_array_i8 *);
 370 export_proto(itime_i8);
 371
 372 void
 373 itime_i8 (gfc_array_i8 *__values)
 374 {
 375   int x[3], i;
 376   index_type len, delta;
 377   GFC_INTEGER_8 *vptr;
 378
 379   /* Call helper function.  */
 380   itime0(x);
 381
 382   /* Copy the value into the array.  */
 383   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 384   assert (len >= 3);
 385   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 386   if (delta == 0)
 387     delta = 1;
 388
 389   vptr = __values->data;
 390   for (i = 0; i < 3; i++, vptr += delta)
 391     *vptr = x[i];
 392 }
 393
 394
 395
 396 /* IDATE(X) - Non-standard
 397
 398    Description: Fills TArray with the numerical values at the current
 399    local time. The day (in the range 1-31), month (in the range 1-12),
 400    and year appear in elements 1, 2, and 3 of X, respectively.
 401    The year has four significant digits.  */
 402
 403 static void
 404 idate0 (int x[3])
 405 {
 406 #ifndef HAVE_NO_DATE_TIME
 407   time_t lt;
 408   struct tm local_time;
 409
 410   lt = time (NULL);
 411
 412   if (lt != (time_t) -1)
 413     {
 414       localtime_r (&lt, &local_time);
 415
 416       x[0] = local_time.tm_mday;
 417       x[1] = 1 + local_time.tm_mon;
 418       x[2] = 1900 + local_time.tm_year;
 419     }
 420 #else
 421   x[0] = x[1] = x[2] = -1;
 422 #endif
 423 }
 424
 425 extern void idate_i4 (gfc_array_i4 *);
 426 export_proto(idate_i4);
 427
 428 void
 429 idate_i4 (gfc_array_i4 *__values)
 430 {
 431   int x[3], i;
 432   index_type len, delta;
 433   GFC_INTEGER_4 *vptr;
 434
 435   /* Call helper function.  */
 436   idate0(x);
 437
 438   /* Copy the value into the array.  */
 439   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 440   assert (len >= 3);
 441   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 442   if (delta == 0)
 443     delta = 1;
 444
 445   vptr = __values->data;
 446   for (i = 0; i < 3; i++, vptr += delta)
 447     *vptr = x[i];
 448 }
 449
 450
 451 extern void idate_i8 (gfc_array_i8 *);
 452 export_proto(idate_i8);
 453
 454 void
 455 idate_i8 (gfc_array_i8 *__values)
 456 {
 457   int x[3], i;
 458   index_type len, delta;
 459   GFC_INTEGER_8 *vptr;
 460
 461   /* Call helper function.  */
 462   idate0(x);
 463
 464   /* Copy the value into the array.  */
 465   len = GFC_DESCRIPTOR_EXTENT(__values,0);
 466   assert (len >= 3);
 467   delta = GFC_DESCRIPTOR_STRIDE(__values,0);
 468   if (delta == 0)
 469     delta = 1;
 470
 471   vptr = __values->data;
 472   for (i = 0; i < 3; i++, vptr += delta)
 473     *vptr = x[i];
 474 }
 475
 476
 477
 478 /* GMTIME(STIME, TARRAY) - Non-standard
 479
 480    Description: Given a system time value STime, fills TArray with values
 481    extracted from it appropriate to the GMT time zone using gmtime_r(3).
 482
 483    The array elements are as follows:
 484
 485       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 486       2. Minutes after the hour, range 0-59
 487       3. Hours past midnight, range 0-23
 488       4. Day of month, range 0-31
 489       5. Number of months since January, range 0-11
 490       6. Years since 1900
 491       7. Number of days since Sunday, range 0-6
 492       8. Days since January 1
 493       9. Daylight savings indicator: positive if daylight savings is in effect,
 494          zero if not, and negative if the information isn't available.  */
 495
 496 static void
 497 gmtime_0 (const time_t * t, int x[9])
 498 {
 499   struct tm lt;
 500
 501   gmtime_r (t, &lt);
 502   x[0] = lt.tm_sec;
 503   x[1] = lt.tm_min;
 504   x[2] = lt.tm_hour;
 505   x[3] = lt.tm_mday;
 506   x[4] = lt.tm_mon;
 507   x[5] = lt.tm_year;
 508   x[6] = lt.tm_wday;
 509   x[7] = lt.tm_yday;
 510   x[8] = lt.tm_isdst;
 511 }
 512
 513 extern void gmtime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 514 export_proto(gmtime_i4);
 515
 516 void
 517 gmtime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 518 {
 519   int x[9], i;
 520   index_type len, delta;
 521   GFC_INTEGER_4 *vptr;
 522   time_t tt;
 523
 524   /* Call helper function.  */
 525   tt = (time_t) *t;
 526   gmtime_0(&tt, x);
 527
 528   /* Copy the values into the array.  */
 529   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 530   assert (len >= 9);
 531   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 532   if (delta == 0)
 533     delta = 1;
 534
 535   vptr = tarray->data;
 536   for (i = 0; i < 9; i++, vptr += delta)
 537     *vptr = x[i];
 538 }
 539
 540 extern void gmtime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 541 export_proto(gmtime_i8);
 542
 543 void
 544 gmtime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 545 {
 546   int x[9], i;
 547   index_type len, delta;
 548   GFC_INTEGER_8 *vptr;
 549   time_t tt;
 550
 551   /* Call helper function.  */
 552   tt = (time_t) *t;
 553   gmtime_0(&tt, x);
 554
 555   /* Copy the values into the array.  */
 556   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 557   assert (len >= 9);
 558   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 559   if (delta == 0)
 560     delta = 1;
 561
 562   vptr = tarray->data;
 563   for (i = 0; i < 9; i++, vptr += delta)
 564     *vptr = x[i];
 565 }
 566
 567
 568
 569
 570 /* LTIME(STIME, TARRAY) - Non-standard
 571
 572    Description: Given a system time value STime, fills TArray with values
 573    extracted from it appropriate to the local time zone using localtime_r(3).
 574
 575    The array elements are as follows:
 576
 577       1. Seconds after the minute, range 0-59 or 0-61 to allow for leap seconds
 578       2. Minutes after the hour, range 0-59
 579       3. Hours past midnight, range 0-23
 580       4. Day of month, range 0-31
 581       5. Number of months since January, range 0-11
 582       6. Years since 1900
 583       7. Number of days since Sunday, range 0-6
 584       8. Days since January 1
 585       9. Daylight savings indicator: positive if daylight savings is in effect,
 586          zero if not, and negative if the information isn't available.  */
 587
 588 static void
 589 ltime_0 (const time_t * t, int x[9])
 590 {
 591   struct tm lt;
 592
 593   localtime_r (t, &lt);
 594   x[0] = lt.tm_sec;
 595   x[1] = lt.tm_min;
 596   x[2] = lt.tm_hour;
 597   x[3] = lt.tm_mday;
 598   x[4] = lt.tm_mon;
 599   x[5] = lt.tm_year;
 600   x[6] = lt.tm_wday;
 601   x[7] = lt.tm_yday;
 602   x[8] = lt.tm_isdst;
 603 }
 604
 605 extern void ltime_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 606 export_proto(ltime_i4);
 607
 608 void
 609 ltime_i4 (GFC_INTEGER_4 * t, gfc_array_i4 * tarray)
 610 {
 611   int x[9], i;
 612   index_type len, delta;
 613   GFC_INTEGER_4 *vptr;
 614   time_t tt;
 615
 616   /* Call helper function.  */
 617   tt = (time_t) *t;
 618   ltime_0(&tt, x);
 619
 620   /* Copy the values into the array.  */
 621   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 622   assert (len >= 9);
 623   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 624   if (delta == 0)
 625     delta = 1;
 626
 627   vptr = tarray->data;
 628   for (i = 0; i < 9; i++, vptr += delta)
 629     *vptr = x[i];
 630 }
 631
 632 extern void ltime_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 633 export_proto(ltime_i8);
 634
 635 void
 636 ltime_i8 (GFC_INTEGER_8 * t, gfc_array_i8 * tarray)
 637 {
 638   int x[9], i;
 639   index_type len, delta;
 640   GFC_INTEGER_8 *vptr;
 641   time_t tt;
 642
 643   /* Call helper function.  */
 644   tt = (time_t) * t;
 645   ltime_0(&tt, x);
 646
 647   /* Copy the values into the array.  */
 648   len = GFC_DESCRIPTOR_EXTENT(tarray,0);
 649   assert (len >= 9);
 650   delta = GFC_DESCRIPTOR_STRIDE(tarray,0);
 651   if (delta == 0)
 652     delta = 1;
 653
 654   vptr = tarray->data;
 655   for (i = 0; i < 9; i++, vptr += delta)
 656     *vptr = x[i];
 657 }
 658
 659