PR25024, PR20881, PR23308, PR25538 and PR25710 - Procedure references

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

	PR fortran/25124
	PR fortran/25625
	* decl.c (get_proc_name): If there is an existing
	symbol in the encompassing namespace, call errors
	if it is a procedure of the same name or the kind
	field is set, indicating a type declaration.

	PR fortran/20881
	PR fortran/23308
	PR fortran/25538
	PR fortran/25710
	* decl.c (add_global_entry): New function to check
	for existing global symbol with this name and to
	create new one if none exists.
	(gfc_match_entry): Call add_global_entry before
	matching argument lists for subroutine and function
	entries.
	* gfortran.h: Prototype for existing function,
	global_used.
	* resolve.c (resolve_global_procedure): New function
	to check global symbols for procedures.
	(resolve_call, resolve_function): Calls to this
	new function for non-contained and non-module
	procedures.
	* match.c (match_common): Add check for existing
	global symbol, creat one if none exists and emit
	error if there is a clash.
	* parse.c (global_used): Remove static and use the
	gsymbol name rather than the new_block name, so that
	the function can be called from resolve.c.
	(parse_block_data, parse_module, add_global_procedure):
	Improve checks for existing gsymbols.  Emit error if
	already defined or if references were to another type.
	Set defined flag.

	PR fortran/PR24276
	* trans-expr.c (gfc_conv_aliased_arg): New function called by 
	gfc_conv_function_call that coverts an expression for an aliased
	component reference to a derived type array into a temporary array
	of the same type as the component.  The temporary is passed as an
	actual argument for the procedure call and is copied back to the
	derived type after the call.
	(is_aliased_array): New function that detects an array reference
	that is followed by a component reference.
	(gfc_conv_function_call): Detect an aliased actual argument with
	is_aliased_array and convert it to a temporary and back again
	using gfc_conv_aliased_arg.

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

	PR fortran/25124
	PR fortran/25625
	* gfortran.dg/internal_references_1.f90: New test.
	  PR fortran/20881
	PR fortran/23308
	PR fortran/25538
	PR fortran/25710
	* gfortran.dg/global_references_1.f90: New test.
	* gfortran.dg/g77/19990905-1.f: Restore the error that
	there is a clash between the common block name and
	the name of a subroutine reference.

	PR fortran/PR24276
	* gfortran.dg/aliasing_dummy_1.f90: New test.

From-SVN: r110063

gcc/fortran/ChangeLog

+2005-01-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25124
+	PR fortran/25625
+	* decl.c (get_proc_name): If there is an existing
+	symbol in the encompassing namespace, call errors
+	if it is a procedure of the same name or the kind
+	field is set, indicating a type declaration.
+
+	PR fortran/20881
+	PR fortran/23308
+	PR fortran/25538
+	PR fortran/25710
+	* decl.c (add_global_entry): New function to check
+	for existing global symbol with this name and to
+	create new one if none exists.
+	(gfc_match_entry): Call add_global_entry before
+	matching argument lists for subroutine and function
+	entries.
+	* gfortran.h: Prototype for existing function,
+	global_used.
+	* resolve.c (resolve_global_procedure): New function
+	to check global symbols for procedures.
+	(resolve_call, resolve_function): Calls to this
+	new function for non-contained and non-module
+	procedures.
+	* match.c (match_common): Add check for existing
+	global symbol, creat one if none exists and emit
+	error if there is a clash.
+	* parse.c (global_used): Remove static and use the
+	gsymbol name rather than the new_block name, so that
+	the function can be called from resolve.c.
+	(parse_block_data, parse_module, add_global_procedure):
+	Improve checks for existing gsymbols.  Emit error if
+	already defined or if references were to another type.
+	Set defined flag.
+
+	PR fortran/PR24276
+	* trans-expr.c (gfc_conv_aliased_arg): New function called by 
+	gfc_conv_function_call that coverts an expression for an aliased
+	component reference to a derived type array into a temporary array
+	of the same type as the component.  The temporary is passed as an
+	actual argument for the procedure call and is copied back to the
+	derived type after the call.
+	(is_aliased_array): New function that detects an array reference
+	that is followed by a component reference.
+	(gfc_conv_function_call): Detect an aliased actual argument with
+	is_aliased_array and convert it to a temporary and back again
+	using gfc_conv_aliased_arg.
+
 2006-01-19  Tobias Schlüter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* gfortranspec.c: Update copyright years.

