2005-09-09 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/18878
	* module.c (find_use_name_n): Based on original
	find_use_name. Either counts number of use names for a
	given real name or returns use name n.
	(find_use_name, number_use_names): Interfaces to the
	function find_use_name_n.
	(read_module): Add the logic and calls to these functions,
	so that mutiple reuses of the same real name are loaded.

2005-09-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22304
	PR fortran/23270
	PR fortran/18870
	PR fortran/16511
	PR fortran/17917
	* gfortran.h: Move definition of BLANK_COMMON_NAME from trans-
	common.c so that it is accessible to module.c. Add common_head
	field to gfc_symbol structure. Add field for the equivalence
	name AND new attr field, in_equivalence.
	* match.c (gfc_match_common, gfc_match_equivalence): In loops
	that flag common block equivalences, emit an error if the
	common blocks are different, using sym->common_head as the
	common block identifier. Ensure that symbols that are equivalence
	associated with a common block are marked as being in_common.
	* module.c (write_blank_common): New.
	(write_common): Use unmangled common block name.
	(load_equiv): New function ported from g95.
	(read_module): Call load_equiv.
	(write_equiv): New function ported from g95. Correct
	string referencing for gfc functions. Give module
	equivalences a unique name.
	(write_module): Call write_equiv and write_blank_common.
	* primary.c (match_variable) Old gfc_match_variable, made
	static and third argument provided to indicate if parent
	namespace to be visited or not.
	(gfc_match_variable) New. Interface to match_variable.
	(gfc_match_equiv_variable) New. Interface to match_variable.
	* trans-common.c (finish_equivalences): Provide the call
	to create_common with a gfc_common_header so that
	module equivalences are made external, rather than local.
	(find_equivalences): Ensure that all members in common block
	equivalences are marked as used. This prevents the subsequent
	call to this function from making local unions.
	* trans-decl.c (gfc_generate_function_code): Move the call to
	gfc_generate_contained_functions to after the call to
	gfc_trans_common so the use-associated, contained common
	blocks produce the correct references.
	(gfc_create_module_variable): Return for equivalenced symbols
	with existing backend declaration.

2005-09-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/18878
	* gfortran.dg/module_double_reuse.f90: New.

2005-09-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23270
	PR fortran/22304
	PR fortran/18870
	PR fortran/17917
	PR fortran/16511
	* gfortran.dg/common_equivalence_1.f: New.
	* gfortran.dg/common_equivalence_2.f: New.
	* gfortran.dg/common_equivalence_3.f: New.
	* gfortran.dg/contained_equivalence_1.f90: New.
	* gfortran.dg/module_blank_common.f90: New.
	* gfortran.dg/module_commons_1.f90: New.
	* gfortran.dg/module_equivalence_1.f90: New.
	* gfortran.dg/nested_modules_1.f90: New.
	* gfortran.dg/g77/19990905-0.f: Remove XFAIL, rearrange
	equivalences and add comment to connect the test with
	the PR.


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

1 files changed, 193 insertions, 42 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index db510fdbc36..b11a16baff1 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -47,6 +47,9 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
    ( ( <common name> <symbol> <saved flag>)
      ...
    )
+
+   ( equivalence list )
+
    ( <Symbol Number (in no particular order)>
      <True name of symbol>
      <Module name of symbol>
@@ -582,20 +585,34 @@ syntax:
 cleanup:
   free_rename ();
   return MATCH_ERROR;
-}
+ }
 
 
-/* Given a name, return the name under which to load this symbol.
-   Returns NULL if this symbol shouldn't be loaded.  */
+/* Given a name and a number, inst, return the inst name
+   under which to load this symbol. Returns NULL if this
+   symbol shouldn't be loaded. If inst is zero, returns
+   the number of instances of this name.  */
 
 static const char *
