re PR fortran/38907 (ICE when contained function has same name as module function and used in expression)

2009-01-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/38907
	* resolve.c (check_host_association): Remove the matching to
	correct an incorrect host association and use manipulation of
	the expression instead.

2009-01-20  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/38907
	* gfortran.dg/host_assoc_function_7.f90: New test.

From-SVN: r143530

4 files changed, 112 insertions, 31 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8a0235f..7c56c00 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2009-01-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38907
+	* resolve.c (check_host_association): Remove the matching to
+	correct an incorrect host association and use manipulation of
+	the expression instead.
+
 2009-01-20  Tobias Burnus  <burnus@net-b.de>
 
 	* invoke.texi (RANGE): RANGE also takes INTEGER arguments.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3148b0d..433f380 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4289,15 +4289,17 @@ resolve_procedure:
 /* Checks to see that the correct symbol has been host associated.
    The only situation where this arises is that in which a twice
    contained function is parsed after the host association is made.
-   Therefore, on detecting this, the line is rematched, having got
-   rid of the existing references and actual_arg_list.  */
+   Therefore, on detecting this, change the symbol in the expression
+   and convert the array reference into an actual arglist if the old
+   symbol is a variable.  */
 static bool
 check_host_association (gfc_expr *e)
 {
   gfc_symbol *sym, *old_sym;
-  locus temp_locus;
-  gfc_expr *expr;
+  gfc_symtree *st;
   int n;
+  gfc_ref *ref;
+  gfc_actual_arglist *arg, *tail;
   bool retval = e->expr_type == EXPR_FUNCTION;
 
   /*  If the expression is the result of substitution in
@@ -4313,26 +4315,16 @@ check_host_association (gfc_expr *e)
   if (gfc_current_ns->parent
 	&& old_sym->ns != gfc_current_ns)
     {
+      /* Use the 'USE' name so that renamed module symbols are
+	 correctly handled.  */
       gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
+
       if (sym && old_sym != sym
 	      && sym->ts.type == old_sym->ts.type
 	      && sym->attr.flavor == FL_PROCEDURE
 	      && sym->attr.contained)
 	{
-	  temp_locus = gfc_current_locus;
-	  gfc_current_locus = e->where;
-
-	  gfc_buffer_error (1);
-
-	  gfc_free_ref_list (e->ref);
-	  e->ref = NULL;
-
-	  if (retval)
-	    {
-	      gfc_free_actual_arglist (e->value.function.actual);
-	      e->value.function.actual = NULL;
-	    }
-
+	  /* Clear the shape, since it might not be valid.  */
 	  if (e->shape != NULL)
 	    {
 	      for (n = 0; n < e->rank; n++)
@@ -4341,22 +4333,58 @@ check_host_association (gfc_expr *e)
 	      gfc_free (e->shape);
 	    }
 
-/* TODO - Replace this gfc_match_rvalue with a straight replacement of
-   actual arglists for function to function substitutions and with a
-   conversion of the reference list to an actual arglist in the case of
-   a variable to function replacement.  This should be quite easy since
-   only integers and vectors can be involved.  */	    
-	  gfc_match_rvalue (&expr);
-	  gfc_clear_error ();
-	  gfc_buffer_error (0);
+	  /* Give the symbol a symtree in the right place!  */
+	  gfc_get_sym_tree (sym->name, gfc_current_ns, &st);
+	  st->n.sym = sym;
 
-	  gcc_assert (expr && sym == expr->symtree->n.sym);
+	  if (old_sym->attr.flavor == FL_PROCEDURE)
+	    {
+	      /* Original was function so point to the new symbol, since
+		 the actual argument list is already attached to the
+		 expression. */
+	      e->value.function.esym = NULL;
+	      e->symtree = st;
+	    }
+	  else
+	    {
+	      /* Original was variable so convert array references into
+		 an actual arglist. This does not need any checking now
+		 since gfc_resolve_function will take care of it.  */
+	      e->value.function.actual = NULL;
+	      e->expr_type = EXPR_FUNCTION;
+	      e->symtree = st;
 
-	  *e = *expr;
-	  gfc_free (expr);
-	  sym->refs++;
+	      /* Ambiguity will not arise if the array reference is not
+		 the last reference.  */
+	      for (ref = e->ref; ref; ref = ref->next)
+		if (ref->type == REF_ARRAY && ref->next == NULL)
+		  break;
 
-	  gfc_current_locus = temp_locus;
+	      gcc_assert (ref->type == REF_ARRAY);
+
+	      /* Grab the start expressions from the array ref and
+		 copy them into actual arguments.  */
+	      for (n = 0; n < ref->u.ar.dimen; n++)
+		{
+		  arg = gfc_get_actual_arglist ();
+		  arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
+		  if (e->value.function.actual == NULL)
+		    tail = e->value.function.actual = arg;
+	          else
+		    {
+		      tail->next = arg;
+		      tail = arg;
+		    }
+		}
+
+	      /* Dump the reference list and set the rank.  */
+	      gfc_free_ref_list (e->ref);
+	      e->ref = NULL;
+	      e->rank = sym->as ? sym->as->rank : 0;
+	    }
+
+	  gfc_resolve_expr (e);
+	  sym->refs++;
 	}
     }
   /* This might have changed!  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4754d1a..8b2d31d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-01-20  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/38907
+	* gfortran.dg/host_assoc_function_7.f90: New test
+
 2009-01-20  Andrew Pinski  <andrew_pinski@playstation.sony.com>
 	Richard Guenther  <rguenther@suse.de>
 
diff --git a/gcc/testsuite/gfortran.dg/host_assoc_function_7.f90 b/gcc/testsuite/gfortran.dg/host_assoc_function_7.f90
new file mode 100644
index 0000000..1568443
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/host_assoc_function_7.f90
@@ -0,0 +1,41 @@
+! { dg-do run }
+! Tests the fix for PR38907, in which any expressions, including unary plus,
+! in front of the call to S_REAL_SUM_I (marked) would throw the mechanism
+! for correcting invalid host association.
+!
+! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+!
+module sa0054_stuff
+  REAL :: S_REAL_SUM_2(10) = [(REAL (I), I = 1, 10)]
+contains
+  ELEMENTAL FUNCTION S_REAL_SUM_I (A)
+    REAL  ::  S_REAL_SUM_I
+    REAL, INTENT(IN)  ::  A
+    X = 1.0
+    S_REAL_SUM_I = X
+  END FUNCTION S_REAL_SUM_I
+  SUBROUTINE SA0054 (RDA)
+    REAL RDA(:)
+    RDA =  + S_REAL_SUM_I (RDA)          ! Reported problem => ICE
+    RDA = RDA + S_REAL_SUM_2 (INT (RDA)) ! Also failed
+  CONTAINS
+    ELEMENTAL FUNCTION S_REAL_SUM_I (A)
+      REAL  ::  S_REAL_SUM_I
+      REAL, INTENT(IN)  ::  A
+      S_REAL_SUM_I = 2.0 * A
+    END FUNCTION S_REAL_SUM_I
+    ELEMENTAL FUNCTION S_REAL_SUM_2 (A)
+      REAL  ::  S_REAL_SUM_2
+      INTEGER, INTENT(IN)  ::  A
+      S_REAL_SUM_2 = 2.0 * A
+    END FUNCTION S_REAL_SUM_2
+  END SUBROUTINE
+end module sa0054_stuff
+
+  use sa0054_stuff
+  REAL :: RDA(10) = [(REAL(I), I = 1, 10)]
+  call SA0054 (RDA)
+  IF (ANY (INT (RDA) .ne. [(6 * I, I = 1, 10)])) print *, rda
+END
+
+! { dg-final { cleanup-modules "sa0054_stuff" } }