re PR fortran/18878 ([4.0 only] erronous error message on vaild USE statement)

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.

From-SVN: r104060

gcc/fortran/ChangeLog

+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-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	PR fortran/23765

gcc/fortran/gfortran.h

@@ -77,6 +77,8 @@ char *alloca ();
 #define PREFIX(x) "_gfortran_" x
 #define PREFIX_LEN 10
 
+#define BLANK_COMMON_NAME "__BLNK__"
+
 /* Macro to initialize an mstring structure.  */
 #define minit(s, t) { s, NULL, t }
 
@@ -419,7 +421,7 @@ typedef struct
   unsigned data:1,		/* Symbol is named in a DATA statement.  */
     use_assoc:1;		/* Symbol has been use-associated.  */
 
-  unsigned in_namelist:1, in_common:1;
+  unsigned in_namelist:1, in_common:1, in_equivalence:1;
   unsigned function:1, subroutine:1, generic:1;
   unsigned implicit_type:1;	/* Type defined via implicit rules.  */
   unsigned untyped:1;           /* No implicit type could be found.  */
@@ -706,6 +708,11 @@ typedef struct gfc_symbol
   gfc_component *components;	/* Derived type components */
 
   struct gfc_symbol *common_next;	/* Links for COMMON syms */
+
+  /* This is in fact a gfc_common_head but it is only used for pointer
+     comparisons to check if symbols are in the same common block.  */
+  struct gfc_common_head* common_head;
+
   /* Make sure setup code for dummy arguments is generated in the correct
      order.  */
   int dummy_order;
@@ -734,12 +741,12 @@ gfc_symbol;
 
 /* This structure is used to keep track of symbols in common blocks.  */
 
-typedef struct
+typedef struct gfc_common_head
 {
   locus where;
   int use_assoc, saved;
   char name[GFC_MAX_SYMBOL_LEN + 1];
-  gfc_symbol *head;
+  struct gfc_symbol *head;
 } 
 gfc_common_head;
 
@@ -1194,6 +1201,7 @@ typedef struct gfc_equiv
 {
   struct gfc_equiv *next, *eq;
   gfc_expr *expr;
+  const char *module;
   int used;
 }
 gfc_equiv;

gcc/fortran/match.c

@@ -2226,10 +2226,11 @@ match_common_name (char *name)
 match
 gfc_match_common (void)
 {
-  gfc_symbol *sym, **head, *tail, *old_blank_common;
+  gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
   char name[GFC_MAX_SYMBOL_LEN+1];
   gfc_common_head *t;
   gfc_array_spec *as;
+  gfc_equiv * e1, * e2;
   match m;
 
   old_blank_common = gfc_current_ns->blank_common.head;
@@ -2348,8 +2349,46 @@ gfc_match_common (void)
 
 	      sym->as = as;
 	      as = NULL;
+
+	    }
+
+	  sym->common_head = t;
+
+	  /* Check to see if the symbol is already in an equivalence group.
+	     If it is, set the other members as being in common.  */
+	  if (sym->attr.in_equivalence)
+	    {
+	      for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
+	        {
+	          for (e2 = e1; e2; e2 = e2->eq)
+	            if (e2->expr->symtree->n.sym == sym)
+		      goto equiv_found;
+
+		  continue;
+
+	  equiv_found:
+
+		  for (e2 = e1; e2; e2 = e2->eq)
+		    {
+		      other = e2->expr->symtree->n.sym;
+		      if (other->common_head
+		            && other->common_head != sym->common_head)
+			{
+			  gfc_error ("Symbol '%s', in COMMON block '%s' at "
+				     "%C is being indirectly equivalenced to "
+				     "another COMMON block '%s'",
+				     sym->name,
+				     sym->common_head->name,
+				     other->common_head->name);
+			    goto cleanup;
+			}
+		      other->attr.in_common = 1;
+		      other->common_head = t;
+		    }
+		}
 	    }
 
+
 	  gfc_gobble_whitespace ();
 	  if (gfc_match_eos () == MATCH_YES)
 	    goto done;