gcc/fortran/decl.c

@@ -603,17 +603,38 @@ get_proc_name (const char *name, gfc_symbol ** result)
   int rc;
 
   if (gfc_current_ns->parent == NULL)
-    return gfc_get_symbol (name, NULL, result);
+    rc = gfc_get_symbol (name, NULL, result);
+  else
+    rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
 
-  rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
-  if (*result == NULL)
-    return rc;
+  sym = *result;
 
-  /* ??? Deal with ENTRY problem */
+  if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
+    {
+      /* Trap another encompassed procedure with the same name.  */
+      if (sym->attr.flavor != 0
+	    && sym->attr.proc != 0
+	    && (sym->attr.subroutine || sym->attr.function))
+	gfc_error_now ("Procedure '%s' at %C is already defined at %L",
+		       name, &sym->declared_at);
+
+      /* Trap declarations of attributes in encompassing scope.  The
+	 signature for this is that ts.kind is set.  Legitimate
+	 references only set ts.type.  */
+      if (sym->ts.kind != 0
+	    && sym->attr.proc == 0
+	    && gfc_current_ns->parent != NULL
+	    && sym->attr.access == 0)
+	gfc_error_now ("Procedure '%s' at %C has an explicit interface"
+		       " and must not have attributes declared at %L",
+		       name, &sym->declared_at);
+    }
+
+  if (gfc_current_ns->parent == NULL || *result == NULL)
+    return rc;
 
   st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
 
-  sym = *result;
   st->n.sym = sym;
   sym->refs++;
 
@@ -2606,6 +2627,29 @@ cleanup:
   return m;
 }
 
+/* This is mostly a copy of parse.c(add_global_procedure) but modified to pass the
+   name of the entry, rather than the gfc_current_block name, and to return false
+   upon finding an existing global entry.  */
+
+static bool
+add_global_entry (const char * name, int sub)
+{
+  gfc_gsymbol *s;
+
+  s = gfc_get_gsymbol(name);
+
+  if (s->defined
+	|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+    global_used(s, NULL);
+  else
+    {
+      s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+      s->where = gfc_current_locus;
+      s->defined = 1;
+      return true;
+    }
+  return false;
+}
 
 /* Match an ENTRY statement.  */
 
@@ -2697,6 +2741,9 @@ gfc_match_entry (void)
   if (state == COMP_SUBROUTINE)
     {
       /* An entry in a subroutine.  */
+      if (!add_global_entry (name, 1))
+	return MATCH_ERROR;
+
       m = gfc_match_formal_arglist (entry, 0, 1);
       if (m != MATCH_YES)
 	return MATCH_ERROR;
@@ -2716,6 +2763,9 @@ gfc_match_entry (void)
             ENTRY f() RESULT (r)
          can't be written as
             ENTRY f RESULT (r).  */
+      if (!add_global_entry (name, 0))
+	return MATCH_ERROR;
+
       old_loc = gfc_current_locus;
       if (gfc_match_eos () == MATCH_YES)
 	{

gcc/fortran/gfortran.h

@@ -1962,5 +1962,6 @@ void gfc_show_namespace (gfc_namespace *);
 
 /* parse.c */
 try gfc_parse_file (void);
+void global_used (gfc_gsymbol *, locus *);
 
 #endif /* GCC_GFORTRAN_H  */

gcc/fortran/match.c

@@ -2250,6 +2250,7 @@ gfc_match_common (void)
   gfc_array_spec *as;
   gfc_equiv * e1, * e2;
   match m;
+  gfc_gsymbol *gsym;
 
   old_blank_common = gfc_current_ns->blank_common.head;
   if (old_blank_common)
@@ -2266,6 +2267,23 @@ gfc_match_common (void)
       if (m == MATCH_ERROR)
 	goto cleanup;
 
+      gsym = gfc_get_gsymbol (name);
+      if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
+	{
+	  gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
+		     sym->name);
+	  goto cleanup;
+	}
+
+      if (gsym->type == GSYM_UNKNOWN)
+	{
+	  gsym->type = GSYM_COMMON;
+	  gsym->where = gfc_current_locus;
+	  gsym->defined = 1;
+	}
+
+      gsym->used = 1;
+
       if (name[0] == '\0')
 	{
 	  t = &gfc_current_ns->blank_common;

gcc/fortran/parse.c

 /* Main parser.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, 
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, 
    Inc.
    Contributed by Andy Vaught
 
@@ -2396,7 +2396,7 @@ done:
 /* Come here to complain about a global symbol already in use as
    something else.  */
 
-static void
+void
 global_used (gfc_gsymbol *sym, locus *where)
 {
   const char *name;
@@ -2430,7 +2430,7 @@ global_used (gfc_gsymbol *sym, locus *where)
     }
 
   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
-           gfc_new_block->name, where, name, &sym->where);
+	      sym->name, where, name, &sym->where);
 }
 
 
