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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@84476 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog

+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

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;

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  */

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)

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 */
 

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

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)
     {

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.  */