This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, fortran] PR25054 - namelist objects with non-constant shape.
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: patch <gcc-patches at gcc dot gnu dot org>, "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>
- Date: Wed, 15 Feb 2006 18:50:19 +0100
- Subject: [Patch, fortran] PR25054 - namelist objects with non-constant shape.
:ADDPATCH fortran:
This is a "quickie" to cure PR25054 in which namelist objects with
non-constant
shape were allowed. This was accomplished by separating existing code to
detect non-constant shape arrays into a new function, which is called by
existing conditions as well as a loop through namelist objects. I took the
opportunity to continue the spring-cleaning of resolve_symbol by lifting the
chunk of code dealing with FL_NAMELIST into its own function.
Regtested on FC3/Athlon: OK for trunk?
Paul
2006-02-15 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.
2006-02-15 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25054
* gfortran.dg/namelist_5.f90: New test.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 110986)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_charlen (gfc_charlen *cl)
*** 4598,4603 ****
--- 4598,4632 ----
}
+ /* 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
*************** resolve_fl_variable (gfc_symbol *sym, in
*** 4652,4694 ****
return FAILURE;
/* The shape of a main program or module array needs to be constant. */
! if (sym->as != NULL
! && 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)
{
! /* 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 "
"have constant shape", sym->name, &sym->declared_at);
return FAILURE;
- }
}
if (sym->ts.type == BT_CHARACTER)
--- 4681,4697 ----
return FAILURE;
/* The shape of a main program or module array needs to be constant. */
! 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
! && is_non_constant_shape_array (sym))
{
! 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)
*************** resolve_fl_derived (gfc_symbol *sym)
*** 4961,4966 ****
--- 4964,5009 ----
static try
+ resolve_fl_namelist (gfc_symbol *sym)
+ {
+ gfc_namelist *nl;
+
+ /* 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;
+ }
+ }
+ return SUCCESS;
+ }
+
+
+ static try
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
*************** resolve_symbol (gfc_symbol * sym)
*** 5007,5013 ****
/* 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;
--- 5050,5055 ----
*************** resolve_symbol (gfc_symbol * sym)
*** 5162,5184 ****
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);
! }
! }
!
break;
case FL_PARAMETER:
--- 5204,5211 ----
break;
case FL_NAMELIST:
! if (resolve_fl_namelist (sym) == FAILURE)
! return;
break;
case FL_PARAMETER:
*************** resolve_symbol (gfc_symbol * sym)
*** 5192,5198 ****
break;
}
-
/* Make sure that intrinsic exist */
if (sym->attr.intrinsic
&& ! gfc_intrinsic_name(sym->name, 0)
--- 5219,5224 ----
! { 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
a=1 ; b=2
write(6,NML=NLIST) ! { dg-error "must have constant shape to be a NAMELIST object" }
END SUBROUTINE S1
END