@@ -2553,7 +2592,10 @@ gfc_match_equivalence (void)
 {
   gfc_equiv *eq, *set, *tail;
   gfc_ref *ref;
+  gfc_symbol *sym;
   match m;
+  gfc_common_head *common_head = NULL;
+  bool common_flag;
 
   tail = NULL;
 
@@ -2570,10 +2612,11 @@ gfc_match_equivalence (void)
 	goto syntax;
 
       set = eq;
+      common_flag = FALSE;
 
       for (;;)
 	{
-	  m = gfc_match_variable (&set->expr, 1);
+	  m = gfc_match_equiv_variable (&set->expr);
 	  if (m == MATCH_ERROR)
 	    goto cleanup;
 	  if (m == MATCH_NO)
@@ -2588,6 +2631,14 @@ gfc_match_equivalence (void)
 		goto cleanup;
 	      }
 
+	  if (set->expr->symtree->n.sym->attr.in_common)
+	    {
+	      common_flag = TRUE;
+	      common_head = set->expr->symtree->n.sym->common_head;
+	    }
+
+	  set->expr->symtree->n.sym->attr.in_equivalence = 1;
+
 	  if (gfc_match_char (')') == MATCH_YES)
 	    break;
 	  if (gfc_match_char (',') != MATCH_YES)
@@ -2597,6 +2648,26 @@ gfc_match_equivalence (void)
 	  set = set->eq;
 	}
 
+      /* If one of the members of an equivalence is in common, then
+	 mark them all as being in common.  Before doing this, check
+	 that members of the equivalence group are not in different
+	 common blocks. */
+      if (common_flag)
+	for (set = eq; set; set = set->eq)
+	  {
+	    sym = set->expr->symtree->n.sym;
+	    if (sym->common_head && sym->common_head != common_head)
+	      {
+		gfc_error ("Attempt to indirectly overlap COMMON "
+			   "blocks %s and %s by EQUIVALENCE at %C",
+			   sym->common_head->name,
+			   common_head->name);
+		goto cleanup;
+	      }
+	    sym->attr.in_common = 1;
+	    sym->common_head = common_head;
+	  }
+
       if (gfc_match_eos () == MATCH_YES)
 	break;
       if (gfc_match_char (',') != MATCH_YES)

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)
+    {
+      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,10 +3168,18 @@ read_module (void)
 
       info = get_integer (symbol);
 
-      /* Get the local name for this symbol.  */
-      p = find_use_name (name);
+      /* 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;
 
-      /* Skip symtree nodes not in an ONLY caluse.  */
+      for (j = 1; j <= nuse; j++)
+	{
+	  /* Get the jth local name for this symbol.  */
+	  p = find_use_name_n (name, &j);
+
+	  /* Skip symtree nodes not in an ONLY clause.  */
 	  if (p == NULL)
 	    continue;
 
@@ -3114,7 +3206,8 @@ read_module (void)
 	      if (sym == NULL)
 		{
 		  sym = info->u.rsym.sym =
-		gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
+		      gfc_new_symbol (info->u.rsym.true_name
+				      , gfc_current_ns);
 
 		  sym->module = gfc_get_string (info->u.rsym.module);
 		}
@@ -3130,6 +3223,7 @@ read_module (void)
 	      info->u.rsym.referenced = 1;
 	    }
 	}
+    }
 
   mio_rparen ();
 
@@ -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

gcc/fortran/primary.c

@@ -2173,10 +2173,15 @@ gfc_match_rvalue (gfc_expr ** result)
    starts as a symbol, can be a structure component or an array
    reference.  It can be a function if the function doesn't have a
    separate RESULT variable.  If the symbol has not been previously
-   seen, we assume it is a variable.  */
+   seen, we assume it is a variable.
 
-match
-gfc_match_variable (gfc_expr ** result, int equiv_flag)
+   This function is called by two interface functions:
+   gfc_match_variable, which has host_flag = 1, and
+   gfc_match_equiv_variable, with host_flag = 0, to restrict the
+   match of the symbol to the local scope.  */
+
+static match
+match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
 {
   gfc_symbol *sym;
   gfc_symtree *st;
@@ -2184,7 +2189,7 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag)
   locus where;
   match m;
 