-find_use_name (const char *name)
+find_use_name_n (const char *name, int *inst)
 {
   gfc_use_rename *u;
+  int i;
 
+  i = 0;
   for (u = gfc_rename_list; u; u = u->next)
-    if (strcmp (u->use_name, name) == 0)
-      break;
+    {
+      if (strcmp (u->use_name, name) != 0)
+	continue;
+      if (++i == *inst)
+	break;
+    }
+
+  if (!*inst)
+    {
+      *inst = i;
+      return NULL;
+    }
 
   if (u == NULL)
     return only_flag ? NULL : name;
@@ -605,6 +622,28 @@ find_use_name (const char *name)
   return (u->local_name[0] != '\0') ? u->local_name : name;
 }
 
+/* Given a name, return the name under which to load this symbol.
+   Returns NULL if this symbol shouldn't be loaded.  */
+
+static const char *
+find_use_name (const char *name)
+{
+  int i = 1;
+  return find_use_name_n (name, &i);
+}
+
+/* Given a real name, return the number of use names associated
+   with it.  */
+
+static int
+number_use_names (const char *name)
+{
+  int i = 0;
+  const char *c;
+  c = find_use_name_n (name, &i);
+  return i;
+}
+
 
 /* Try to find the operator in the current list.  */
 
@@ -2920,6 +2959,48 @@ load_commons(void)
   mio_rparen();
 }
 
+/* load_equiv()-- Load equivalences. */
+
+static void
+load_equiv(void)
+{
+  gfc_equiv *head, *tail, *end;
+
+  mio_lparen();
+
+  end = gfc_current_ns->equiv;
+  while(end != NULL && end->next != NULL)
+    end = end->next;
+
+  while(peek_atom() != ATOM_RPAREN) {
+    mio_lparen();
+    head = tail = NULL;
+
+    while(peek_atom() != ATOM_RPAREN)
+      {
+	if (head == NULL)
+	  head = tail = gfc_get_equiv();
+	else
+	  {
+	    tail->eq = gfc_get_equiv();
+	    tail = tail->eq;
+	  }
+
+	mio_pool_string(&tail->module);
+	mio_expr(&tail->expr);
+      }
+
+    if (end == NULL)
+      gfc_current_ns->equiv = head;
+    else
+      end->next = head;
+
+    end = head;
+    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
@@ -3020,7 +3101,7 @@ read_module (void)
   const char *p;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_intrinsic_op i;
-  int ambiguous, symbol;
+  int ambiguous, symbol, j, nuse;
   pointer_info *info;
   gfc_use_rename *u;
   gfc_symtree *st;
@@ -3032,6 +3113,9 @@ read_module (void)
   get_module_locus (&user_operators);
   skip_list ();
   skip_list ();
+
+  /* Skip commons and equivalences for now.  */
+  skip_list ();
   skip_list ();
 
   mio_lparen ();
@@ -3084,50 +3168,60 @@ read_module (void)
 
       info = get_integer (symbol);
 
-      /* Get the local name for this symbol.  */
-      p = find_use_name (name);
-
-      /* Skip symtree nodes not in an ONLY caluse.  */
-      if (p == NULL)
-	continue;
+      /* See how many use names there are.  If none, go through the start
+	 of the loop at least once.  */
+      nuse = number_use_names (name);
+      if (nuse == 0)
+	nuse = 1;
 
-      /* Check for ambiguous symbols.  */
-      st = gfc_find_symtree (gfc_current_ns->sym_root, p);
-
-      if (st != NULL)
-	{
-	  if (st->n.sym != info->u.rsym.sym)
-	    st->ambiguous = 1;
-          info->u.rsym.symtree = st;
-	}
-      else
+      for (j = 1; j <= nuse; j++)
 	{
-          /* Create a symtree node in the current namespace for this symbol.  */
-	  st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
-	    gfc_new_symtree (&gfc_current_ns->sym_root, p);
+	  /* Get the jth local name for this symbol.  */
+	  p = find_use_name_n (name, &j);
 
-	  st->ambiguous = ambiguous;
+	  /* Skip symtree nodes not in an ONLY clause.  */
+	  if (p == NULL)
+	    continue;
 
-	  sym = info->u.rsym.sym;
+	  /* Check for ambiguous symbols.  */
+	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
 
-          /* Create a symbol node if it doesn't already exist.  */
-	  if (sym == NULL)
+	  if (st != NULL)
 	    {
-	      sym = info->u.rsym.sym =
-		gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
-
-	      sym->module = gfc_get_string (info->u.rsym.module);
+	      if (st->n.sym != info->u.rsym.sym)
+		st->ambiguous = 1;
+	      info->u.rsym.symtree = st;
 	    }
+	  else
+	    {
+	      /* Create a symtree node in the current namespace for this symbol.  */
+	      st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
+	      gfc_new_symtree (&gfc_current_ns->sym_root, p);
+
+	      st->ambiguous = ambiguous;
+
+	      sym = info->u.rsym.sym;
+
+	      /* Create a symbol node if it doesn't already exist.  */
+	      if (sym == NULL)
+		{
+		  sym = info->u.rsym.sym =
+		      gfc_new_symbol (info->u.rsym.true_name
+				      , gfc_current_ns);
 
-	  st->n.sym = sym;
-	  st->n.sym->refs++;
+		  sym->module = gfc_get_string (info->u.rsym.module);
+		}
+
+	      st->n.sym = sym;
+	      st->n.sym->refs++;
 
-          /* Store the symtree pointing to this symbol.  */
-          info->u.rsym.symtree = st;
+	      /* Store the symtree pointing to this symbol.  */
+	      info->u.rsym.symtree = st;
 
-	  if (info->u.rsym.state == UNUSED)
-	    info->u.rsym.state = NEEDED;
-	  info->u.rsym.referenced = 1;
+	      if (info->u.rsym.state == UNUSED)
+	        info->u.rsym.state = NEEDED;
+	      info->u.rsym.referenced = 1;
+	    }
 	}
     }
 
@@ -3170,6 +3264,7 @@ read_module (void)
   load_generic_interfaces ();
 
   load_commons ();
+  load_equiv();
 
   /* At this point, we read those symbols that are needed but haven't
      been loaded yet.  If one symbol requires another, the other gets
@@ -3241,6 +3336,7 @@ static void
 write_common (gfc_symtree *st)
 {
   gfc_common_head *p;
+  const char * name;
 
   if (st == NULL)
     return;
@@ -3249,7 +3345,11 @@ write_common (gfc_symtree *st)
   write_common(st->right);
 
   mio_lparen();
-  mio_pool_string(&st->name);
+
+  /* Write the unmangled name.  */
+  name = st->n.common->name;
+
+  mio_pool_string(&name);
 
   p = st->n.common;
   mio_symbol_ref(&p->head);
@@ -3258,6 +3358,51 @@ write_common (gfc_symtree *st)
   mio_rparen();
 }
 
