From 53096259e6fb2000ca4bfd279e3f6b190d531090 Mon Sep 17 00:00:00 2001
From: Paul Thomas <pault@gcc.gnu.org>
Date: Tue, 1 Nov 2005 05:53:29 +0000
Subject: [PATCH] re PR fortran/21565 (namelist in block data is illegal)
2005-11-01 Paul Thomas <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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 <pault@gcc.gnu.org>
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.
From-SVN: r106317
---
gcc/fortran/ChangeLog | 20 +++++++
gcc/fortran/check.c | 17 ++++++
gcc/fortran/gfortran.h | 1 +
gcc/fortran/intrinsic.c | 7 +++
gcc/fortran/intrinsic.h | 2 +
gcc/fortran/intrinsic.texi | 49 +++++++++++++++++
gcc/fortran/iresolve.c | 9 ++++
gcc/fortran/resolve.c | 4 +-
gcc/fortran/symbol.c | 2 +
gcc/fortran/trans-intrinsic.c | 1 +
gcc/testsuite/ChangeLog | 11 ++++
.../gfortran.dg/external_implicit_none.f90 | 11 ++++
.../gfortran.dg/namelist_blockdata.f | 7 +++
gcc/testsuite/gfortran.dg/secnds.f | 29 ++++++++++
libgfortran/ChangeLog | 6 +++
libgfortran/intrinsics/date_and_time.c | 54 +++++++++++++++++++
16 files changed, 229 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/external_implicit_none.f90
create mode 100644 gcc/testsuite/gfortran.dg/namelist_blockdata.f
create mode 100644 gcc/testsuite/gfortran.dg/secnds.f
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d3757933f96e..e28464b4d0b3 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,23 @@
+2005-11-01 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <schwab@suse.de>
* Make-lang.in (GFORTRAN_TARGET_INSTALL_NAME): Define.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 6d2c65b5f963..fe96ea4dc917 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1831,6 +1831,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 083fc33f1471..46c5bd2186fc 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 e96ccbb406fc..a577ed9f9d79 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 eb2517136cc4..51334b4336ab 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 025b3f1a2b01..dae94cc7ab85 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 5650c0fb9b77..47a494dd0fb9 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1366,6 +1366,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)
{
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f6fb2b0f8386..5d5ca780ba75 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 85ed70eb352d..43209e4ccaea 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 93e8043360a6..b81b543a2710 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 78bee8652c95..388c59f8173c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2005-11-01 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <jh@suse.cz>
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 000000000000..43cfb2848046
--- /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 000000000000..c1a7a5b4e9bf
--- /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 000000000000..d9a0f0dc3574
--- /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 <pault@gcc.gnu.org>
+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 86deed1a341f..fe10fb9cb65e 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,9 @@
+2005-11-01 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <jvdelisle@verizon.net>
PR libgfortran/24584
diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c
index be2959b33479..c52ccfec4a65 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;
+}
--
GitLab