re PR fortran/34658 (save / common)

2007-01-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34658
        * match.c (gfc_match_common): Remove blank common in
        DATA BLOCK warning.
        * resolve.c (resolve_common_vars): New function.
        (resolve_common_blocks): Move checks to resolve_common_vars
        and invoke that function.
        (resolve_types): Call resolve_common_vars for blank commons.

2007-01-06  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34658
        * gfortran.dg/common_11.f90: New.
        * gfortran.dg/blockdata_1.f90: Update test case.
        * gfortran.dg/blockdata_2.f90: Update test case.

From-SVN: r131355

3 files changed, 45 insertions, 18 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a3d2ee8..f7b85b0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2007-01-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34658
+	* match.c (gfc_match_common): Remove blank common in
+	DATA BLOCK warning.
+	* resolve.c (resolve_common_vars): New function.
+	(resolve_common_blocks): Move checks to resolve_common_vars
+	and invoke that function.
+	(resolve_types): Call resolve_common_vars for blank commons.
+
 2008-01-06  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34655
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 78ed754..9a9ed8a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2784,11 +2784,6 @@ gfc_match_common (void)
 
       if (name[0] == '\0')
 	{
-	  if (gfc_current_ns->is_block_data)
-	    {
-	      gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
-			   "at %C");
-	    }
 	  t = &gfc_current_ns->blank_common;
 	  if (t->head == NULL)
 	    t->where = gfc_current_locus;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6cde79f..0f96cd6 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -646,23 +646,27 @@ has_default_initializer (gfc_symbol *der)
   return c != NULL;
 }
 
-
-/* Resolve common blocks.  */
+/* Resolve common variables.  */
 static void
-resolve_common_blocks (gfc_symtree *common_root)
+resolve_common_vars (gfc_symbol *sym, bool named_common)
 {
-  gfc_symbol *sym, *csym;
-
-  if (common_root == NULL)
-    return;
+  gfc_symbol *csym = sym;
 
-  if (common_root->left)
-    resolve_common_blocks (common_root->left);
-  if (common_root->right)
-    resolve_common_blocks (common_root->right);
-
-  for (csym = common_root->n.common->head; csym; csym = csym->common_next)
+  for (; csym; csym = csym->common_next)
     {
+      if (csym->value || csym->attr.data)
+	{
+	  if (!csym->ns->is_block_data)
+	    gfc_notify_std (GFC_STD_GNU, "Variable '%s' at %L is in COMMON "
+			    "but only in BLOCK DATA initialization is "
+			    "allowed", csym->name, &csym->declared_at);
+	  else if (!named_common)
+	    gfc_notify_std (GFC_STD_GNU, "Initialized variable '%s' at %L is "
+			    "in a blank COMMON but initialization is only "
+			    "allowed in named common blocks", csym->name,
+			    &csym->declared_at);
+	}
+
       if (csym->ts.type != BT_DERIVED)
 	continue;
 
@@ -680,6 +684,23 @@ resolve_common_blocks (gfc_symtree *common_root)
 		       "may not have default initializer", csym->name,
 		       &csym->declared_at);
     }
+}
+
+/* Resolve common blocks.  */
+static void
+resolve_common_blocks (gfc_symtree *common_root)
+{
+  gfc_symbol *sym;
+
+  if (common_root == NULL)
+    return;
+
+  if (common_root->left)
+    resolve_common_blocks (common_root->left);
+  if (common_root->right)
+    resolve_common_blocks (common_root->right);
+
+  resolve_common_vars (common_root->n.common->head, true);
 
   gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
   if (sym == NULL)
@@ -8939,6 +8960,7 @@ resolve_types (gfc_namespace *ns)
 
   resolve_entries (ns);
 
+  resolve_common_vars (ns->blank_common.head, false);
   resolve_common_blocks (ns->common_root);
 
   resolve_contained_functions (ns);