OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/25054 (nonconstant bounds array cannot appear in a namelist)

Browse Source 
2005-02-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25054
	* resolve.c (is_non_constant_shape_array): New function.
	(resolve_fl_variable): Remove code for the new function and call it.
	(resolve_fl_namelist): New function.  Add test for namelist array
	with non-constant shape, using is_non_constant_shape_array.
	(resolve_symbol): Remove code for resolve_fl_namelist and call it.

	PR fortran/25089
	* match.c (match_namelist): Increment the refs field of an accepted
	namelist object symbol.
	* resolve.c (resolve_fl_namelist): Test namelist objects for a conflict
	with contained or module procedures.

2005-02-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/25054
	* gfortran.dg/namelist_5.f90: New test.

	PR fortran/25089
	* gfortran.dg/namelist_4.f90: New test.

From-SVN: r111268
This commit is contained in:
Paul Thomas 2006-02-19 15:24:26 +00:00
parent c05f6d04cb
commit 3e1cf50075
6 changed files with 169 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2005-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* resolve.c (is_non_constant_shape_array): New function.
(resolve_fl_variable): Remove code for the new function and call it.
(resolve_fl_namelist): New function. Add test for namelist array
with non-constant shape, using is_non_constant_shape_array.
(resolve_symbol): Remove code for resolve_fl_namelist and call it.
PR fortran/25089
* match.c (match_namelist): Increment the refs field of an accepted
namelist object symbol.
* resolve.c (resolve_fl_namelist): Test namelist objects for a conflict
with contained or module procedures.
2006-02-18 Roger Sayle <roger@eyesopen.com>
* trans-stmt.c (struct temporary_list): Delete.

1
gcc/fortran/match.c
View File

@ -2589,6 +2589,7 @@ gfc_match_namelist (void)
nl = gfc_get_namelist ();
nl->sym = sym;
sym->refs++;
if (group_name->namelist == NULL)
group_name->namelist = group_name->namelist_tail = nl;

142
gcc/fortran/resolve.c
View File