@@ -2461,12 +2461,13 @@ parse_block_data (void)
   else
     {
       s = gfc_get_gsymbol (gfc_new_block->name);
-      if (s->type != GSYM_UNKNOWN)
+      if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
        global_used(s, NULL);
       else
        {
          s->type = GSYM_BLOCK_DATA;
          s->where = gfc_current_locus;
+	 s->defined = 1;
        }
     }
 
@@ -2491,12 +2492,13 @@ parse_module (void)
   gfc_gsymbol *s;
 
   s = gfc_get_gsymbol (gfc_new_block->name);
-  if (s->type != GSYM_UNKNOWN)
+  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
     global_used(s, NULL);
   else
     {
       s->type = GSYM_MODULE;
       s->where = gfc_current_locus;
+      s->defined = 1;
     }
 
   st = parse_spec (ST_NONE);
@@ -2535,12 +2537,14 @@ add_global_procedure (int sub)
 
   s = gfc_get_gsymbol(gfc_new_block->name);
 
-  if (s->type != GSYM_UNKNOWN)
+  if (s->defined
+	|| (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
     global_used(s, NULL);
   else
     {
       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
       s->where = gfc_current_locus;
+      s->defined = 1;
     }
 }
 
@@ -2556,12 +2560,13 @@ add_global_program (void)
     return;
   s = gfc_get_gsymbol (gfc_new_block->name);
 
-  if (s->type != GSYM_UNKNOWN)
+  if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
     global_used(s, NULL);
   else
     {
       s->type = GSYM_PROGRAM;
       s->where = gfc_current_locus;
+      s->defined = 1;
     }
 }
 

gcc/fortran/resolve.c

@@ -885,6 +885,36 @@ find_noncopying_intrinsics (gfc_symbol * fnsym, gfc_actual_arglist * actual)
       ap->expr->inline_noncopying_intrinsic = 1;
 }
 
+/* This function does the checking of references to global procedures
+   as defined in sections 18.1 and 14.1, respectively, of the Fortran
+   77 and 95 standards.  It checks for a gsymbol for the name, making
+   one if it does not already exist.  If it already exists, then the
+   reference being resolved must correspond to the type of gsymbol.
+   Otherwise, the new symbol is equipped with the attributes of the 
+   reference.  The corresponding code that is called in creating
+   global entities is parse.c.  */
+
+static void
+resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
+{
+  gfc_gsymbol * gsym;
+  uint type;
+
+  type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+
+  gsym = gfc_get_gsymbol (sym->name);
+
+  if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
+    global_used (gsym, where);
+
+  if (gsym->type == GSYM_UNKNOWN)
+    {
+      gsym->type = type;
+      gsym->where = *where;
+    }
+
+  gsym->used = 1;
+}
 
 /************* Function resolution *************/
 
@@ -1157,6 +1187,14 @@ resolve_function (gfc_expr * expr)
   try t;
   int temp;
 
