[Patch, Fortran] PR32985 - COMMON checking

[Tobias Burnus <burnus at net-b dot de>]

:ADDPATCH fortran:

This patch does two things:

a) It fixes a really stupid bug be me. A tree is a tree is a tree -- and
not a linked list; as I was treating the common_root symtree as list,
the diagnostic did not always work.

b) The checking in MATCH comes too early thus the check whether an
element in COMMON lacks the SEQUENCE type did not work if "TYPE(...)"
came after "COMMON". Additionally, there was no check for allocateable
components. BIND(C) is now treated as SEQUENCE with regards to COMMON.


For COMMON:

"C589 (R558) If a common-block-object is of a derived type, it shall be a
sequence type (4.5.1) or a type with the BIND attribute and it shall have no
default initialization."

"C588 (R558) A common-block-object shall not be a dummy argument, an
allocatable variable, a derived-type object with an ultimate component that is
allocatable, an automatic object, a function name, an entry name, a variable
with the BIND attribute, or a result name."


With regards to the standard, this patch fixes the BIND(C) (was
rejected) and "derived-type object with an ultimate component that is
allocatable" (was accepted).

What currently is missing is a check for "it shall have no default
initialization."


By the way,  BIND(C) in EQUIVALENCE is not allowed: "C576 An
equivalence-object shall not be a designator with a base object that is
[...] a variable with the BIND attribute". (gfortran did and still does
the right thing.)


Regression tested on x86-64-linux.

Ok for the trunk?

Tobias

2007-08-20  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-20  Tobias Burnus  <burnus@net-b.de>

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

Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(Revision 127647)
+++ gcc/fortran/match.c	(Arbeitskopie)
@@ -2709,14 +2709,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
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 127647)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -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);
 }
 
 
Index: gcc/testsuite/gfortran.dg/namelist_14.f90
===================================================================
--- gcc/testsuite/gfortran.dg/namelist_14.f90	(Revision 127647)
+++ gcc/testsuite/gfortran.dg/namelist_14.f90	(Arbeitskopie)
@@ -6,6 +6,7 @@
 
 module global
   type             ::  mt
+    sequence
     integer        ::  ii(4)
   end type mt
 end module global
Index: gcc/testsuite/gfortran.dg/common_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/common_10.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/common_10.f90	(Revision 0)
@@ -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