From f6eeace763a523ee312595c499eb36b681b217a2 Mon Sep 17 00:00:00 2001 From: pault Date: Tue, 20 Jan 2009 21:56:49 +0000 Subject: [PATCH] 2009-01-20 Paul Thomas 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 PR fortran/38907 * gfortran.dg/host_assoc_function_7.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@143530 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 7 ++ gcc/fortran/resolve.c | 90 ++++++++++++++-------- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/host_assoc_function_7.f90 | 41 ++++++++++ 4 files changed, 112 insertions(+), 31 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/host_assoc_function_7.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8a0235fc824..7c56c004cd6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2009-01-20 Paul Thomas + + 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 * invoke.texi (RANGE): RANGE also takes INTEGER arguments. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 3148b0de9ff..433f380868b 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 4754d1a2998..8b2d31da084 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-01-20 Paul Thomas + + PR fortran/38907 + * gfortran.dg/host_assoc_function_7.f90: New test + 2009-01-20 Andrew Pinski Richard Guenther 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 00000000000..15684438a9f --- /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 +! +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" } } -- 2.11.4.GIT