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, 69 insertions, 20 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index cf8f453..7f720ba 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1,6 +1,7 @@
 /* Handle modules, which amounts to loading and saving symbols and
    their attendant structures.
-   Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, 
+   Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -43,6 +44,9 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
      ...
    )
+   ( ( <common name> <symbol> <saved flag>)
+     ...
+   )
    ( <Symbol Number (in no particular order)>
      <True name of symbol>
      <Module name of symbol>
@@ -1361,8 +1365,8 @@ mio_internal_string (char *string)
 
 typedef enum
 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
-  AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_COMMON, AB_RESULT,
-  AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_SAVED_COMMON,
+  AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
+  AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
   AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
   AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
 }
@@ -1379,13 +1383,11 @@ static const mstring attr_bits[] =
     minit ("SAVE", AB_SAVE),
     minit ("TARGET", AB_TARGET),
     minit ("DUMMY", AB_DUMMY),
-    minit ("COMMON", AB_COMMON),
     minit ("RESULT", AB_RESULT),
     minit ("ENTRY", AB_ENTRY),
     minit ("DATA", AB_DATA),
     minit ("IN_NAMELIST", AB_IN_NAMELIST),
     minit ("IN_COMMON", AB_IN_COMMON),
-    minit ("SAVED_COMMON", AB_SAVED_COMMON),
     minit ("FUNCTION", AB_FUNCTION),
     minit ("SUBROUTINE", AB_SUBROUTINE),
     minit ("SEQUENCE", AB_SEQUENCE),
@@ -1450,8 +1452,6 @@ mio_symbol_attribute (symbol_attribute * attr)
 	MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
       if (attr->dummy)
 	MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
-      if (attr->common)
-	MIO_NAME(ab_attribute) (AB_COMMON, attr_bits);
       if (attr->result)
 	MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
       if (attr->entry)
@@ -1463,8 +1463,6 @@ mio_symbol_attribute (symbol_attribute * attr)
 	MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
       if (attr->in_common)
 	MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
-      if (attr->saved_common)
-	MIO_NAME(ab_attribute) (AB_SAVED_COMMON, attr_bits);
 
       if (attr->function)
 	MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
@@ -1527,9 +1525,6 @@ mio_symbol_attribute (symbol_attribute * attr)
 	    case AB_DUMMY:
 	      attr->dummy = 1;
 	      break;
-	    case AB_COMMON:
-	      attr->common = 1;
-	      break;
 	    case AB_RESULT:
 	      attr->result = 1;
 	      break;
@@ -1545,9 +1540,6 @@ mio_symbol_attribute (symbol_attribute * attr)
 	    case AB_IN_COMMON:
 	      attr->in_common = 1;
 	      break;
-	    case AB_SAVED_COMMON:
-	      attr->saved_common = 1;
-	      break;
 	    case AB_FUNCTION:
 	      attr->function = 1;
 	      break;
@@ -2679,7 +2671,6 @@ mio_symbol (gfc_symbol * sym)
     }
 
   /* Save/restore common block links */
-  mio_symbol_ref (&sym->common_head);
   mio_symbol_ref (&sym->common_next);
 
   mio_formal_arglist (sym);
@@ -2698,9 +2689,6 @@ mio_symbol (gfc_symbol * sym)
     sym->component_access =
       MIO_NAME(gfc_access) (sym->component_access, access_types);
 
-  mio_symbol_ref (&sym->common_head);
-  mio_symbol_ref (&sym->common_next);
-
   mio_rparen ();
 }
 
@@ -2820,6 +2808,34 @@ load_generic_interfaces (void)
 }
 
 
+/* Load common blocks.  */
+
+static void
+load_commons(void)
+{
+  char name[GFC_MAX_SYMBOL_LEN+1];
+  gfc_common_head *p;
+
+  mio_lparen ();
+
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_lparen ();
+      mio_internal_string (name);
+
+      p = gfc_get_common (name);
+
+      mio_symbol_ref (&p->head);
+      mio_integer (&p->saved);
+      p->use_assoc = 1;
+
+      mio_rparen();
+    }
+
+  mio_rparen();
+}
+
+
 /* Recursive function to traverse the pointer_info tree and load a
    needed symbol.  We return nonzero if we load a symbol and stop the
    traversal, because the act of loading can alter the tree.  */
@@ -2931,6 +2947,7 @@ read_module (void)
   get_module_locus (&user_operators);
   skip_list ();
   skip_list ();
+  skip_list ();
 
   mio_lparen ();
 
@@ -3067,6 +3084,8 @@ read_module (void)
   load_operator_interfaces ();
   load_generic_interfaces ();
 
+  load_commons ();
+
   /* At this point, we read those symbols that are needed but haven't
      been loaded yet.  If one symbol requires another, the other gets
      marked as NEEDED if its previous state was UNUSED.  */
@@ -3137,6 +3156,30 @@ check_access (gfc_access specific_access, gfc_access default_access)
 }
 
 
+/* Write a common block to the module */
+
+static void
+write_common (gfc_symtree *st)
+{
+  gfc_common_head *p;
+
+  if (st == NULL)
+    return;
+
+  write_common(st->left);
+  write_common(st->right);
+
+  mio_lparen();
+  mio_internal_string(st->name);
+
+  p = st->n.common;
+  mio_symbol_ref(&p->head);
+  mio_integer(&p->saved);
+
+  mio_rparen();
+}
+
+
 /* Write a symbol to the module.  */
 
 static void
@@ -3329,6 +3372,12 @@ write_module (void)
   write_char ('\n');
   write_char ('\n');
 
+  mio_lparen ();
+  write_common (gfc_current_ns->common_root);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
   /* Write symbol information.  First we traverse all symbols in the
      primary namespace, writing those that need to be written.
      Sometimes writing one symbol will cause another to need to be
@@ -3347,7 +3396,7 @@ write_module (void)
   write_char ('\n');
 
   mio_lparen ();
-  gfc_traverse_symtree (gfc_current_ns, write_symtree);
+  gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
   mio_rparen ();
 }