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

6 files changed, 169 insertions, 49 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 83a9059..5486c8e 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 a2b9c41..4c2fe1b 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 1de2446..63b2cd9 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)
@@ -4961,6 +4964,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)
 {
   /* A parameter array's shape needs to be constant.  */
@@ -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 f705bdd..6cca5da 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 0000000..0e1b0ee
--- /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 0000000..401302d
--- /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