-  m = gfc_match_sym_tree (&st, 1);
+  m = gfc_match_sym_tree (&st, host_flag);
   if (m != MATCH_YES)
     return m;
   where = gfc_current_locus;
@@ -2258,3 +2263,16 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag)
   *result = expr;
   return MATCH_YES;
 }
+
+match
+gfc_match_variable (gfc_expr ** result, int equiv_flag)
+{
+  return match_variable (result, equiv_flag, 1);
+}
+
+match
+gfc_match_equiv_variable (gfc_expr ** result)
+{
+  return match_variable (result, 1, 0);
+}
+

gcc/fortran/trans-common.c

@@ -119,8 +119,6 @@ typedef struct segment_info
 static segment_info * current_segment;
 static gfc_namespace *gfc_common_ns = NULL;
 
-#define BLANK_COMMON_NAME "__BLNK__"
-
 /* Make a segment_info based on a symbol.  */
 
 static segment_info *
@@ -665,46 +663,45 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
 
 
 /* Given a segment element, search through the equivalence lists for unused
-   conditions that involve the symbol.  Add these rules to the segment.  Only
-   checks for rules involving the first symbol in the equivalence set.  */
+   conditions that involve the symbol.  Add these rules to the segment.  */
 
 static bool
 find_equivalence (segment_info *n)
 {
-  gfc_equiv *e1, *e2, *eq, *other;
+  gfc_equiv *e1, *e2, *eq;
   bool found;
 
   found = FALSE;
+
   for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
     {
-      other = NULL;
-      for (e2 = e1->eq; e2; e2 = e2->eq)
-	{
-	  if (e2->used)
-	    continue;
+      eq = NULL;
 
-	  if (e1->expr->symtree->n.sym == n->sym)
+      /* Search the equivalence list, including the root (first) element
+         for the symbol that owns the segment.  */
+      for (e2 = e1; e2; e2 = e2->eq)
 	{
-	      eq = e1;
-	      other = e2;
-	    }
-	  else if (e2->expr->symtree->n.sym == n->sym)
+	  if (!e2->used && e2->expr->symtree->n.sym == n->sym)
 	    {
 	      eq = e2;
-	      other = e1;
+	      break;
+	    }
 	}
-	  else
-	    eq = NULL;
 
-	  if (eq)
-	    {
-	      add_condition (n, eq, other);
+      /* Go to the next root element.  */
+      if (eq == NULL)
+	continue;
+
       eq->used = 1;
+
+      /* Now traverse the equivalence list matching the offsets.  */
+      for (e2 = e1; e2; e2 = e2->eq)
+	{
+	  if (!e2->used && e2 != eq)
+	    {
+	      add_condition (n, eq, e2);
+	      e2->used = 1;
 	      found = TRUE;
-	      /* If this symbol is the first in the chain we may find other
-		 matches. Otherwise we can skip to the next equivalence.  */
-	      if (eq == e2)
-		break;
 	    }
 	}
     }
@@ -813,12 +810,14 @@ translate_common (gfc_common_head *common, gfc_symbol *var_list)
   /* Add symbols to the segment.  */
   for (sym = var_list; sym; sym = sym->common_next)
     {
-      if (sym->equiv_built)
-	{
-	  /* Symbol has already been added via an equivalence.  */
       current_segment = common_segment;
       s = find_segment_info (sym);
 
+      /* Symbol has already been added via an equivalence.  Multiple
+	 use associations of the same common block result in equiv_built
+	 being set but no information about the symbol in the segment.  */
+      if (s && sym->equiv_built)
+	{
 	  /* Ensure the current location is properly aligned.  */
 	  align = TYPE_ALIGN_UNIT (s->field);
 	  current_offset = (current_offset + align - 1) &~ (align - 1);
@@ -893,6 +892,7 @@ finish_equivalences (gfc_namespace *ns)
 {
   gfc_equiv *z, *y;
   gfc_symbol *sym;
+  gfc_common_head * c;
   HOST_WIDE_INT offset;
   unsigned HOST_WIDE_INT align;
   bool dummy;
@@ -916,8 +916,23 @@ finish_equivalences (gfc_namespace *ns)
 
 	apply_segment_offset (current_segment, offset);
 
-	/* Create the decl.  */
-        create_common (NULL, current_segment, true);
+	/* Create the decl. If this is a module equivalence, it has a unique
+	   name, pointed to by z->module. This is written to a gfc_common_header
+	   to push create_common into using build_common_decl, so that the
+	   equivalence appears as an external symbol. Otherwise, a local
+	   declaration is built using build_equiv_decl.*/
+	if (z->module)
+	  {
+	    c = gfc_get_common_head ();
+	    /* We've lost the real location, so use the location of the
+	     enclosing procedure.  */
+	    c->where = ns->proc_name->declared_at;
+	    strcpy (c->name, z->module);
+	  }
+	else
+	  c = NULL;
+
+        create_common (c, current_segment, true);
         break;
       }
 }

gcc/fortran/trans-decl.c

@@ -2160,6 +2160,10 @@ gfc_create_module_variable (gfc_symbol * sym)
   if (sym->attr.use_assoc || sym->attr.in_common)
     return;
 
+  /* Equivalenced variables arrive here after creation.  */
+  if (sym->backend_decl && sym->equiv_built)
+      return;
+
   if (sym->backend_decl)
     internal_error ("backend decl for module variable %s already exists",
 		    sym->name);
@@ -2336,8 +2340,6 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   gfc_start_block (&block);
 
-  gfc_generate_contained_functions (ns);
-
   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
     {
       /* Copy length backend_decls to all entry point result
@@ -2354,6 +2356,8 @@ gfc_generate_function_code (gfc_namespace * ns)
   /* Translate COMMON blocks.  */
   gfc_trans_common (ns);
 
+  gfc_generate_contained_functions (ns);
+
   generate_local_vars (ns);
 
   current_function_return_label = NULL;

gcc/testsuite/ChangeLog

+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.
+
 2005-09-08  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	PR fortran/23765

gcc/testsuite/gfortran.dg/common_equivalence_1.f

+c { dg-do run }
+c This program tests the fix for PR22304.
+c
+c provided by Paul Thomas - pault@gcc.gnu.org
+c
+      integer a(2), b, c
+      COMMON /foo/ a
+      EQUIVALENCE (a(1),b), (c, a(2))
+      a(1) = 101
+      a(2) = 102
+      call bar ()
+      END
+
+      subroutine bar ()
+      integer a(2), b, c, d
+      COMMON /foo/ a
+      EQUIVALENCE (a(1),b), (c, a(2))
+      if (b.ne.101) call abort ()
+      if (c.ne.102) call abort ()
+      END
+

gcc/testsuite/gfortran.dg/common_equivalence_2.f

+! { dg-do compile }
+! PR fortran/18870
+!
+      program main
+      common /foo/ a
+      common /bar/ b
+      equivalence (a,c)
+      equivalence (b,c) ! { dg-error "indirectly overlap COMMON" }
+      c=3.
+      print *,a
+      print *,b
+      end
+

gcc/testsuite/gfortran.dg/common_equivalence_3.f

+! { dg-do compile }
+! PR fortran/18870
+!
+      program main
+      equivalence (a,c)
+      equivalence (b,c)
+      common /foo/ a
+      common /bar/ b ! { dg-error "equivalenced to another COMMON" }
+      c=3.
+      print *,a
+      print *,b
+      end
+
+

gcc/testsuite/gfortran.dg/contained_equivalence_1.f90

+! { dg-do run }
+! This program tests that equivalence only associates variables in
+! the same scope.
+!
+! provided by Paul Thomas - pault@gcc.gnu.org
+!
+program contained_equiv
+  real a
+  a = 1.0
+  call foo ()
+  if (a.ne.1.0) call abort ()
+contains
+  subroutine foo ()
+    real b
+    equivalence (a, b)
+    b = 2.0
+  end subroutine foo
+end program contained_equiv

gcc/testsuite/gfortran.dg/module_blank_common.f90

+! { dg-do run }
+!
+! This tests that blank common works in modules. PR23270
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+module global
+  common a, b
+  real    a, b
+end module global
+program blank_common
+  use global
+  common z
+  complex z
+  a = 999.0_4
+  b = -999.0_4
+  if (z.ne.cmplx (a,b)) call abort ()
+end program blank_common
+
+

gcc/testsuite/gfortran.dg/module_commons_1.f90

+! { dg-do run }
+! This program tests that use associated common blocks work.
+!
+! provided by Paul Thomas - pault@gcc.gnu.org
+!
+module m1
+  common /x/ a
+end module m1
+module m2
+  common /x/ a
+end module m2
+
+subroutine foo ()
+  use m2
+  if (a.ne.99.0) call abort ()
+end subroutine foo
+
+program collision
+  use m1
+  use m2, only: b=>a
+  b = 99.0
+  call foo ()
+end program collision
+

gcc/testsuite/gfortran.dg/module_double_reuse.f90

+! Test of fix for PR18878
+!
+! Based on example in PR by Steve Kargl
+!
+module a
+  integer, parameter :: b = kind(1.d0)
+  real(b)            :: z
+end module a
+program d
+  use a, only : e => b, f => b, u => z, v => z
+  real(e) x
+  real(f) y
+  x = 1.e0_e
+  y = 1.e0_f
+  u = 99.0
+  if (kind(x).ne.kind(y)) call abort ()
+  if (v.ne.u) call abort ()
+end program d
+

gcc/testsuite/gfortran.dg/module_equivalence_1.f90

+! { dg-do run }
+! This tests the fix for PR17917, where equivalences were not being
+! written to and read back from modules.
+!
+! Contributed by Paul Thomas  pault@gcc.gnu.org
+!
+module test_equiv !Bug 17917
+  common /my_common/ d
+  real    a(2),b(4),c(4), d(8)
+  equivalence (a(1),b(2)), (c(1),d(5))
+end module test_equiv
+
+subroutine foo ()
+  use test_equiv, z=>b
+  if (any (d(5:8)/=z)) call abort ()
+end subroutine foo
+
+program module_equiv
+  use test_equiv
+  b = 99.0_4
+  a = 999.0_4
+  c = (/99.0_4, 999.0_4, 999.0_4, 99.0_4/)
+  call foo ()
+end program module_equiv
+
+

gcc/testsuite/gfortran.dg/nested_modules_1.f90

+! { dg-do run }
+!
+! This tests that common blocks function with multiply nested modules.
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+       module mod0
+         double complex FOO, KANGA
+         common /bar/ FOO, KANGA
+       contains
+         subroutine eyeore ()    
+           FOO = FOO + (1.0d0, 0.0d0)
+           KANGA = KANGA - (1.0d0, 0.0d0)
+         end subroutine eyeore
+       end module mod0
+       module mod1
+         use mod0
+         complex ROBIN
+         common/owl/ROBIN
+       end module mod1
+       module mod2
+         use mod0
+         use mod1
+         real*8 re1, im1, re2, im2, re, im
+         common /bar/ re1, im1, re2, im2
+         equivalence (re1, re), (im1, im)
+       contains
+         subroutine tigger (w)
+           double complex w
+           if (FOO.ne.(1.0d0, 1.0d0)) call abort ()
+           if (KANGA.ne.(-1.0d0, -1.0d0)) call abort ()
+           if (ROBIN.ne.(99.0d0, 99.0d0)) CALL abort ()
+           if (w.ne.cmplx(re,im)) call abort ()
+         end subroutine tigger
+       end module mod2
+
+       use mod2
+       use mod0, only: w=>foo
+       FOO = (0.0d0, 1.0d0)
+       KANGA = (0.0d0, -1.0d0)
+       ROBIN = (99.0d0, 99.0d0)
+       call eyeore ()
+       call tigger (w)
+       end