re PR fortran/33198 (Derived type in common: Default initializer not rejected)

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.

From-SVN: r128980

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 255a6270b7e676a1994d418afafaaa7b6d4c6b12..98f1f24d07b629a8f07ab8df410053a47fb5f6d2 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2007-09-28  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+       PR fortran/33198
+       * 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): ... here, while adapting to new h_d_i
+       interface.
+
 2007-10-03  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        PR fortran/26682

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2f578e736d50a7f688592b15174c3a62fc1afdec..82b50a35a76eb2c2d2cffaa059b78c83a9ec8b34 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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 *common_root)
 
   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_namespace *ns)
 }
 
 
-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, int mp_flag)
 }
 
 
+/* 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, int mp_flag)
   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, int mp_flag)
          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, int mp_flag)
     }
 
 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 --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 216454d5f0c8be57caddc58db8c65c597b9a61e2..be26f5c2525d1cf1631e8bc29c2c98734ad56aaf 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-09-28  Tobias Schlüter  <tobi@gcc.gnu.org>
+
+       PR fortran/33198
+       * gfortran.dg/common_errors_1.f90: New.
+
 2007-10-03  Doug Kwan  <dougkwan@google.com>
        Richard Guenther  <rguenther@suse.de>
 

diff --git a/gcc/testsuite/gfortran.dg/common_errors_1.f90 b/gcc/testsuite/gfortran.dg/common_errors_1.f90
new file mode 100644 (file)
index 0000000..0d4e1be
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/common_errors_1.f90
@@ -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