Commit 5b3b1d09 by Paul Thomas

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

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
parent 53f506ed
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> 2009-01-20 Tobias Burnus <burnus@net-b.de>
* invoke.texi (RANGE): RANGE also takes INTEGER arguments. * invoke.texi (RANGE): RANGE also takes INTEGER arguments.
......
...@@ -4289,15 +4289,17 @@ resolve_procedure: ...@@ -4289,15 +4289,17 @@ resolve_procedure:
/* Checks to see that the correct symbol has been host associated. /* Checks to see that the correct symbol has been host associated.
The only situation where this arises is that in which a twice The only situation where this arises is that in which a twice
contained function is parsed after the host association is made. contained function is parsed after the host association is made.
Therefore, on detecting this, the line is rematched, having got Therefore, on detecting this, change the symbol in the expression
rid of the existing references and actual_arg_list. */ and convert the array reference into an actual arglist if the old
symbol is a variable. */
static bool static bool
check_host_association (gfc_expr *e) check_host_association (gfc_expr *e)
{ {
gfc_symbol *sym, *old_sym; gfc_symbol *sym, *old_sym;
locus temp_locus; gfc_symtree *st;
gfc_expr *expr;
int n; int n;
gfc_ref *ref;
gfc_actual_arglist *arg, *tail;
bool retval = e->expr_type == EXPR_FUNCTION; bool retval = e->expr_type == EXPR_FUNCTION;
/* If the expression is the result of substitution in /* If the expression is the result of substitution in
...@@ -4313,26 +4315,16 @@ check_host_association (gfc_expr *e) ...@@ -4313,26 +4315,16 @@ check_host_association (gfc_expr *e)
if (gfc_current_ns->parent if (gfc_current_ns->parent
&& old_sym->ns != gfc_current_ns) && 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); gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym);
if (sym && old_sym != sym if (sym && old_sym != sym
&& sym->ts.type == old_sym->ts.type && sym->ts.type == old_sym->ts.type
&& sym->attr.flavor == FL_PROCEDURE && sym->attr.flavor == FL_PROCEDURE
&& sym->attr.contained) && sym->attr.contained)
{ {
temp_locus = gfc_current_locus; /* Clear the shape, since it might not be valid. */
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;
}
if (e->shape != NULL) if (e->shape != NULL)
{ {
for (n = 0; n < e->rank; n++) for (n = 0; n < e->rank; n++)
...@@ -4341,22 +4333,58 @@ check_host_association (gfc_expr *e) ...@@ -4341,22 +4333,58 @@ check_host_association (gfc_expr *e)
gfc_free (e->shape); gfc_free (e->shape);
} }
/* TODO - Replace this gfc_match_rvalue with a straight replacement of /* Give the symbol a symtree in the right place! */
actual arglists for function to function substitutions and with a gfc_get_sym_tree (sym->name, gfc_current_ns, &st);
conversion of the reference list to an actual arglist in the case of st->n.sym = sym;
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);
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; /* Ambiguity will not arise if the array reference is not
gfc_free (expr); the last reference. */
sym->refs++; 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! */ /* This might have changed! */
......
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> 2009-01-20 Andrew Pinski <andrew_pinski@playstation.sony.com>
Richard Guenther <rguenther@suse.de> Richard Guenther <rguenther@suse.de>
......
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment