OSDN Git Service

Configure 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
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