+  /* If the procedure is not internal or module, it must be external and
+     should be checked for usage.  */
+  if (expr->symtree && expr->symtree->n.sym
+	&& !expr->symtree->n.sym->attr.dummy
+	&& !expr->symtree->n.sym->attr.contained
+	&& !expr->symtree->n.sym->attr.use_assoc)
+    resolve_global_procedure (expr->symtree->n.sym, &expr->where, 0);
+
   /* Switch off assumed size checking and do this again for certain kinds
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
@@ -1511,6 +1549,14 @@ resolve_call (gfc_code * c)
 {
   try t;
 
+  /* If the procedure is not internal or module, it must be external and
+     should be checked for usage.  */
+  if (c->symtree && c->symtree->n.sym
+	&& !c->symtree->n.sym->attr.dummy
+	&& !c->symtree->n.sym->attr.contained
+	&& !c->symtree->n.sym->attr.use_assoc)
+    resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
+
   /* Switch off assumed size checking and do this again for certain kinds
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
@@ -4805,6 +4851,18 @@ resolve_symbol (gfc_symbol * sym)
 	}
       break;
 
+    case FL_PROCEDURE:
+      /* An external symbol may not have an intializer because it is taken to be
+	 a procedure.  */
+      if (sym->attr.external && sym->value)
+	{
+	  gfc_error ("External object '%s' at %L may not have an initializer",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+
+      break;
+
     case FL_DERIVED:
       /* Add derived type to the derived type list.  */
       {
@@ -4818,14 +4876,6 @@ resolve_symbol (gfc_symbol * sym)
 
     default:
 
-      /* An external symbol falls through to here if it is not referenced.  */
-      if (sym->attr.external && sym->value)
-	{
-	  gfc_error ("External object '%s' at %L may not have an initializer",
-		     sym->name, &sym->declared_at);
-	  return;
-	}
-
       break;
     }
 

gcc/fortran/trans-expr.c

@@ -1529,6 +1529,226 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
   gfc_free_expr (expr);
 }
 
+/* Returns a reference to a temporary array into which a component of
+   an actual argument derived type array is copied and then returned
+   after the function call.
+   TODO Get rid of this kludge, when array descriptors are capable of
+   handling aliased arrays.  */
+
+static void
+gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77)
+{
+  gfc_se lse;
+  gfc_se rse;
+  gfc_ss *lss;
+  gfc_ss *rss;
+  gfc_loopinfo loop;
+  gfc_loopinfo loop2;
+  gfc_ss_info *info;
+  tree offset;
+  tree tmp_index;
+  tree tmp;
+  tree base_type;
+  stmtblock_t body;
+  int n;
+
+  gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the argument expression.  */
+  rss = gfc_walk_expr (expr);
+
+  gcc_assert (rss != gfc_ss_terminator);
+ 
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop);
+  gfc_add_ss_to_loop (&loop, rss);
+
+  /* Calculate the bounds of the scalarization.  */
+  gfc_conv_ss_startstride (&loop);
+
+  /* Build an ss for the temporary.  */
+  base_type = gfc_typenode_for_spec (&expr->ts);
+  if (GFC_ARRAY_TYPE_P (base_type)
+		|| GFC_DESCRIPTOR_TYPE_P (base_type))
+    base_type = gfc_get_element_type (base_type);
+
+  loop.temp_ss = gfc_get_ss ();;
+  loop.temp_ss->type = GFC_SS_TEMP;
+  loop.temp_ss->data.temp.type = base_type;
+
+  if (expr->ts.type == BT_CHARACTER)
+    loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+
+  loop.temp_ss->data.temp.dimen = loop.dimen;
+  loop.temp_ss->next = gfc_ss_terminator;
+
+  /* Associate the SS with the loop.  */
+  gfc_add_ss_to_loop (&loop, loop.temp_ss);
+
+  /* Setup the scalarizing loops.  */
+  gfc_conv_loop_setup (&loop);
+
+  /* Pass the temporary descriptor back to the caller.  */
+  info = &loop.temp_ss->data.info;
+  parmse->expr = info->descriptor;
+
+  /* Setup the gfc_se structures.  */
+  gfc_copy_loopinfo_to_se (&lse, &loop);
+  gfc_copy_loopinfo_to_se (&rse, &loop);
+
+  rse.ss = rss;
+  lse.ss = loop.temp_ss;
+  gfc_mark_ss_chain_used (rss, 1);
+  gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+  /* Start the scalarized loop body.  */
+  gfc_start_scalarized_body (&loop, &body);
+
+  /* Translate the expression.  */
+  gfc_conv_expr (&rse, expr);
+
+  gfc_conv_tmp_array_ref (&lse);
+  gfc_advance_se_ss_chain (&lse);
+
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+  gfc_add_expr_to_block (&body, tmp);
+
+  gcc_assert (rse.ss == gfc_ss_terminator);
+
+  gfc_trans_scalarizing_loops (&loop, &body);
+
+  /* Add the post block after the second loop, so that any
+     freeing of allocated memory is done at the right time.  */
+  gfc_add_block_to_block (&parmse->pre, &loop.pre);
+
+  /**********Copy the temporary back again.*********/
+
+  gfc_init_se (&lse, NULL);
+  gfc_init_se (&rse, NULL);
+
+  /* Walk the argument expression.  */
+  lss = gfc_walk_expr (expr);
+  rse.ss = loop.temp_ss;
+  lse.ss = lss;
+
+  /* Initialize the scalarizer.  */
+  gfc_init_loopinfo (&loop2);
+  gfc_add_ss_to_loop (&loop2, lss);
+
+  /* Calculate the bounds of the scalarization.  */
+  gfc_conv_ss_startstride (&loop2);
+
+  /* Setup the scalarizing loops.  */
+  gfc_conv_loop_setup (&loop2);
+
+  gfc_copy_loopinfo_to_se (&lse, &loop2);
+  gfc_copy_loopinfo_to_se (&rse, &loop2);
+
+  gfc_mark_ss_chain_used (lss, 1);
+  gfc_mark_ss_chain_used (loop.temp_ss, 1);
+
+  /* Declare the variable to hold the temporary offset and start the
+     scalarized loop body.  */
+  offset = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_start_scalarized_body (&loop2, &body);
+
+  /* Build the offsets for the temporary from the loop variables.  The
+     temporary array has lbounds of zero and strides of one in all
+     dimensions, so this is very simple.  The offset is only computed
+     outside the innermost loop, so the overall transfer could be
+     optimised further.  */
+  info = &rse.ss->data.info;
+
+  tmp_index = gfc_index_zero_node;
+  for (n = info->dimen - 1; n > 0; n--)
+    {
+      tree tmp_str;
+      tmp = rse.loop->loopvar[n];
+      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			 tmp, rse.loop->from[n]);
+      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			 tmp, tmp_index);
+
+      tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+			     rse.loop->to[n-1], rse.loop->from[n-1]);
+      tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			     tmp_str, gfc_index_one_node);
+
+      tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
+			       tmp, tmp_str);
+    }
+
+  tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+  			   tmp_index, rse.loop->from[0]);
+  gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
+
+  tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+			   rse.loop->loopvar[0], offset);
+
+  /* Now use the offset for the reference.  */
+  tmp = build_fold_indirect_ref (info->data);
+  rse.expr = gfc_build_array_ref (tmp, tmp_index);
+
+  if (expr->ts.type == BT_CHARACTER)
+    rse.string_length = expr->ts.cl->backend_decl;
+
+  gfc_conv_expr (&lse, expr);
+
+  gcc_assert (lse.ss == gfc_ss_terminator);
+
+  tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
+  gfc_add_expr_to_block (&body, tmp);
+  
+  /* Generate the copying loops.  */
+  gfc_trans_scalarizing_loops (&loop2, &body);
+
+  /* Wrap the whole thing up by adding the second loop to the post-block
+     and following it by the post-block of the fist loop.  In this way,
+     if the temporary needs freeing, it is done after use!  */
+  gfc_add_block_to_block (&parmse->post, &loop2.pre);
+  gfc_add_block_to_block (&parmse->post, &loop2.post);
+
+  gfc_add_block_to_block (&parmse->post, &loop.post);
+
+  gfc_cleanup_loop (&loop);
+  gfc_cleanup_loop (&loop2);
+
+  /* Pass the string length to the argument expression.  */
+  if (expr->ts.type == BT_CHARACTER)
+    parmse->string_length = expr->ts.cl->backend_decl;
+
+  /* We want either the address for the data or the address of the descriptor,
+     depending on the mode of passing array arguments.  */
+  if (g77)
+    parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
+  else
+    parmse->expr = build_fold_addr_expr (parmse->expr);
+
+  return;
+}
+
+/* Is true if the last array reference is followed by a component reference.  */
+
+static bool
+is_aliased_array (gfc_expr * e)
+{
+  gfc_ref * ref;
+  bool seen_array;
+
+  seen_array = false;	
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_ARRAY)
+	seen_array = true;
+
+      if (ref->next == NULL && ref->type == REF_COMPONENT)
+	return seen_array;
+    }
+  return false;
+}
 
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
@@ -1655,7 +1875,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		  && !formal->sym->attr.pointer
 		  && formal->sym->as->type != AS_ASSUMED_SHAPE;
 	      f = f || !sym->attr.always_explicit;
