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
+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.
}
+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)
{
GFC_ISYM_SCALE,
GFC_ISYM_SCAN,
GFC_ISYM_SECOND,
+ GFC_ISYM_SECNDS,
GFC_ISYM_SET_EXPONENT,
GFC_ISYM_SHAPE,
GFC_ISYM_SI_KIND,
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);
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 *);
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 *);
* @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
+
+@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
}
+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)
{
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. */
{
a1 = NULL;
+ if (attr->in_namelist)
+ a1 = in_namelist;
if (attr->allocatable)
a1 = allocatable;
if (attr->external)
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:
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+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
+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
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;
+}
projects / gcc.git / commitdiff