OSDN Git Service

2005-11-01 Paul Thomas <pault@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 1 Nov 2005 05:53:29 +0000 (05:53 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 1 Nov 2005 05:53:29 +0000 (05:53 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@106317 138bc75d-0d04-0410-961f-82ee72b054a4

16 files changed:
gcc/fortran/ChangeLog
gcc/fortran/check.c
gcc/fortran/gfortran.h
gcc/fortran/intrinsic.c
gcc/fortran/intrinsic.h
gcc/fortran/intrinsic.texi
gcc/fortran/iresolve.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/fortran/trans-intrinsic.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/external_implicit_none.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/namelist_blockdata.f [new file with mode: 0644]
gcc/testsuite/gfortran.dg/secnds.f [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/intrinsics/date_and_time.c

index d375793..e28464b 100644 (file)
@@ -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.
index 6d2c65b..fe96ea4 100644 (file)
@@ -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)
 {
 
index 083fc33..46c5bd2 100644 (file)
@@ -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,
index e96ccbb..a577ed9 100644 (file)
@@ -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);
index eb25171..51334b4 100644 (file)
@@ -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 *);
index 025b3f1..dae94cc 100644 (file)
@@ -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
index 5650c0f..47a494d 100644 (file)
@@ -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;
index f6fb2b0..5d5ca78 100644 (file)
@@ -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.  */
index 85ed70e..43209e4 100644 (file)
@@ -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)
index 93e8043..b81b543 100644 (file)
@@ -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:
index 78bee86..388c59f 100644 (file)
@@ -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 (file)
index 0000000..43cfb28
--- /dev/null
@@ -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 (file)
index 0000000..c1a7a5b
--- /dev/null
@@ -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 (file)
index 0000000..d9a0f0d
--- /dev/null
@@ -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
index 86deed1..fe10fb9 100644 (file)
@@ -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
index be2959b..c52ccfe 100644 (file)
@@ -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;
+}