l4/pkg/libgfortran/lib/contrib/intrinsics/date_and_time.c

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