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

@@ -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.

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)
 {

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,

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);

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 *);

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

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)
 {

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.  */

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)

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:

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

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

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

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

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

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;
+}