[gfortran, PR 33198] Disallow default initialization of derived types in COMMONs

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Hi,

this patch fixes PR33198, where we would erroneously allow variables in 
common blocks where there was a default initialization for the 
variable's derived type.  The patch consists in adding a straightforward 
check to resolve_common_blocks.  This required moving 
has_default_initializer to the top.  While I was moving this function I 
realized that the returned pointer was never actually used, so I changed 
the interface to return bool.  This in turn lead me to clarifying 
resolve_fl_variable, where the returned pointer was recorded, but never 
used.

Built and testen on i386-darwin.  Ok?

Cheers,
- Tobi

:ADDPATCH fortran:
2007-09-28  Tobias Schlüter  <tobi@gcc.gnu.org>

	PR fortran/33198
fortran/
	* resolve.c (has_default_initializer): Move to top.  Make bool.
	(resolve_common_blocks): Simplify logic.  Add case for derived
	type initialization.
	(resolve_fl_variable_derived): Split out from ...
	(resolve_fl_variable): ... from here, while adapting to new h_d_i
	interface.
testsuite/
	* gfortran.dg/common_errors_1.f90: New.

diff -r 2ffe2d9f2050 .hgtags
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgtags	Fri Sep 28 23:08:23 2007 +0200
@@ -0,0 +1,1 @@
+f8ce69e5dcb9bd67ade65c2f4e7076caae157bb4 Failed patch.
diff -r 2ffe2d9f2050 gcc/fortran/resolve.c
--- a/gcc/fortran/resolve.c	Fri Sep 28 15:10:13 2007 +0000
+++ b/gcc/fortran/resolve.c	Fri Sep 28 23:08:23 2007 +0200
@@ -602,6 +602,22 @@ resolve_entries (gfc_namespace *ns)
 }
 
 
+static bool
+has_default_initializer (gfc_symbol *der)
+{
+  gfc_component *c;
+
+  gcc_assert (der->attr.flavor == FL_DERIVED);
+  for (c = der->components; c; c = c->next)
+    if ((c->ts.type != BT_DERIVED && c->initializer)
+	|| (c->ts.type == BT_DERIVED
+	    && (!c->pointer && has_default_initializer (c->ts.derived))))
+      break;
+
+  return c != NULL;
+}
+
+
 /* Resolve common blocks.  */
 static void
 resolve_common_blocks (gfc_symtree *common_root)
@@ -618,23 +634,22 @@ resolve_common_blocks (gfc_symtree *comm
 
   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 (csym->ts.type != BT_DERIVED)
+	continue;
+
+      if (!(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);
+      if (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 (has_default_initializer (csym->ts.derived))
+	gfc_error_now ("Derived type variable '%s' in COMMON at %L "
+		       "may not have default initializer", csym->name,
+		       &csym->declared_at);
     }
 
   gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym);
@@ -5913,21 +5928,6 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
 }
 
 
-static gfc_component *
-has_default_initializer (gfc_symbol *der)
-{
-  gfc_component *c;
-  for (c = der->components; c; c = c->next)
-    if ((c->ts.type != BT_DERIVED && c->initializer)
-        || (c->ts.type == BT_DERIVED
-              && !c->pointer
-              && has_default_initializer (c->ts.derived)))
-      break;
-
-  return c;
-}
-
-
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -6883,6 +6883,66 @@ resolve_fl_var_and_proc (gfc_symbol *sym
 }
 
 
