OSDN Git Service

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