OSDN Git Service

fa51d5f5ba287734ae5aa6c4e8f9abacbf91b6c8
[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 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