-	      gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+	      if (arg->expr->expr_type == EXPR_VARIABLE
+		    && is_aliased_array (arg->expr))
+		/* The actual argument is a component reference to an
+		   array of derived types.  In this case, the argument
+		   is converted to a temporary, which is passed and then
+		   written back after the procedure call.  */
+		gfc_conv_aliased_arg (&parmse, arg->expr, f);
+	      else
+	        gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
 	    } 
 	}
 

gcc/testsuite/ChangeLog

+2005-01-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/25124
+	PR fortran/25625
+	* gfortran.dg/internal_references_1.f90: New test.
+	  PR fortran/20881
+	PR fortran/23308
+	PR fortran/25538
+	PR fortran/25710
+	* gfortran.dg/global_references_1.f90: New test.
+	* gfortran.dg/g77/19990905-1.f: Restore the error that
+	there is a clash between the common block name and
+	the name of a subroutine reference.
+
+	PR fortran/PR24276
+	* gfortran.dg/aliasing_dummy_1.f90: New test.
+
 2006-01-21  Alan Modra  <amodra@bigpond.net.au>
 
 	* gcc.dg/vmx/1b-01.c: Warning fix.

gcc/testsuite/gfortran.dg/aliasing_dummy_1.f90

+! { dg-do run }
+! This tests the fix for PR24276, which originated from the Loren P. Meissner example,
+! Array_List.  The PR concerns dummy argument aliassing of components of arrays of derived
+! types as arrays of the type of the component.  gfortran would compile and run this
+! example but the stride used did not match the actual argument.  This test case exercises
+! a procedure call (to foo2, below) that is identical to Array_List's.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+
+program test_lex
+  type :: dtype
+    integer :: n
+    character*5 :: word
+  end type dtype
+
+  type :: list
+    type(dtype), dimension(4) :: list
+    integer :: l = 4
+  end type list
+ 
+  type(list) :: table
+  type(dtype) :: elist(2,2)
+
+  table%list = (/dtype (1 , "one  "), dtype (2 , "two  "), dtype (3 , "three"), dtype (4 , "four ")/)
+
+! Test 1D with assumed shape (original bug) and assumed size.
+  call bar (table, 2, 4)
+  if (any (table%list%word.ne.(/"one  ","i=  2","three","i=  4"/))) call abort ()
+
+  elist = reshape (table%list, (/2,2/))
+
+! Check 2D is OK with assumed shape and assumed size.
+  call foo3 (elist%word, 1)
+  call foo1 (elist%word, 3)
+  if (any (elist%word.ne.reshape ((/"i=  1","i=  2","i=  3","i=  4"/), (/2,2/)))) call abort ()
+
+contains
+
+  subroutine bar (table, n, m)
+    type(list) :: table
+    integer n, m
+    call foo1 (table%list(:table%l)%word, n)
+    call foo2 (table%list(:table%l)%word, m)
+  end subroutine bar
+
+  subroutine foo1 (slist, i)
+    character(*), dimension(*) :: slist
+    integer i
+    write (slist(i), '(2hi=,i3)') i
+  end subroutine foo1
+
+  subroutine foo2 (slist, i)
+    character(5), dimension(:) :: slist
+    integer i
+    write (slist(i), '(2hi=,i3)') i
+  end subroutine foo2
+
+  subroutine foo3 (slist, i)
+    character(5), dimension(:,:) :: slist
+    integer i
+    write (slist(1,1), '(2hi=,i3)') i
+  end subroutine foo3
+
+end program test_lex
\ No newline at end of file

