re PR fortran/16336 (ICE with common block in module)

PR fortran/16336
* decl.c (gfc_match_save): Use-associated common block
doesn't collide.
* gfortran.h (gfc_common_head): Add new field 'name'.
Fix typo in comment after #endif.
* match.c (gfc_get_common): Add new argument from_common,
mangle name if flag is set, fill in new field in structure
gfc_common_head.
(match_common): Set new arg in call to gfc_get_common,
use-associated common block doesn't collide.
* match.h (gfc_get_common): Adapt prototype.
* module.c (load_commons): Set new arg in call to
gfc_get_common.
* symbol.c (free_common_tree): New function.
(gfc_free_namespace): Call new function.
* trans-common.c (several functions): Remove argument
'name', use name from gfc_common_head instead.

From-SVN: r84476

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4335a586789ccd87e3603915bca081842a54b430..1b39762b9676b9cf7a4dd5193b3017d669b6dae9 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,23 @@
+2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+       
+       PR fortran/16336
+       * decl.c (gfc_match_save): Use-associated common block
+       doesn't collide.
+       * gfortran.h (gfc_common_head): Add new field 'name'.
+       Fix typo in comment after #endif.
+       * match.c (gfc_get_common): Add new argument from_common,
+       mangle name if flag is set, fill in new field in structure
+       gfc_common_head.
+       (match_common): Set new arg in call to gfc_get_common,
+       use-associated common block doesn't collide.
+       * match.h (gfc_get_common): Adapt prototype.
+       * module.c (load_commons): Set new arg in call to
+       gfc_get_common.
+       * symbol.c (free_common_tree): New function.
+       (gfc_free_namespace): Call new function.
+       * trans-common.c (several functions): Remove argument
+       'name', use name from gfc_common_head instead.
+
 2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
        * expr.c (gfc_check_pointer_assign): Verify that rank of the LHS

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 94573ac9df57443a2c4cf41eab189a7de4361880..3a78efc65609cbcac7a80f5e914b9ee30d5f09dd 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2699,14 +2699,7 @@ gfc_match_save (void)
       if (m == MATCH_NO)
        goto syntax;
 
-      c = gfc_get_common (n);
-
-      if (c->use_assoc) 
-       {       
-         gfc_error("COMMON block '%s' at %C is already USE associated", n);
-         return MATCH_ERROR;
-       }
-
+      c = gfc_get_common (n, 0);
       c->saved = 1;
 
       gfc_current_ns->seen_save = 1;

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d82d30621d756d982aa7ada205855ecacdcdf257..3ea8bb6431b3668a3e6718aebbaf83a476bfc09f 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -678,6 +678,7 @@ typedef struct
 {
   locus where;
   int use_assoc, saved;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symbol *head;
 } 
 gfc_common_head;
@@ -1697,4 +1698,4 @@ void gfc_show_namespace (gfc_namespace *);
 /* parse.c */
 try gfc_parse_file (void);
 
-#endif /* GFC_GFC_H  */
+#endif /* GCC_GFORTRAN_H  */

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2d85a56cc7d5db5ec7f08d9fe299c71078ee142e..040142f766ceef60c2402af0bc6a95a8ff95b576 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2049,22 +2049,38 @@ cleanup:
 
 
 /* Given a name, return a pointer to the common head structure,
-   creating it if it does not exist.
+   creating it if it does not exist. If FROM_MODULE is non-zero, we
+   mangle the name so that it doesn't interfere with commons defined 
+   in the using namespace.
    TODO: Add to global symbol tree.  */
 
 gfc_common_head *