+/* Write the blank common block to the module */
+
+static void
+write_blank_common (void)
+{
+  const char * name = BLANK_COMMON_NAME;
+
+  if (gfc_current_ns->blank_common.head == NULL)
+    return;
+
+  mio_lparen();
+
+  mio_pool_string(&name);
+
+  mio_symbol_ref(&gfc_current_ns->blank_common.head);
+  mio_integer(&gfc_current_ns->blank_common.saved);
+
+  mio_rparen();
+}
+
+/* Write equivalences to the module.  */
+
+static void
+write_equiv(void)
+{
+  gfc_equiv *eq, *e;
+  int num;
+
+  num = 0;
+  for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
+    {
+      mio_lparen();
+
+      for(e=eq; e; e=e->eq)
+	{
+	  if (e->module == NULL)
+	    e->module = gfc_get_string("%s.eq.%d", module_name, num);
+	  mio_allocated_string(e->module);
+	  mio_expr(&e->expr);
+	}
+
+      num++;
+      mio_rparen();
+    }
+}
 
 /* Write a symbol to the module.  */
 
@@ -3444,11 +3589,17 @@ write_module (void)
   write_char ('\n');
 
   mio_lparen ();
+  write_blank_common ();
   write_common (gfc_current_ns->common_root);
   mio_rparen ();
   write_char ('\n');
   write_char ('\n');
 
+  mio_lparen();
+  write_equiv();
+  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