From: pault Date: Tue, 1 Nov 2005 05:53:29 +0000 (+0000) Subject: 2005-11-01 Paul Thomas X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=1038783304983d4f79b0df3e70088cc7edbb3371 2005-11-01 Paul Thomas PR fortran/21565 * symbol.c (check_conflict): An object cannot be in a namelist and in block data. PR fortran/18737 * resolve.c (resolve_symbol): Set the error flag to gfc_set_default_type, in the case of an external symbol, so that an error message is emitted if IMPLICIT NONE is set. PR fortran/14994 * gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SECNDS to enum. * check.c (gfc_check_secnds): New function. * intrinsic.c (add_functions): Add call to secnds. * iresolve.c (gfc_resolve_secnds): New function. * trans-intrinsic (gfc_conv_intrinsic_function): Add call to secnds via case GFC_ISYM_SECNDS. * intrinsic.texi: Add documentation for secnds. 2005-11-01 Paul Thomas PR fortran/14994 * libgfortran/intrinsics/date_and_time.c: Add interface to the functions date_and_time for the intrinsic function secnds. 2005-11-01 Paul Thomas PR fortran/21565 gfortran.dg/namelist_blockdata.f90: New test. PR fortran/18737 gfortran.dg/external_implicit_none.f90: New test. PR fortran/14994 * gfortran.dg/secnds.f: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106317 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d3757933f96..e28464b4d0b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,23 @@ +2005-11-01 Paul Thomas + + PR fortran/21565 + * symbol.c (check_conflict): An object cannot be in a namelist and in + block data. + + PR fortran/18737 + * resolve.c (resolve_symbol): Set the error flag to + gfc_set_default_type, in the case of an external symbol, so that + an error message is emitted if IMPLICIT NONE is set. + + PR fortran/14994 + * gfortran.h (gfc_generic_isym_id): Add GFC_ISYM_SECNDS to enum. + * check.c (gfc_check_secnds): New function. + * intrinsic.c (add_functions): Add call to secnds. + * iresolve.c (gfc_resolve_secnds): New function. + * trans-intrinsic (gfc_conv_intrinsic_function): Add call to + secnds via case GFC_ISYM_SECNDS. + * intrinsic.texi: Add documentation for secnds. + 2005-10-31 Andreas Schwab * Make-lang.in (GFORTRAN_TARGET_INSTALL_NAME): Define. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 6d2c65b5f96..fe96ea4dc91 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1832,6 +1832,23 @@ gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z) try +gfc_check_secnds (gfc_expr * r) +{ + + if (type_check (r, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (kind_value_check (r, 0, 4) == FAILURE) + return FAILURE; + + if (scalar_check (r, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try gfc_check_selected_int_kind (gfc_expr * r) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 083fc33f147..46c5bd2186f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -389,6 +389,7 @@ enum gfc_generic_isym_id GFC_ISYM_SCALE, GFC_ISYM_SCAN, GFC_ISYM_SECOND, + GFC_ISYM_SECNDS, GFC_ISYM_SET_EXPONENT, GFC_ISYM_SHAPE, GFC_ISYM_SI_KIND, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index e96ccbb406f..a577ed9f9d7 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1882,6 +1882,13 @@ add_functions (void) make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); + /* Added for G77 compatibility. */ + add_sym_1 ("secnds", 0, 1, BT_REAL, dr, GFC_STD_GNU, + gfc_check_secnds, NULL, gfc_resolve_secnds, + x, BT_REAL, dr, REQUIRED); + + make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU); + add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di, GFC_STD_F95, gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index eb2517136cc..51334b4336a 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -104,6 +104,7 @@ try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_scale (gfc_expr *, gfc_expr *); try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_second_sub (gfc_expr *); +try gfc_check_secnds (gfc_expr *); try gfc_check_selected_int_kind (gfc_expr *); try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); try gfc_check_set_exponent (gfc_expr *, gfc_expr *); @@ -363,6 +364,7 @@ void gfc_resolve_rrspacing (gfc_expr *, gfc_expr *); void gfc_resolve_scale (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_second_sub (gfc_code *); +void gfc_resolve_secnds (gfc_expr *, gfc_expr *); void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_shape (gfc_expr *, gfc_expr *); void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 025b3f1a2b0..dae94cc7ab8 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -94,6 +94,7 @@ and editing. All contributions and corrections are strongly encouraged. * @code{LOG10}: LOG10, Base 10 logarithm function * @code{MALLOC}: MALLOC, Dynamic memory allocation function * @code{REAL}: REAL, Convert to real type +* @code{SECNDS}: SECNDS, Time function * @code{SIGNAL}: SIGNAL, Signal handling subroutine (or function) * @code{SIN}: SIN, Sine function * @code{SINH}: SINH, Hyperbolic sine function @@ -3135,6 +3136,54 @@ end program test_signal + +@node SECNDS +@section @code{SECNDS} --- Time subroutine +@findex @code{SECNDS} intrinsic +@cindex SECNDS + +@table @asis +@item @emph{Description}: +@code{SECNDS(X)} gets the time in seconds from the real-time system clock. +@var{X} is a reference time, also in seconds. If this is zero, the time in +seconds from midnight is returned. This function is non-standard and its +use is discouraged. + +@item @emph{Option}: +gnu + +@item @emph{Class}: +function + +@item @emph{Syntax}: +@code{T = SECNDS (X)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .80 +@item Name @tab Type +@item @var{T} @tab REAL(4) +@item @var{X} @tab REAL(4) +@end multitable + +@item @emph{Return value}: +None + +@item @emph{Example}: +@smallexample +program test_secnds + real(4) :: t1, t2 + print *, secnds (0.0) ! seconds since midnight + t1 = secnds (0.0) ! reference time + do i = 1, 10000000 ! do something + end do + t2 = secnds (t1) ! elapsed time + print *, "Something took ", t2, " seconds." +end program test_secnds +@end smallexample +@end table + + + @node SIN @section @code{SIN} --- Sine function @findex @code{SIN} intrinsic diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 5650c0fb9b7..47a494dd0fb 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1367,6 +1367,15 @@ gfc_resolve_scan (gfc_expr * f, gfc_expr * string, void +gfc_resolve_secnds (gfc_expr * t1, gfc_expr * t0) +{ + t1->ts = t0->ts; + t1->value.function.name = + gfc_get_string (PREFIX("secnds")); +} + + +void gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i) { f->ts = x->ts; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f6fb2b0f838..5d5ca780ba7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4238,8 +4238,10 @@ resolve_symbol (gfc_symbol * sym) if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) { + /* The specific case of an external procedure should emit an error + in the case that there is no implicit type. */ if (!mp_flag) - gfc_set_default_type (sym, 0, NULL); + gfc_set_default_type (sym, sym->attr.external, NULL); else { /* Result may be in another namespace. */ diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 85ed70eb352..43209e4ccae 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -283,6 +283,8 @@ check_conflict (symbol_attribute * attr, const char * name, locus * where) { a1 = NULL; + if (attr->in_namelist) + a1 = in_namelist; if (attr->allocatable) a1 = allocatable; if (attr->external) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 93e8043360a..b81b543a271 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -3101,6 +3101,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_RAND: case GFC_ISYM_RENAME: case GFC_ISYM_SECOND: + case GFC_ISYM_SECNDS: case GFC_ISYM_SIGNAL: case GFC_ISYM_STAT: case GFC_ISYM_SYMLNK: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 78bee8652c9..388c59f8173 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2005-11-01 Paul Thomas + + PR fortran/21565 + gfortran.dg/namelist_blockdata.f90: New test. + + PR fortran/18737 + gfortran.dg/external_implicit_none.f90: New test. + + PR fortran/14994 + * gfortran.dg/secnds.f: New test. + 2005-10-31 Jan Hubicka PR target/20928 diff --git a/gcc/testsuite/gfortran.dg/external_implicit_none.f90 b/gcc/testsuite/gfortran.dg/external_implicit_none.f90 new file mode 100644 index 00000000000..43cfb284804 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/external_implicit_none.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests fix for PR18737 - ICE on external symbol of unknown type. +program test + implicit none + real(8) :: x + external bug ! { dg-error "has no IMPLICIT type" } + + x = 2 + print *, bug(x) + +end program test \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/namelist_blockdata.f b/gcc/testsuite/gfortran.dg/namelist_blockdata.f new file mode 100644 index 00000000000..c1a7a5b4e9b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_blockdata.f @@ -0,0 +1,7 @@ +! { dg-do compile } +! Tests fix for PR21565 - object cannot be in namelist and block data. + block data + common /foo/ a + namelist /foo_n/ a ! { dg-error "not allowed in BLOCK DATA" } + data a /1.0/ + end diff --git a/gcc/testsuite/gfortran.dg/secnds.f b/gcc/testsuite/gfortran.dg/secnds.f new file mode 100644 index 00000000000..d9a0f0dc357 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/secnds.f @@ -0,0 +1,29 @@ +C { dg-do run } +C { dg-options "-O0" } +C Tests fix for PR14994 - SECNDS intrinsic not supported. +C Note1: The test uses +/-20ms accuracy in the check that +C date_and_time and secnds give the same values. +C +C Contributed by Paul Thomas +C + character*20 dum1, dum2, dum3 + real*4 t1, t2 + real*4 dat1, dat2 + real*4 dt + integer*4 i, j, values(8) + dt = 40e-3 + t1 = secnds (0.0) + call date_and_time (dum1, dum2, dum3, values) + dat1 = 0.001*real (values(8)) + real (values(7)) + + & 60.0*real (values(6)) + 3600.0* real (values(5)) + if (int ((dat1 - t1 + dt * 0.5) / dt) .ne. 0) call abort () + do j=1,10000 + do i=1,10000 + end do + end do + call date_and_time (dum1, dum2, dum3, values) + dat2 = 0.001*real (values(8)) + real (values(7)) + + & 60.0*real (values(6)) + 3600.0* real (values(5)) + t2 = secnds (t1) + if (int ((dat1-dat2 + t2 + dt * 0.5) / dt) .ne. 0.0) call abort () + end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 86deed1a341..fe10fb9cb65 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2005-11-01 Paul Thomas + + PR fortran/14994 + * libgfortran/intrinsics/date_and_time.c: Add interface to + the functions date_and_time for the intrinsic function secnds. + 2005-10-31 Jerry DeLisle PR libgfortran/24584 diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c index be2959b3347..c52ccfec4a6 100644 --- a/libgfortran/intrinsics/date_and_time.c +++ b/libgfortran/intrinsics/date_and_time.c @@ -305,3 +305,57 @@ date_and_time (char *__date, char *__time, char *__zone, fstrcpy (__date, DATE_LEN, date, DATE_LEN); } } + + +/* SECNDS (X) - Non-standard + + Description: Returns the system time of day, or elapsed time, as a GFC_REAL_4 + in seconds. + + Class: Non-elemental subroutine. + + Arguments: + + X must be REAL(4) and the result is of the same type. The accuracy is system + dependent. + + Usage: + + T = SECNDS (X) + + yields the time in elapsed seconds since X. If X is 0.0, T is the time in + seconds since midnight. Note that a time that spans midnight but is less than + 24hours will be calculated correctly. */ + +extern GFC_REAL_4 secnds (GFC_REAL_4 *); +export_proto(secnds); + +GFC_REAL_4 +secnds (GFC_REAL_4 *x) +{ + GFC_INTEGER_4 values[VALUES_SIZE]; + GFC_REAL_4 temp1, temp2; + + /* Make the INTEGER*4 array for passing to date_and_time. */ + gfc_array_i4 *avalues = internal_malloc_size (sizeof (gfc_array_i4)); + avalues->data = &values[0]; + GFC_DESCRIPTOR_DTYPE (avalues) = ((GFC_DTYPE_REAL << GFC_DTYPE_TYPE_SHIFT) + & GFC_DTYPE_TYPE_MASK) + + (4 << GFC_DTYPE_SIZE_SHIFT); + + avalues->dim[0].ubound = 7; + avalues->dim[0].lbound = 0; + avalues->dim[0].stride = 1; + + date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0); + + free_mem (avalues); + + temp1 = 3600.0 * (GFC_REAL_4)values[4] + + 60.0 * (GFC_REAL_4)values[5] + + (GFC_REAL_4)values[6] + + 0.001 * (GFC_REAL_4)values[7]; + temp2 = fmod (*x, 86400.0); + temp2 = (temp1 - temp2 > 0.0) ? temp2 : (temp2 - 86400.0); + return temp1 - temp2; +}