+/* Additional checks for symbols with flavor variable and derived
+   type.  To be called from resolve_fl_variable.  */
+
+static try
+resolve_fl_variable_derived (gfc_symbol *sym, int flag)
+{
+  gcc_assert (sym->ts.type == BT_DERIVED);
+
+  /* Check to see if a derived type is blocked from being host
+     associated by the presence of another class I symbol in the same
+     namespace.  14.6.1.3 of the standard and the discussion on
+     comp.lang.fortran.  */
+  if (sym->ns != sym->ts.derived->ns
+      && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
+    {
+      gfc_symbol *s;
+      gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
+      if (s && (s->attr.flavor != FL_DERIVED
+		|| !gfc_compare_derived_types (s, sym->ts.derived)))
+	{
+	  gfc_error ("The type '%s' cannot be host associated at %L "
+		     "because it is blocked by an incompatible object "
+		     "of the same name declared at %L",
+		     sym->ts.derived->name, &sym->declared_at,
+		     &s->declared_at);
+	  return FAILURE;
+	}
+    }
+
+  /* 4th constraint in section 11.3: "If an object of a type for which
+     component-initialization is specified (R429) appears in the
+     specification-part of a module and does not have the ALLOCATABLE
+     or POINTER attribute, the object shall have the SAVE attribute."
+
+     The check for initializers is performed with
+     has_default_initializer because gfc_default_initializer generates
+     a hidden default for allocatable components.  */
+  if (!(sym->value || flag) && sym->ns->proc_name
+      && sym->ns->proc_name->attr.flavor == FL_MODULE
+      && !sym->ns->save_all && !sym->attr.save
+      && !sym->attr.pointer && !sym->attr.allocatable
+      && has_default_initializer (sym->ts.derived))
+    {
+      gfc_error("Object '%s' at %L must have the SAVE attribute for "
+		"default initialization of a component",
+		sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
+  /* Assign default initializer.  */
+  if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
+      && (!flag || sym->attr.intent == INTENT_OUT))
+    {
+      sym->value = gfc_default_initializer (&sym->ts);
+    }
+
+  return SUCCESS;
+}
+
+
 /* Resolve symbols with flavor variable.  */
 
 static try
@@ -6891,7 +6951,6 @@ resolve_fl_variable (gfc_symbol *sym, in
   int flag;
   int i;
   gfc_expr *e;
-  gfc_component *c;
   const char *auto_save_msg;
 
   auto_save_msg = "automatic object '%s' at %L cannot have the "
@@ -6985,7 +7044,7 @@ resolve_fl_variable (gfc_symbol *sym, in
 	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
-  }
+    }
 
   /* Reject illegal initializers.  */
   if (!sym->mark && sym->value && flag)
@@ -7015,54 +7074,8 @@ resolve_fl_variable (gfc_symbol *sym, in
     }
 
 no_init_error:
-  /* Check to see if a derived type is blocked from being host associated
-     by the presence of another class I symbol in the same namespace.
-     14.6.1.3 of the standard and the discussion on comp.lang.fortran.  */
-  if (sym->ts.type == BT_DERIVED && sym->ns != sym->ts.derived->ns
-	&& sym->ns->proc_name->attr.if_source != IFSRC_IFBODY)
-    {
-      gfc_symbol *s;
-      gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
-      if (s && (s->attr.flavor != FL_DERIVED
-		|| !gfc_compare_derived_types (s, sym->ts.derived)))
-	{
-	  gfc_error ("The type %s cannot be host associated at %L because "
-		     "it is blocked by an incompatible object of the same "
-		     "name at %L", sym->ts.derived->name, &sym->declared_at,
-		     &s->declared_at);
-	  return FAILURE;
-	}
-    }
-
-  /* Do not use gfc_default_initializer to test for a default initializer
-     in the fortran because it generates a hidden default for allocatable
-     components.  */
-  c = NULL;
-  if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
-    c = has_default_initializer (sym->ts.derived);
-
-  /* 4th constraint in section 11.3:  "If an object of a type for which
-     component-initialization is specified (R429) appears in the
-     specification-part of a module and does not have the ALLOCATABLE
-     or POINTER attribute, the object shall have the SAVE attribute."  */
-  if (c && sym->ns->proc_name
-      && sym->ns->proc_name->attr.flavor == FL_MODULE
-      && !sym->ns->save_all && !sym->attr.save
-      && !sym->attr.pointer && !sym->attr.allocatable)
-    {
-      gfc_error("Object '%s' at %L must have the SAVE attribute %s",
- 	 	sym->name, &sym->declared_at,
-		"for default initialization of a component");
-      return FAILURE;
-    }
-
-  /* Assign default initializer.  */
-  if (sym->ts.type == BT_DERIVED
-      && !sym->value
-      && !sym->attr.pointer
-      && !sym->attr.allocatable
-      && (!flag || sym->attr.intent == INTENT_OUT))
-    sym->value = gfc_default_initializer (&sym->ts);
+  if (sym->ts.type == BT_DERIVED)
+    return resolve_fl_variable_derived (sym, flag);
 
   return SUCCESS;
 }
diff -r 2ffe2d9f2050 gcc/testsuite/gfortran.dg/common_errors_1.f90
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/gfortran.dg/common_errors_1.f90	Fri Sep 28 23:08:23 2007 +0200
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! Tests a number of error messages relating to derived type objects
+! in common blocks.  Originally due to PR 33198
+
+subroutine one
+type a
+   sequence
+   integer :: i = 1
+end type a
+type(a) :: t ! { dg-error "Derived type variable .t. in COMMON at ... may not have default initializer" }
+common /c/ t
+end
+
+subroutine first
+type a
+   integer :: i
+   integer :: j
+end type a
+type(a) :: t  ! { dg-error "Derived type variable .t. in COMMON at ... has neither the SEQUENCE nor the BIND.C. attribute" }
+common /c/ t
+end
+
+subroutine prime
+type a
+   sequence
+   integer, allocatable :: i(:)
+   integer :: j
+end type a
+type(a) :: t  ! { dg-error "Derived type variable .t. in COMMON at ... has an ultimate component that is allocatable" }
+common /c/ t
+end
+
+subroutine source
+parameter(x=0.) ! { dg-error "COMMON block .x. at ... is used as PARAMETER at ..." }
+common /x/ i  ! { dg-error "COMMON block .x. at ... is used as PARAMETER at ..." }
+intrinsic sin
+common /sin/ j ! { dg-error "COMMON block .sin. at ... is also an intrinsic procedure" }
+end subroutine source