In date_and_time.c, 'time' is called. If the routine then goes on to call
'gettimeofday', it extracts the milliseconds value from the 'gettimeofday'
call, but gets the seconds value from the old call to 'time'. This can result
in consecutive times of (say)
2006 11 29 12 4 34 999
2006 11 29 12 4 34 0
being generated. Notice that the seconds in the later call have not 'ticked
over',
because they refer to the earlier time value accessed by 'time', while the
milliseconds refer to the "correct" value accessed by gettimeofday.
Here is our test code:
!!!!!!!!!!!!!!!!!!!! Test program for DATE_AND_TIME
PROGRAM DATE_AND_TIME_TEST
! .. Implicit None Statement ..
IMPLICIT NONE
! .. Parameters ..
INTEGER, PARAMETER :: NOUT = 6
INTEGER, PARAMETER :: WP = KIND(0.0D0)
! .. Non-Generic Interface Blocks ..
INTERFACE
FUNCTION ORDER_TIME(ITIME1,ITIME2)
! .. Function Return Value ..
INTEGER :: ORDER_TIME
! .. Array Arguments ..
INTEGER, INTENT (IN) :: ITIME1(7), ITIME2(7)
END FUNCTION ORDER_TIME
END INTERFACE
! .. Local Scalars ..
REAL (KIND=WP) :: E, ETOL, EXPE, T
INTEGER :: I, N, NFAILS
LOGICAL :: PASS
! .. Local Arrays ..
INTEGER :: DATE_TIME(8), ITIME1(7), ITIME2(7)
! .. Intrinsic Functions ..
INTRINSIC ABS, DATE_AND_TIME, KIND, MIN
! .. Executable Statements ..
CONTINUE
PASS = .TRUE.
EXPE = 2.718281828E0_WP
! Make up to 10000 calls of DATE_AND_TIME and check that they return
! monotonic non-decreasing times, by calling ORDER_TIME.
NFAILS = 0
CALL DATE_AND_TIME(VALUES=DATE_TIME)
ITIME2(1:3) = DATE_TIME(1:3)
ITIME2(4:7) = DATE_TIME(5:8)
! Output start time.
WRITE (NOUT,FMT=99991) ITIME2(1:7)
I = 2
DO
! Save the old time in ITIME1.
ITIME1(1:7) = ITIME2(1:7)
! Delay a bit by computing e.
ETOL = 0.001_WP
E = 1.0E0_WP
T = 1.0E0_WP
DO N = 1, 100000 - MIN(I,6)
T = T/N
E = E + T
END DO
! This test is just so that E gets used and the loop
! above isn't optimised away.
IF (ABS(E-EXPE)>ETOL) THEN
IF (PASS) THEN
PASS = .FALSE.
WRITE (NOUT,FMT=99999) E, EXPE
END IF
END IF
! Get the new time in ITIME2.
CALL DATE_AND_TIME(VALUES=DATE_TIME)
ITIME2(1:3) = DATE_TIME(1:3)
ITIME2(4:7) = DATE_TIME(5:8)
IF (ORDER_TIME(ITIME1,ITIME2)==1 .AND. NFAILS<5) THEN
NFAILS = NFAILS + 1
PASS = .FALSE.
WRITE (NOUT,FMT=99998) ITIME1, ITIME2
END IF
! Continue round the loop up to at most 10000 times, unless at
! least two different times have been found and we've done
! the loop at least 1000 times.
IF ((ORDER_TIME(ITIME1,ITIME2)/=-1 .AND. I<10000) .OR. I<1000) THEN
I = I + 1
ELSE
EXIT
END IF
END DO
! Make one final check to ensure that all the times in the loop
! above were not identical.
! Output end time.
WRITE (NOUT,FMT=99990) ITIME2(1:7)
IF (ORDER_TIME(ITIME1,ITIME2)/=-1 .AND. NFAILS<5) THEN
PASS = .FALSE.
WRITE (NOUT,FMT=99997) ITIME1, ITIME2
END IF
IF (PASS) THEN
WRITE (NOUT,FMT=99996)
ELSE
WRITE (NOUT,FMT=99995)
END IF
99999 FORMAT (1X/1X,'Computed e as ',1P,E13.5,' instead of ',E13.5)
99998 FORMAT (1X/1X,'Two consecutive calls of DATE_AND_TIME returned:', &
2(/1X,7I5)/2X, &
'- the first should be not later than the second but is.')
99997 FORMAT (1X/1X,'Two calls of DATE_AND_TIME returned:',2(/1X,7I5)/2X, &
'- the first should be earlier than the second but is not.')
99996 FORMAT (1X/1X,'TEST OF DATE_AND_TIME PASSED OK')
99995 FORMAT (1X/1X,'TEST OF DATE_AND_TIME FAILS')
99991 FORMAT (1X,'*** Started at',7I5)
99990 FORMAT (1X/1X,'***** Ended at',7I5)
END PROGRAM DATE_AND_TIME_TEST
FUNCTION ORDER_TIME(ITIME1,ITIME2)
! .. Implicit None Statement ..
IMPLICIT NONE
! .. Function Return Value ..
INTEGER :: ORDER_TIME
! .. Parameters ..
INTEGER, PARAMETER :: WP = KIND(0.0D0)
! .. Array Arguments ..
INTEGER, INTENT (IN) :: ITIME1(7), ITIME2(7)
! .. Local Scalars ..
INTEGER :: I
! .. Intrinsic Functions ..
INTRINSIC KIND
! .. Executable Statements ..
CONTINUE
! Compare the integer array format times.
I = 1
DO
IF (ITIME1(I)==ITIME2(I) .AND. I<7) THEN
I = I + 1
ELSE
EXIT
END IF
END DO
IF (ITIME1(I)<ITIME2(I)) THEN
ORDER_TIME = -1
ELSE IF (ITIME1(I)==ITIME2(I)) THEN
ORDER_TIME = 0
ELSE
ORDER_TIME = 1
END IF
RETURN
END FUNCTION ORDER_TIME
!!!!!!!!!!!!!!!!!!!! End of test program for DATE_AND_TIME
The fix to date_and_time is pretty obvious. Here's how we made the relevant
section of the code work:
/* Some unchanged date_and_time.c code above here */
#ifndef HAVE_NO_DATE_TIME
time_t lt;
struct tm local_time;
struct tm UTC_time;
lt = time (NULL);
if (lt != (time_t) -1)
{
#if HAVE_GETTIMEOFDAY
{
struct timeval tp;
#if GETTIMEOFDAY_ONE_ARGUMENT
if (!gettimeofday (&tp))
#else
#if HAVE_STRUCT_TIMEZONE
struct timezone tzp;
/* Some systems such as HP-UX, do have struct timezone, but
gettimeofday takes void* as the 2nd arg. However, the
effect of passing anything other than a null pointer is
unspecified on HP-UX. Configure checks if gettimeofday
actually fails with a non-NULL arg and pretends that
struct timezone is missing if it does fail. */
if (!gettimeofday (&tp, &tzp))
#else
if (!gettimeofday (&tp, (void *) 0))
#endif /* HAVE_STRUCT_TIMEZONE */
#endif /* GETTIMEOFDAY_ONE_ARGUMENT */
/* All arguments can be derived from tp. */
lt = tp.tv_sec;
values[7] = tp.tv_usec / 1000;
}
#else
{
/* All arguments can be derived from lt. */
values[7] = 0;
}
#endif /* HAVE_GETTIMEOFDAY */
local_time = *localtime (<);
UTC_time = *gmtime (<);
values[0] = 1900 + local_time.tm_year;
values[1] = 1 + local_time.tm_mon;
values[2] = local_time.tm_mday;
values[3] = (local_time.tm_min - UTC_time.tm_min +
60 * (local_time.tm_hour - UTC_time.tm_hour +
24 * (local_time.tm_yday - UTC_time.tm_yday)));
values[4] = local_time.tm_hour;
values[5] = local_time.tm_min;
values[6] = local_time.tm_sec;
#if HAVE_SNPRINTF
if (__date)
/* Some unchanged date_and_time.c code below here */
--
Summary: Intrinsic date_and_time can go back in time
Product: gcc
Version: 4.2.0
Status: UNCONFIRMED
Severity: critical
Priority: P3
Component: libfortran
AssignedTo: unassigned at gcc dot gnu dot org
ReportedBy: mathewc at nag dot co dot uk
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=30015
