re PR fortran/25062 (same name for parameter and common block)

2007-07-03  Tobias Burnus  <burnus@net-b.de>

	PR fortran/25062
	* resolve.c (resolve_common_blocks): New check function.
	(resolve_types): Use it.

2007-07-03  Tobias Burnus  <burnus@net-b.de>

	PR fortran/25062
	* common_7.f90: New.
	* common_8.f90: New.
	* common_9.f90: New.

From-SVN: r126279

1 files changed, 52 insertions, 0 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b249f30..615d85e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -594,6 +594,56 @@ resolve_entries (gfc_namespace *ns)
 }
 
 
+/* Resolve common blocks.  */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+   gfc_symtree *symtree;
+   gfc_symbol *sym;
+
+   if (common_root == NULL)
+     return;
+
+   for (symtree = common_root; symtree->left; symtree = symtree->left);
+
+   for (; symtree; symtree = symtree->right)
+     {
+	gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
+	if (sym == NULL)
+	  continue;
+
+	if (sym->attr.flavor == FL_PARAMETER)
+	  {
+	    gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+		       sym->name, &symtree->n.common->where,
+		       &sym->declared_at);
+	  }
+
+	if (sym->attr.intrinsic)
+	  {
+	    gfc_error ("COMMON block '%s' at %L is also an intrinsic "
+		       "procedure", sym->name,
+		       &symtree->n.common->where);
+	  }
+	else if (sym->attr.result
+		 ||(sym->attr.function && gfc_current_ns->proc_name == sym))
+	  {
+	    gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
+			    "at %L that is also a function result", sym->name,
+			    &symtree->n.common->where);
+	  }
+	else if (sym->attr.flavor == FL_PROCEDURE
+		&& sym->attr.proc != PROC_INTERNAL
+		&& sym->attr.proc != PROC_ST_FUNCTION)
+	  {
+	    gfc_notify_std (GFC_STD_F2003, "Fortran 2003: COMMON block '%s' "
+			    "at %L that is also a global procedure", sym->name,
+			    &symtree->n.common->where);
+	  }
+     }
+}
+
+
 /* Resolve contained function types.  Because contained functions can call one
    another, they have to be worked out before any of the contained procedures
    can be resolved.
@@ -8197,6 +8247,8 @@ resolve_types (gfc_namespace *ns)
 
   resolve_entries (ns);
 
+  resolve_common_blocks (ns->common_root);
+
   resolve_contained_functions (ns);
 
   gfc_traverse_ns (ns, resolve_bind_c_derived_types);