procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/21565 (namelist in block data is illegal)

Browse source 
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
This commit is contained in:
Paul Thomas 2005-11-01 05:53:29 +00:00
parent 4b2a5715ee
commit 53096259e6
16 changed files with 229 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
gcc/fortran/ChangeLog
View 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.

17
gcc/fortran/check.c
View file

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

1
gcc/fortran/gfortran.h
View 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,

7
gcc/fortran/intrinsic.c
View 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);

2
gcc/fortran/intrinsic.h
View 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 *);

49
gcc/fortran/intrinsic.texi
View 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

9
gcc/fortran/iresolve.c
View file

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

4
gcc/fortran/resolve.c
View 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. */

2
gcc/fortran/symbol.c
View 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)

1
gcc/fortran/trans-intrinsic.c
View 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:

11
gcc/testsuite/ChangeLog
View 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

11
gcc/testsuite/gfortran.dg/external_implicit_none.f90 Normal file
View file

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

7
gcc/testsuite/gfortran.dg/namelist_blockdata.f Normal file
View file

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

29
gcc/testsuite/gfortran.dg/secnds.f Normal file
View file

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

6
libgfortran/ChangeLog
View 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

54
libgfortran/intrinsics/date_and_time.c
View 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;
}