@ -4598,6 +4598,35 @@ resolve_charlen (gfc_charlen *cl)
}
/* Test for non-constant shape arrays. */
static bool
is_non_constant_shape_array (gfc_symbol *sym)
{
gfc_expr *e;
int i;
if (sym->as != NULL)
{
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
has not been simplified; parameter array references. Do the
simplification now. */
for (i = 0; i < sym->as->rank; i++)
{
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
return true;
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
return true;
}
}
return false;
}
/* Resolution of common features of flavors variable and procedure. */
static try
@ -4652,43 +4681,17 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
return FAILURE;
/* The shape of a main program or module array needs to be constant. */
if (sym->as != NULL
&& sym->ns->proc_name
if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)
&& !sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer)
&& !sym->attr.pointer
&& is_non_constant_shape_array (sym))
{
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
has not been simplified; parameter array references. Do the
simplification now. */
flag = 0;
for (i = 0; i < sym->as->rank; i++)
{
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
{
flag = 1;
break;
}
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
{
flag = 1;
break;
}
}
if (flag)
{
gfc_error ("The module or main program array '%s' at %L must "
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
return FAILURE;
}
}
if (sym->ts.type == BT_CHARACTER)
@ -4960,6 +4963,64 @@ resolve_fl_derived (gfc_symbol *sym)
}
static try
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
gfc_symbol *nlsym;
/* Reject PRIVATE objects in a PUBLIC namelist. */
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
{
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
&& !(sym->ns->parent == nl->sym->ns)
&& !gfc_check_access(nl->sym->attr.access,
nl->sym->ns->default_access))
{
gfc_error ("PRIVATE symbol '%s' cannot be member of "
"PUBLIC namelist at %L", nl->sym->name,
&sym->declared_at);
return FAILURE;
}
}
}
/* Reject namelist arrays that are not constant shape. */
for (nl = sym->namelist; nl; nl = nl->next)
{
if (is_non_constant_shape_array (nl->sym))
{
gfc_error ("The array '%s' must have constant shape to be "
"a NAMELIST object at %L", nl->sym->name,
&sym->declared_at);
return FAILURE;
}
}
/* 14.1.2 A module or internal procedure represent local entities
of the same type as a namelist member and so are not allowed.
Note that this is sometimes caught by check_conflict so the
same message has been used. */
for (nl = sym->namelist; nl; nl = nl->next)
{
nlsym = NULL;
if (sym->ns->parent && nl->sym && nl->sym->name)
gfc_find_symbol (nl->sym->name, sym->ns->parent, 0, &nlsym);
if (nlsym && nlsym->attr.flavor == FL_PROCEDURE)
{
gfc_error ("PROCEDURE attribute conflicts with NAMELIST "
"attribute in '%s' at %L", nlsym->name,
&sym->declared_at);
return FAILURE;
}
}
return SUCCESS;
}
static try
resolve_fl_parameter (gfc_symbol *sym)
{
@ -5007,7 +5068,6 @@ resolve_symbol (gfc_symbol * sym)
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
gfc_namelist *nl;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
@ -5162,23 +5222,8 @@ resolve_symbol (gfc_symbol * sym)
break;
case FL_NAMELIST:
/* Reject PRIVATE objects in a PUBLIC namelist. */
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
{
for (nl = sym->namelist; nl; nl = nl->next)
{
if (!nl->sym->attr.use_assoc
&&
!(sym->ns->parent == nl->sym->ns)
&&
!gfc_check_access(nl->sym->attr.access,
nl->sym->ns->default_access))
gfc_error ("PRIVATE symbol '%s' cannot be member of "
"PUBLIC namelist at %L", nl->sym->name,
&sym->declared_at);
}
}
if (resolve_fl_namelist (sym) == FAILURE)
return;
break;
case FL_PARAMETER:
@ -5192,7 +5237,6 @@ resolve_symbol (gfc_symbol * sym)
break;
}
/* Make sure that intrinsic exist */
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2005-02-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* gfortran.dg/namelist_5.f90: New test.
PR fortran/25089
* gfortran.dg/namelist_4.f90: New test.
2006-02-18 Andrew Pinski <pinskia@physics.uc.edu>
PR tree-opt/25680

39
gcc/testsuite/gfortran.dg/namelist_4.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do compile }
! This tests the fix for PR25089 in which it was noted that a
! NAMELIST member that is an internal(or module) procedure gave
! no error if the NAMELIST declaration appeared before the
! procedure declaration. Not mentioned in the PR is that any
! reference to the NAMELIST object would cause a segfault.
!
! Based on the contribution from Joost VanderVondele
!
module M1
CONTAINS
! This is the original PR
INTEGER FUNCTION G1()
NAMELIST /NML1/ G2 ! { dg-error "PROCEDURE attribute conflicts" }
G1=1
END FUNCTION
INTEGER FUNCTION G2()
G2=1
END FUNCTION
! This has always been picked up - namelist after function
INTEGER FUNCTION G3()
NAMELIST /NML2/ G1 ! { dg-error "PROCEDURE attribute conflicts" }
G3=1
END FUNCTION
END module M1
program P1
CONTAINS
! This has the additional wrinkle of a reference to the object.
INTEGER FUNCTION F1()
NAMELIST /NML3/ F2 ! { dg-error "PROCEDURE attribute conflicts" }
f2 = 1 ! Used to ICE here
F1=1
END FUNCTION
INTEGER FUNCTION F2()
F2=1
END FUNCTION
END

13
gcc/testsuite/gfortran.dg/namelist_5.f90 Normal file
View File

@ -0,0 +1,13 @@
! { dg-do compile }
! Tests the fix for PR25054 in which namelist objects with non-constant
! shape were allowed.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
SUBROUTINE S1(I)
integer :: a,b(I)
NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape to be a NAMELIST object" }
a=1 ; b=2
write(6,NML=NLIST)
END SUBROUTINE S1
END