re PR fortran/38907 (ICE when contained function has same name as module function...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8a0235fc824d682abb45fd3dbd4d6f50bfbdbfc7..7c56c004cd6c760bcb968b03de3151f499ed2061 100644 (file)
--- 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 3148b0de9ff57e061bceb1d82d69159d4104dc7e..433f380868be49f3a37ab19c03aedbadd82ff2d1 100644 (file)
--- 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 4754d1a29983de2eb15e93c6625ad612353445e8..8b2d31da084412c3e32aa0d2f15677939d44e2ee 100644 (file)
--- 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 (file)
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" } }