diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 83a9059b8a34bfee77f32c0af6e239cecd34441f..5486c8eb78acd58a2d38645dff02b7f80cdb9423 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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.
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a2b9c41d5494934415c63899e8799e930d1d121f..4c2fe1b71ce430b7915ea956eeefdcf2ab6f6935 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -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;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1de2446aa1f71add872b401bb78f434f6209ef25..63b2cd9904d0027cce1239079d13a128eedc26bf 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f705bddb63996b4e43f9f5fe1dc973309e5e61e7..6cca5da64c6dca4a63451fac692cf33291762d52 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/namelist_4.f90 b/gcc/testsuite/gfortran.dg/namelist_4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0e1b0eef51faf48f2064bf35058e5a17ef008d86
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/namelist_4.f90
@@ -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
+
diff --git a/gcc/testsuite/gfortran.dg/namelist_5.f90 b/gcc/testsuite/gfortran.dg/namelist_5.f90
new file mode 100644
index 0000000000000000000000000000000000000000..401302dd5dd133105058b13f760fcb28a19a8fd2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/namelist_5.f90
@@ -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
\ No newline at end of file