-gfc_get_common (char *name)
+gfc_get_common (const char *name, int from_module)
 {
   gfc_symtree *st;
+  static int serial = 0;
+  char mangled_name[GFC_MAX_SYMBOL_LEN+1];
 
-  st = gfc_find_symtree (gfc_current_ns->common_root, name);
-  if (st == NULL)
-    st = gfc_new_symtree (&gfc_current_ns->common_root, name);
+  if (from_module)
+    {
+      /* A use associated common block is only needed to correctly layout
+        the variables it contains.  */
+      snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+      st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
+    }
+  else
+    {
+      st = gfc_find_symtree (gfc_current_ns->common_root, name);
+
+      if (st == NULL)
+       st = gfc_new_symtree (&gfc_current_ns->common_root, name);
+    }
 
   if (st->n.common == NULL)
     {
       st->n.common = gfc_get_common_head ();
       st->n.common->where = gfc_current_locus;
+      strcpy (st->n.common->name, name);
     }
 
   return st->n.common;
@@ -2140,15 +2156,8 @@ gfc_match_common (void)
        }
       else
        {
-         t = gfc_get_common (name);
+         t = gfc_get_common (name, 0);
          head = &t->head;
-
-         if (t->use_assoc)
-           {
-             gfc_error ("COMMON block '%s' at %C has already "
-                        "been USE-associated", name);
-             goto cleanup;
-           }
        }
 
       if (*head == NULL)

diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 4b8f87232ec82676fcc760849789b6d671c81b8f..032a6a310b95d175687ce94ae6f40a21948feab3 100644 (file)
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -89,7 +89,7 @@ match gfc_match_forall (gfc_statement *);
 
 /* Other functions.  */
 
-gfc_common_head *gfc_get_common (char *);
+gfc_common_head *gfc_get_common (const char *, int);
 
 /* decl.c */
 

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8fce458a65545949749161ce8301ccce52d3703c..33f050b91dcaee3ee417876c25f3e08ea533c03e 100644 (file)
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -2825,7 +2825,7 @@ load_commons(void)
       mio_lparen ();
       mio_internal_string (name);
 
-      p = gfc_get_common (name);
+      p = gfc_get_common (name, 1);
 
       mio_symbol_ref (&p->head);
       mio_integer (&p->saved);

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 9208d2205d9eafa4d8f276b428eab99232721a62..3159436eeb90d365aa9c88579c00d3133f4d6ff6 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2139,6 +2139,22 @@ gfc_commit_symbols (void)
 }
 
 
+/* Recursive function that deletes an entire tree and all the common
+   head structures it points to.  */
+
+static void
+free_common_tree (gfc_symtree * common_tree)
+{
+  if (common_tree == NULL)
+    return;
+
+  free_common_tree (common_tree->left);
+  free_common_tree (common_tree->right);
+
+  gfc_free (common_tree);
+}  
+
+
 /* Recursive function that deletes an entire tree and all the user
    operator nodes that it contains.  */
 
@@ -2216,6 +2232,7 @@ gfc_free_namespace (gfc_namespace * ns)
 
   free_sym_tree (ns->sym_root);
   free_uop_tree (ns->uop_root);
