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

gcc/fortran/ChangeLog

 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.

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

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);
 }
 
 

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/common_10.f90

+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

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