Andrew Vaught <andyv@firstinter.net>

2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
Andrew Vaught  <andyv@firstinter.net>

PR fortran/13249
PR fortran/15481
* declc (gfc_match_save): Adapt to new common structures,
don't allow saving USE-associated common.
* dump-parse-tree (gfc_show_attr): (saved_)common are not
symbol attributes any longer.
(gfc_show_symbol): Don't show old-style commons any longer.
(gfc_show_namespace): Adapt call to gfc_traverse_symtree to new
interface.
* gfortran.h (symbol_attribute): Remove common and saved_common
attributes.
(gfc_symbol): Remove common_head element.
(gfc_common_head): New struct.
(gfc_get_common_head): New macro.
(gfc_symtree): Add field 'common' to union.
(gfc_namespace): Add field 'common_root'; change type of field
'blank_common' to blank_common.
(gfc_add_data): New prototype.
(gfc_traverse_symtree): Expect a symtree as first argument
instead of namespace.
* match.c (gfc_get_common): New function.
(match_common_name): Change to take char * as argument, adapt,
fix bug with empty name.
(gfc_match_common): Adapt to new data structures. Disallow
redeclaration of USE-associated COMMON-block. Fix bug with
empty common.
(var_element): Adapt to new common structures.
* match.h (gfc_get_common): Declare.
* module.c: Add 2004 to copyright years, add commons to module
file layout description.
(ab_attribute, attr_bits, mio_symbol_attributes): Remove code
for removed attributes.
(mio_symbol): Adapt to new way of storing common relations.
(load_commons): New function.
(read_module): Skip common list on first pass, load_commons at
second.
(write_commons): New function.
(write_module): Call write_commons().
* symbol.c (gfc_add_saved_comon, gfc_add_common): Remove
functions related to removed attributes.
(gfc_add_data): New function.
(gfc_clear_attr): Don't set removed attributes.
(gfc_copy_attr): Don't copy removed attributes.
(traverse_symtree): Remove.
(gfc_traverse_symtree): Don't traverse symbol
tree of the passed namespace, but require a symtree to be passed
instead. Unify with traverse_symtree.
(gfc_traverse_ns): Call gfc_traverse_symtree according to new
interface.
(save_symbol): Remove setting of removed attribute.
* trans-common.c (gfc_sym_mangled_common_id): Change to
take 'char *' argument instead of 'gfc_symbol'.
(build_common_decl, new_segment, translate_common): Adapt to new
data structures, add new
argument name.
(create_common): Adapt to new data structures, add new
argument name. Fix typo in intialization of derived types.
(finish_equivalences): Add second argument in call to
create_common.
(named_common): take 'gfc_symtree' instead of 'gfc_symbol'.
(gfc_trans_common): Adapt to new data structures.
* trans-decl.c (gfc_create_module_variables): Also output
symbols from commons.

Co-Authored-By: Andrew Vaught <andyv@firstinter.net>

From-SVN: r83871

1 files changed, 68 insertions, 23 deletions

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index bc2379d..d605361 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2246,23 +2246,49 @@ error:
 }
 
 
+/* Given a name, return a pointer to the common head structure,
+   creating it if it does not exist.
+   TODO: Add to global symbol tree.  */
+
+gfc_common_head *
+gfc_get_common (char *name)
+{
+  gfc_symtree *st;
+
+  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;
+    }
+
+  return st->n.common;
+}
+
+
 /* Match a common block name.  */
 
 static match