gcc/testsuite/gfortran.dg/g77/19990905-1.f

@@ -12,8 +12,8 @@ c  Invalid declaration of or reference to symbol `foo' at (2) [initially seen at
 * =foo7.f in Burley's g77 test suite.
       subroutine x
       real a(n)
-      common /foo/n
+      common /foo/n  ! { dg-error "is already being used as a COMMON" }
       continue
       entry y(a)
-      call foo(a(1))
+      call foo(a(1)) ! { dg-error "is already being used as a COMMON" }
       end

gcc/testsuite/gfortran.dg/global_references_1.f90

+! { dg-do compile }
+! This program tests the patch for PRs 20881, 23308, 25538 & 25710
+! Assembled from PRs by Paul Thomas  <pault@gcc.gnu.org>
+module m
+contains
+  subroutine g(x)   ! Local entity
+    REAL :: x
+    x = 1.0
+  end subroutine g
+end module m
+! Error only appears once but testsuite associates with both lines.
+function f(x)       ! { dg-error "is already being used as a FUNCTION" }
+  REAL :: f, x
+  f = x
+end function f
+
+function g(x)       ! Global entity
+  REAL :: g, x
+  g = x
+
+! PR25710==========================================================
+! Lahey -2607-S: "SOURCE.F90", line 26: 
+! Function 'f' cannot be referenced as a subroutine. The previous
+! definition is in 'line 12'.
+
+  call f(g) ! { dg-error "is already being used as a FUNCTION" }
+end function g
+! Error only appears once but testsuite associates with both lines.
+function h(x)       ! { dg-error "is already being used as a FUNCTION" }
+  REAL :: h, x
+  h = x
+end function h
+
+SUBROUTINE TT()
+  CHARACTER(LEN=10), EXTERNAL :: j
+  CHARACTER(LEN=10)          :: T
+! PR20881=========================================================== 
+! Error only appears once but testsuite associates with both lines.
+  T = j () ! { dg-error "is already being used as a FUNCTION" }
+  print *, T
+END SUBROUTINE TT
+
+  use m             ! Main program
+  real x
+  integer a(10)
+
+! PR23308===========================================================
+! Lahey - 2604-S: "SOURCE.F90", line 52:
+! The name 'foo' cannot be specified as both external procedure name
+! and common block name. The previous appearance is in 'line 68'.
+! Error only appears once but testsuite associates with both lines.
+  common /foo/ a    ! { dg-error "is already being used as a COMMON" }
+
+  call f (x)        ! OK - reference to local entity
+  call g (x)        !             -ditto-
+
+! PR25710===========================================================
+! Lahey - 2607-S: "SOURCE.F90", line 62:
+! Function 'h' cannot be referenced as a subroutine. The previous
+! definition is in 'line 29'.
+
+  call h (x) ! { dg-error "is already being used as a FUNCTION" }
+
+! PR23308===========================================================
+! Lahey - 2521-S: "SOURCE.F90", line 68: Intrinsic procedure name or
+! external procedure name same as common block name 'foo'.
+
+  call foo () ! { dg-error "is already being used as a COMMON" }
+
+contains
+  SUBROUTINE f (x)  ! Local entity
+    real x
+    x = 2
+  end SUBROUTINE f
+end
+
+! PR20881=========================================================== 
+! Lahey - 2636-S: "SOURCE.F90", line 81:
+! Subroutine 'j' is previously referenced as a function in 'line 39'.
+
+SUBROUTINE j (x)    ! { dg-error "is already being used as a FUNCTION" }
+  integer a(10)
+  common /bar/ a    ! Global entity foo
+  real x
+  x = bar(1.0)      ! OK for local procedure to have common block name
+contains
+  function bar (x)
+    real bar, x
+    bar = 2.0*x
+  end function bar
+END SUBROUTINE j
+
+! PR25538===========================================================
+! would ICE with entry and procedure having same names.
+  subroutine link2 (namef) ! { dg-error "is already being used as a SUBROUTINE" }
+    entry link2 (nameg)    ! { dg-error "is already being used as a SUBROUTINE" }
+    return
+  end

gcc/testsuite/gfortran.dg/internal_references_1.f90

+! { dg-do compile }
+! This tests the patch for PRs 24327, 25024 & 25625, which
+! are all connected with references to internal procedures.
+! This is a composite of the PR testcases; and each is
+! labelled by PR.
+!
+! Contributed by Paul Thomas  <pault@gcc.gnu.org>
+!
+! PR25625 - would neglect to point out that there were 2 subroutines p.
+module m
+  implicit none
+contains
+
+  subroutine p (i)   ! { dg-error "is already defined" }
+    integer :: i
+  end subroutine
+
+  subroutine p (i)   ! { dg-error "is already defined" }
+   integer :: i
+  end subroutine
+end module
+!
+! PR25124 - would happily ignore the declaration of foo in the main program.
+program test
+real :: foo, x      ! { dg-error "explicit interface and must not have attributes declared" }
+x = bar ()          ! This is OK because it is a regular reference.
+x = foo ()
+contains
+    function foo () ! { dg-error "explicit interface and must not have attributes declared" }
+      foo = 1.0
+    end function foo
+    function bar ()
+      bar = 1.0
+    end function bar
+end program test
+