re PR fortran/32985 (COMMON checking: TYPE with(out) SEQUENCE/bind(C), ALLOCATABLE)

2007-08-26  Tobias Burnus  <burnus@net-b.de>

	PR fortran/32985
	* match.c (gfc_match_common): Remove SEQUENCE diagnostics.
	* resolve.c (resolve_common_blocks): Add SEQUENCE diagnostics;
	fix walking through the tree.

2007-08-26  Tobias Burnus  <burnus@net-b.de>

	PR fortran/32985
	* gfortran.dg/namelist_14.f90: Make test case valid.
	* gfortran.dg/common_10.f90: New.

From-SVN: r127811

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 2597164..fe7ae49 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,12 @@
 2007-08-26  Tobias Burnus  <burnus@net-b.de>
 
+       PR fortran/32985
+       * match.c (gfc_match_common): Remove SEQUENCE diagnostics.
+       * resolve.c (resolve_common_blocks): Add SEQUENCE diagnostics;
+       fix walking through the tree.
+
+2007-08-26  Tobias Burnus  <burnus@net-b.de>
+
        PR fortran/32980
        * intrinsic.h (gfc_simplify_gamma,gfc_simplify_lgamma,
        gfc_resolve_gamma,gfc_resolve_lgamma): New function declations.

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 5773aa2..dcf6ad1 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2885,14 +2885,6 @@ gfc_match_common (void)
          if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
            goto cleanup;
 
-         /* Derived type names must have the SEQUENCE attribute.  */
-         if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
-           {
-             gfc_error ("Derived type variable in COMMON at %C does not "
-                        "have the SEQUENCE attribute");
-             goto cleanup;
-           }
-
          if (tail != NULL)
            tail->common_next = sym;
          else

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fbb7a03..4610c08 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -606,49 +606,58 @@ resolve_entries (gfc_namespace *ns)
 static void
 resolve_common_blocks (gfc_symtree *common_root)
 {
-   gfc_symtree *symtree;
-   gfc_symbol *sym;
+  gfc_symbol *sym, *csym;
 
-   if (common_root == NULL)
-     return;
+  if (common_root == NULL)
+    return;
 
-   for (symtree = common_root; symtree->left; symtree = symtree->left);
+  if (common_root->left)
+    resolve_common_blocks (common_root->left);
+  if (common_root->right)
+    resolve_common_blocks (common_root->right);
 
-   for (; symtree; symtree = symtree->right)
-     {
-       gfc_find_symbol (symtree->name, gfc_current_ns, 0, &sym);
-       if (sym == NULL)
-         continue;
+  for (csym = common_root->n.common->head; csym; csym = csym->common_next)
+    {
+      if (csym->ts.type == BT_DERIVED
+         && !(csym->ts.derived->attr.sequence
+              || csym->ts.derived->attr.is_bind_c))
+       {
+           gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+                          "has neither the SEQUENCE nor the BIND(C) "
+                          "attribute", csym->name,
+                          &csym->declared_at);
+       }
+      else if (csym->ts.type == BT_DERIVED
+              && csym->ts.derived->attr.alloc_comp)
+       {
+           gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+                          "has an ultimate component that is "
+                          "allocatable", csym->name,
+                          &csym->declared_at);
+       }
+    }
 
-       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);
-         }
+  gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
+  if (sym == NULL)
+    return;
 
-       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);
-         }
-     }
+  if (sym->attr.flavor == FL_PARAMETER)
+    gfc_error ("COMMON block '%s' at %L is used as PARAMETER at %L",
+              sym->name, &common_root->n.common->where, &sym->declared_at);
+
+  if (sym->attr.intrinsic)
+    gfc_error ("COMMON block '%s' at %L is also an intrinsic procedure",
+              sym->name, &common_root->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,
+                   &common_root->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,
+                   &common_root->n.common->where);
 }
 
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ae2f57b..5d2f257 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2007-08-26  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/32985
+       * gfortran.dg/namelist_14.f90: Make test case valid.
+       * gfortran.dg/common_10.f90: New.
+
 2007-08-26  H.J. Lu  <hongjiu.lu@intel.com>
 
        PR middle-end/33181

diff --git a/gcc/testsuite/gfortran.dg/common_10.f90 b/gcc/testsuite/gfortran.dg/common_10.f90
new file mode 100644 (file)
index 0000000..cec443a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_10.f90
@@ -0,0 +1,55 @@
+use iso_c_binding
+implicit none
+
+type, bind(C) :: mytype1
+  integer(c_int) :: x
+  real(c_float)    :: y
+end type mytype1
+
+type mytype2
+  sequence
+  integer :: x
+  real    :: y
+end type mytype2
+
+type mytype3
+  integer :: x
+  real    :: y
+end type mytype3
+
+type mytype4
+  sequence
+  integer, allocatable, dimension(:) :: x
+end type mytype4
+
+type mytype5
+  sequence
+  integer, pointer :: x
+  integer :: y
+end type mytype5
+
+type mytype6
+  sequence
+  type(mytype5) :: t
+end type mytype6
+
+type mytype7
+  sequence
+  type(mytype4) :: t
+end type mytype7
+
+common /a/ t1
+common /b/ t2
+common /c/ t3  ! { dg-error "has neither the SEQUENCE nor the BIND.C. attribute" }
+common /d/ t4  ! { dg-error "has an ultimate component that is allocatable" }
+common /e/ t5
+common /f/ t6
+common /f/ t7  ! { dg-error "has an ultimate component that is allocatable" }
+type(mytype1) :: t1
+type(mytype2) :: t2
+type(mytype3) :: t3
+type(mytype4) :: t4
+type(mytype5) :: t5
+type(mytype6) :: t6
+type(mytype7) :: t7
+end

diff --git a/gcc/testsuite/gfortran.dg/namelist_14.f90 b/gcc/testsuite/gfortran.dg/namelist_14.f90
index e95495a..729f1b2 100644 (file)
--- a/gcc/testsuite/gfortran.dg/namelist_14.f90
+++ b/gcc/testsuite/gfortran.dg/namelist_14.f90
@@ -6,6 +6,7 @@
 
 module global
   type             ::  mt
+    sequence
     integer        ::  ii(4)
   end type mt
 end module global