-match_common_name (gfc_symbol ** sym)
+match_common_name (char *name)
 {
   match m;
 
   if (gfc_match_char ('/') == MATCH_NO)
-    return MATCH_NO;
+    {
+      name[0] = '\0';
+      return MATCH_YES;
+    }
 
   if (gfc_match_char ('/') == MATCH_YES)
     {
-      *sym = NULL;
+      name[0] = '\0';
       return MATCH_YES;
     }
 
-  m = gfc_match_symbol (sym, 0);
+  m = gfc_match_name (name);
 
   if (m == MATCH_ERROR)
     return MATCH_ERROR;
@@ -2279,18 +2305,19 @@ match_common_name (gfc_symbol ** sym)
 match
 gfc_match_common (void)
 {
-  gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common;
+  gfc_symbol *sym, **head, *tail, *old_blank_common;
+  char name[GFC_MAX_SYMBOL_LEN+1];
+  gfc_common_head *t;
   gfc_array_spec *as;
   match m;
 
-  old_blank_common = gfc_current_ns->blank_common;
+  old_blank_common = gfc_current_ns->blank_common.head;
   if (old_blank_common)
     {
       while (old_blank_common->common_next)
 	old_blank_common = old_blank_common->common_next;
     }
 
-  common_name = NULL;
   as = NULL;
 
   if (gfc_match_eos () == MATCH_YES)
@@ -2298,19 +2325,28 @@ gfc_match_common (void)
 
   for (;;)
     {
-      m = match_common_name (&common_name);
+      m = match_common_name (name);
       if (m == MATCH_ERROR)
 	goto cleanup;
 
-      if (common_name == NULL)
-	head = &gfc_current_ns->blank_common;
+      if (name[0] == '\0')
+	{
+	  t = &gfc_current_ns->blank_common;
+	  if (t->head == NULL)
+	    t->where = gfc_current_locus;
+	  head = &t->head;
+	}
       else
 	{
-	  head = &common_name->common_head;
+	  t = gfc_get_common (name);
+	  head = &t->head;
 
-	  if (!common_name->attr.common
-	      && gfc_add_common (&common_name->attr, NULL) == FAILURE)
-	    goto cleanup;
+	  if (t->use_assoc)
+	    {
+	      gfc_error ("COMMON block '%s' at %C has already "
+			 "been USE-associated");
+	      goto cleanup;
+	    }
 	}
 
       if (*head == NULL)
@@ -2323,6 +2359,9 @@ gfc_match_common (void)
 	}
 
       /* Grab the list of symbols.  */
+      if (gfc_match_eos () == MATCH_YES)
+	goto done;
+  
       for (;;)
 	{
 	  m = gfc_match_symbol (&sym, 0);
@@ -2338,16 +2377,18 @@ gfc_match_common (void)
 	      goto cleanup;
 	    }
 
+	  if (gfc_add_in_common (&sym->attr, NULL) == FAILURE) 
+	    goto cleanup;
+
 	  if (sym->value != NULL
-	      && (common_name == NULL || !sym->attr.data))
+	      && (name[0] == '\0' || !sym->attr.data))
 	    {
-	      if (common_name == NULL)
+	      if (name[0] == '\0')
 		gfc_error ("Previously initialized symbol '%s' in "
 			   "blank COMMON block at %C", sym->name);
 	      else
 		gfc_error ("Previously initialized symbol '%s' in "
-			   "COMMON block '%s' at %C", sym->name,
-			   common_name->name);
+			   "COMMON block '%s' at %C", sym->name, name);
 	      goto cleanup;
 	    }
 
@@ -2422,7 +2463,7 @@ cleanup:
   if (old_blank_common)
     old_blank_common->common_next = NULL;
   else
-    gfc_current_ns->blank_common = NULL;
+    gfc_current_ns->blank_common.head = NULL;
   gfc_free_array_spec (as);
   return MATCH_ERROR;
 }
@@ -2827,7 +2868,8 @@ static match
 var_element (gfc_data_variable * new)
 {
   match m;
-  gfc_symbol *sym, *t;
+  gfc_symbol *sym;
+  gfc_common_head *t;
 
   memset (new, '\0', sizeof (gfc_data_variable));
 
@@ -2847,17 +2889,20 @@ var_element (gfc_data_variable * new)
       return MATCH_ERROR;
     }
 
+#if 0 // TODO: Find out where to move this message
   if (sym->attr.in_common)
     /* See if sym is in the blank common block.  */
-    for (t = sym->ns->blank_common; t; t = t->common_next)
-      if (sym == t)
+    for (t = &sym->ns->blank_common; t; t = t->common_next)
+      if (sym == t->head)
 	{
 	  gfc_error ("DATA statement at %C may not initialize variable "
 		     "'%s' from blank COMMON", sym->name);
 	  return MATCH_ERROR;
 	}
+#endif
 
-  sym->attr.data = 1;
+  if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
+    return MATCH_ERROR;
 
   return MATCH_YES;
 }