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