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, 34 insertions, 33 deletions

diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index f0c385adfbb..769469d9cca 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -168,24 +168,24 @@ add_segments (segment_info *list, segment_info *v)
 /* Construct mangled common block name from symbol name.  */
 
 static tree
-gfc_sym_mangled_common_id (gfc_symbol *sym)
+gfc_sym_mangled_common_id (const char  *name)
 {
   int has_underscore;
-  char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+  char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 
-  if (strcmp (sym->name, BLANK_COMMON_NAME) == 0)
-    return get_identifier (sym->name);
+  if (strcmp (name, BLANK_COMMON_NAME) == 0)
+    return get_identifier (name);
   if (gfc_option.flag_underscoring)
     {
-      has_underscore = strchr (sym->name, '_') != 0;
+      has_underscore = strchr (name, '_') != 0;
       if (gfc_option.flag_second_underscore && has_underscore)
-        snprintf (name, sizeof name, "%s__", sym->name);
+        snprintf (mangled_name, sizeof mangled_name, "%s__", name);
       else
-        snprintf (name, sizeof name, "%s_", sym->name);
-      return get_identifier (name);
+        snprintf (mangled_name, sizeof mangled_name, "%s_", name);
+      return get_identifier (mangled_name);
     }
   else
-    return get_identifier (sym->name);
+    return get_identifier (name);
 }
 
 
@@ -252,7 +252,8 @@ build_equiv_decl (tree union_type, bool is_init)
 /* Get storage for common block.  */
 
 static tree
-build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
+build_common_decl (gfc_common_head *com, const char *name, 
+		   tree union_type, bool is_init)
 {
   gfc_symbol *common_sym;
   tree decl;
@@ -261,7 +262,7 @@ build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
   if (gfc_common_ns == NULL)
     gfc_common_ns = gfc_get_namespace (NULL);
 
-  gfc_get_symbol (sym->name, gfc_common_ns, &common_sym);
+  gfc_get_symbol (name, gfc_common_ns, &common_sym);
   decl = common_sym->backend_decl;
 
   /* Update the size of this common block as needed.  */
@@ -273,9 +274,9 @@ build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
           /* 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 (sym->name, BLANK_COMMON_NAME))
+          if (strcmp (name, BLANK_COMMON_NAME))
               gfc_warning ("Named COMMON block '%s' at %L shall be of the "
-                           "same size", sym->name, &sym->declared_at);
+                           "same size", name, &com->where);
           DECL_SIZE_UNIT (decl) = size;
         }
      }
@@ -289,8 +290,8 @@ build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
   /* If there is no backend_decl for the common block, build it.  */
   if (decl == NULL_TREE)
     {
-      decl = build_decl (VAR_DECL, get_identifier (sym->name), union_type);
-      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (sym));
+      decl = build_decl (VAR_DECL, get_identifier (name), union_type);
+      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (name));
       TREE_PUBLIC (decl) = 1;
       TREE_STATIC (decl) = 1;
       DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
@@ -323,7 +324,7 @@ build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
    backend declarations for all of the elements.  */
 
 static void
-create_common (gfc_symbol *sym)
+create_common (gfc_common_head *com, const char *name)
 { 
   segment_info *h, *next_s; 
   tree union_type;
@@ -354,8 +355,8 @@ create_common (gfc_symbol *sym)
     }
   finish_record_layout (rli, true);
 
-  if (sym)
-    decl = build_common_decl (sym, union_type, is_init);
+  if (com)
+    decl = build_common_decl (com, name, union_type, is_init);
   else
     decl = build_equiv_decl (union_type, is_init);
 
@@ -395,7 +396,7 @@ create_common (gfc_symbol *sym)
 
 		    case BT_DERIVED:
 		      gfc_init_se (&se, NULL);
-		      gfc_conv_structure (&se, sym->value, 1);
+		      gfc_conv_structure (&se, h->sym->value, 1);
 		      break;
 
 		    default:
@@ -725,7 +726,7 @@ add_equivalences (void)
    and all of the symbols equivalenced with that symbol.  */
  
 static void
-new_segment (gfc_symbol *common_sym, gfc_symbol *sym)
+new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
 {
   HOST_WIDE_INT length;
 
@@ -742,7 +743,7 @@ new_segment (gfc_symbol *common_sym, gfc_symbol *sym)
   if (current_segment->offset < 0)
     gfc_error ("The equivalence set for '%s' cause an invalid extension "
 	       "to COMMON '%s' at %L",
-	       sym->name, common_sym->name, &common_sym->declared_at);
+	       sym->name, name, &common->where);
 
   /* The offset of the next common variable.  */ 
   current_offset += length;
@@ -783,7 +784,7 @@ finish_equivalences (gfc_namespace *ns)
 	  v->offset -= min_offset;
 
         current_common = current_segment;
-        create_common (NULL);
+        create_common (NULL, NULL);
         break;
       }
 }
@@ -792,7 +793,8 @@ finish_equivalences (gfc_namespace *ns)
 /* Translate a single common block.  */
 
 static void 
-translate_common (gfc_symbol *common_sym, gfc_symbol *var_list)
+translate_common (gfc_common_head *common, const char *name, 
+		  gfc_symbol *var_list)
 {
   gfc_symbol *sym;
 
@@ -803,20 +805,19 @@ translate_common (gfc_symbol *common_sym, gfc_symbol *var_list)
   for (sym = var_list; sym; sym = sym->common_next)
     {
       if (! sym->equiv_built)
-	new_segment (common_sym, sym);
+	new_segment (common, name, sym);
     }
 
-  create_common (common_sym);
+  create_common (common, name);
 }          
  
 
 /* Work function for translating a named common block.  */
 
 static void
-named_common (gfc_symbol *s)
+named_common (gfc_symtree *st)
 {
-  if (s->attr.common)
-    translate_common (s, s->common_head);
+  translate_common (st->n.common, st->name, st->n.common->head);
 }
 
 
@@ -827,17 +828,17 @@ named_common (gfc_symbol *s)
 void 
 gfc_trans_common (gfc_namespace *ns)
 {
-  gfc_symbol *sym;
+  gfc_common_head *c;
 
   /* Translate the blank common block.  */
-  if (ns->blank_common != NULL)
+  if (ns->blank_common.head != NULL)
     {
-      gfc_get_symbol (BLANK_COMMON_NAME, ns, &sym);
-      translate_common (sym, ns->blank_common);
+      c = gfc_get_common_head ();
+      translate_common (c, BLANK_COMMON_NAME, ns->blank_common.head);
     }
  
   /* Translate all named common blocks.  */
-  gfc_traverse_ns (ns, named_common); 
+  gfc_traverse_symtree (ns->common_root, named_common); 
 
   /* Commit the newly created symbols for common blocks.  */
   gfc_commit_symbols ();