+  free_common_tree (ns->common_root);
 
   for (cl = ns->cl_list; cl; cl = cl2)
     {

diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index d20a60be906cf4c616b9a98518bf3ad3ccb9fa50..7907020371e21085cf3a2370e02288fc480f635d 100644 (file)
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -277,8 +277,7 @@ build_equiv_decl (tree union_type, bool is_init)
 /* Get storage for common block.  */
 
 static tree
-build_common_decl (gfc_common_head *com, const char *name,
-                  tree union_type, bool is_init)
+build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
 {
   gfc_symbol *common_sym;
   tree decl;
@@ -287,7 +286,7 @@ build_common_decl (gfc_common_head *com, const char *name,
   if (gfc_common_ns == NULL)
     gfc_common_ns = gfc_get_namespace (NULL);
 
-  gfc_get_symbol (name, gfc_common_ns, &common_sym);
+  gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
   decl = common_sym->backend_decl;
 
   /* Update the size of this common block as needed.  */
@@ -299,9 +298,9 @@ build_common_decl (gfc_common_head *com, const char *name,
           /* Named common blocks of the same name shall be of the same size
              in all scoping units of a program in which they appear, but
              blank common blocks may be of different sizes.  */
-          if (strcmp (name, BLANK_COMMON_NAME))
+          if (strcmp (com->name, BLANK_COMMON_NAME))
            gfc_warning ("Named COMMON block '%s' at %L shall be of the "
-                        "same size", name, &com->where);
+                        "same size", com->name, &com->where);
           DECL_SIZE_UNIT (decl) = size;
         }
      }
@@ -315,8 +314,8 @@ build_common_decl (gfc_common_head *com, const char *name,
   /* If there is no backend_decl for the common block, build it.  */
   if (decl == NULL_TREE)
     {
-      decl = build_decl (VAR_DECL, get_identifier (name), union_type);
-      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (name));
+      decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
+      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (com->name));
       TREE_PUBLIC (decl) = 1;
       TREE_STATIC (decl) = 1;
       DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
@@ -348,7 +347,7 @@ build_common_decl (gfc_common_head *com, const char *name,
    backend declarations for all of the elements.  */
 
 static void
-create_common (gfc_common_head *com, const char *name)
+create_common (gfc_common_head *com)
 {
   segment_info *s, *next_s;
   tree union_type;
@@ -377,7 +376,7 @@ create_common (gfc_common_head *com, const char *name)
   finish_record_layout (rli, true);
 
   if (com)
-    decl = build_common_decl (com, name, union_type, is_init);
+    decl = build_common_decl (com, union_type, is_init);
   else
     decl = build_equiv_decl (union_type, is_init);
 
@@ -720,7 +719,7 @@ add_equivalences (void)
    and all of the symbols equivalenced with that symbol.  */
 
 static void
-new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
+new_segment (gfc_common_head *common, gfc_symbol *sym)
 {
 
   current_segment = get_segment_info (sym, current_offset);
@@ -733,8 +732,9 @@ new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
   add_equivalences ();
 
   if (current_segment->offset < 0)
-    gfc_error ("The equivalence set for '%s' cause an invalid extension "
-              "to COMMON '%s' at %L", sym->name, name, &common->where);
+    gfc_error ("The equivalence set for '%s' cause an invalid "
+              "extension to COMMON '%s' at %L", sym->name,
+              common->name, &common->where);
 
   /* Add these to the common block.  */
   current_common = add_segments (current_common, current_segment);
@@ -770,7 +770,7 @@ finish_equivalences (gfc_namespace *ns)
          v->offset -= min_offset;
 
         current_common = current_segment;
-        create_common (NULL, NULL);
+        create_common (NULL);
         break;
       }
 }
@@ -779,8 +779,7 @@ finish_equivalences (gfc_namespace *ns)
 /* Translate a single common block.  */
 
 static void
-translate_common (gfc_common_head *common, const char *name,
-                 gfc_symbol *var_list)
+translate_common (gfc_common_head *common, gfc_symbol *var_list)
 {
   gfc_symbol *sym;
 
@@ -791,10 +790,10 @@ translate_common (gfc_common_head *common, const char *name,
   for (sym = var_list; sym; sym = sym->common_next)
     {
       if (! sym->equiv_built)
-       new_segment (common, name, sym);
+       new_segment (common, sym);
     }
 
-  create_common (common, name);
+  create_common (common);
 }
 
 
@@ -804,7 +803,7 @@ static void
 named_common (gfc_symtree *st)
 {
 
-  translate_common (st->n.common, st->name, st->n.common->head);
+  translate_common (st->n.common, st->n.common->head);
 }
 
 
@@ -821,7 +820,8 @@ gfc_trans_common (gfc_namespace *ns)
   if (ns->blank_common.head != NULL)
     {
       c = gfc_get_common_head ();
-      translate_common (c, BLANK_COMMON_NAME, ns->blank_common.head);
+      strcpy (c->name, BLANK_COMMON_NAME);
+      translate_common (c, ns->blank_common.head);
     }
  
   /* Translate all named common blocks.  */