re PR fortran/25054 (nonconstant bounds array cannot appear in a namelist)
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
parent
c05f6d04cb
commit
3e1cf50075
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue