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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@131355 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a3d2ee8..f7b85b0 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 39188cc..f59e8aa 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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.
+
 2008-01-06  Tobias Burnus  <burnus@net-b.de>
 
        * gfortran.dg/equiv_constraint_9.f90: Fix typo.

diff --git a/gcc/testsuite/gfortran.dg/blockdata_1.f90 b/gcc/testsuite/gfortran.dg/blockdata_1.f90
index 81cd02c..74910c4 100644 (file)
--- a/gcc/testsuite/gfortran.dg/blockdata_1.f90
+++ b/gcc/testsuite/gfortran.dg/blockdata_1.f90
@@ -14,7 +14,7 @@ end blockdata d1
 
 block data d2
  common /b/ u
- common j ! { dg-warning "cannot contain blank COMMON" }
+ common j ! { dg-warning "blank COMMON but initialization is only allowed in named common" }
  data j /1/
 end block data d2
 !

diff --git a/gcc/testsuite/gfortran.dg/blockdata_2.f90 b/gcc/testsuite/gfortran.dg/blockdata_2.f90
index a1370c8..b4badba 100644 (file)
--- a/gcc/testsuite/gfortran.dg/blockdata_2.f90
+++ b/gcc/testsuite/gfortran.dg/blockdata_2.f90
@@ -3,6 +3,6 @@
 ! proc_name from an unnamed block data which we intended to use as locus
 ! for a blank common.
 block data
-  common c ! { dg-warning "cannot contain blank COMMON" }
+  common c
 end !block data
 end

diff --git a/gcc/testsuite/gfortran.dg/common_11.f90 b/gcc/testsuite/gfortran.dg/common_11.f90
new file mode 100644 (file)
index 0000000..ec01515
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_11.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+!
+! PR fortran/34658
+!
+! Check for more COMMON constrains
+!
+block data
+  implicit none
+  integer :: x, a  ! { dg-warning "Initialized variable 'a' at .1. is in a blank COMMON" }
+  integer :: y = 5, b = 5 ! { dg-warning "Initialized variable 'b' at .1. is in a blank COMMON" }
+  data x/5/, a/5/
+  common // a, b
+  common /a/ x, y
+end block data
+
+subroutine foo()
+  implicit none
+  type t
+    sequence
+    integer :: i = 5
+  end type t
+  type(t) x ! { dg-error "may not have default initializer" }
+  common // x
+end subroutine foo
+
+program test
+  implicit none
+  common /a/ I ! { dg-warning "in COMMON but only in BLOCK DATA initialization" }
+  integer :: I = 43
+end program test