From 6a661315c2e9581727c969320d335da82dbd4829 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 24 Mar 2007 12:30:58 +0000 Subject: [PATCH] re PR fortran/31215 (ICE on valid code with gfortran) 2007-03-24 Paul Thomas PR fortran/31215 * trans-expr.c (gfc_apply_interface_mapping_to_expr): Return int result that is non-zero if the expression is the function result. Only the characteristics of the result expression can be used in a procedure interface, so simplify LEN in situ using its character length. PR fortran/31219 PR fortran/31200 * trans-expr.c (gfc_conv_function_call): Do not use gfc_conv_expr_reference for actual pointer function with formal target because a temporary is created that does not transfer the reference correctly. Do not indirect formal pointer functions since it is the function reference that is needed. 2007-03-24 Paul Thomas PR fortran/31219 * gfortran.dg/pointer_function_actual_1.f90: New test. PR fortran/31200 * gfortran.dg/pointer_function_actual_2.f90: New test. PR fortran/31215 * gfortran.dg/result_in_spec_1.f90: New test. From-SVN: r123183 --- gcc/fortran/ChangeLog | 17 ++++++ gcc/fortran/trans-expr.c | 35 +++++++++++-- gcc/testsuite/ChangeLog | 11 ++++ .../gfortran.dg/pointer_function_actual_1.f90 | 51 ++++++++++++++++++ .../gfortran.dg/pointer_function_actual_2.f90 | 22 ++++++++ .../gfortran.dg/result_in_spec_1.f90 | 52 +++++++++++++++++++ 6 files changed, 184 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_function_actual_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_function_actual_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/result_in_spec_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 645a5293099..ee5faa74215 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2007-03-24 Paul Thomas + + PR fortran/31215 + * trans-expr.c (gfc_apply_interface_mapping_to_expr): Return + int result that is non-zero if the expression is the function + result. Only the characteristics of the result expression + can be used in a procedure interface, so simplify LEN in situ + using its character length. + + PR fortran/31219 + PR fortran/31200 + * trans-expr.c (gfc_conv_function_call): Do not use + gfc_conv_expr_reference for actual pointer function with formal + target because a temporary is created that does not transfer + the reference correctly. Do not indirect formal pointer + functions since it is the function reference that is needed. + 2007-03-24 Brooks Moses * gfortran.h: Edit comments on GFC_STD_*. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a6920db500e..036d55bdd28 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -43,7 +43,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "dependency.h" static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); -static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, +static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); /* Copy the scalarization loop variables. */ @@ -1601,15 +1601,16 @@ gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping, dummy arguments that MAPPING maps to actual arguments. Replace each such reference with a reference to the associated actual argument. */ -static void +static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, gfc_expr * expr) { gfc_interface_sym_mapping *sym; gfc_actual_arglist *actual; + int seen_result = 0; if (!expr) - return; + return 0; /* Copying an expression does not copy its length, so do that here. */ if (expr->ts.type == BT_CHARACTER && expr->ts.cl) @@ -1631,6 +1632,8 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, switch (expr->expr_type) { case EXPR_VARIABLE: + if (expr->symtree->n.sym->attr.result) + seen_result = 1; case EXPR_CONSTANT: case EXPR_NULL: case EXPR_SUBSTRING: @@ -1642,6 +1645,21 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, break; case EXPR_FUNCTION: + if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE + && gfc_apply_interface_mapping_to_expr (mapping, + expr->value.function.actual->expr) + && expr->value.function.esym == NULL + && expr->value.function.isym != NULL + && expr->value.function.isym->generic_id == GFC_ISYM_LEN) + { + gfc_expr *new_expr; + new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length); + *expr = *new_expr; + gfc_free (new_expr); + gfc_apply_interface_mapping_to_expr (mapping, expr); + break; + } + for (sym = mapping->syms; sym; sym = sym->next) if (sym->old == expr->value.function.esym) expr->value.function.esym = sym->new->n.sym; @@ -1655,6 +1673,7 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping, gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor); break; } + return seen_result; } @@ -2087,11 +2106,19 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* Argument list functions %VAL, %LOC and %REF are signalled through arg->name. */ conv_arglist_function (&parmse, arg->expr, arg->name); + else if ((e->expr_type == EXPR_FUNCTION) + && e->symtree->n.sym->attr.pointer + && fsym && fsym->attr.target) + { + gfc_conv_expr (&parmse, e); + parmse.expr = build_fold_addr_expr (parmse.expr); + } else { gfc_conv_expr_reference (&parmse, e); if (fsym && fsym->attr.pointer - && e->expr_type != EXPR_NULL) + && fsym->attr.flavor != FL_PROCEDURE + && e->expr_type != EXPR_NULL) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index aa313d97d8a..4b1505e74fb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2007-03-24 Paul Thomas + + PR fortran/31219 + * gfortran.dg/pointer_function_actual_1.f90: New test. + + PR fortran/31200 + * gfortran.dg/pointer_function_actual_2.f90: New test. + + PR fortran/31215 + * gfortran.dg/result_in_spec_1.f90: New test. + 2007-03-23 Francois-Xavier Coudert PR fortran/30834 diff --git a/gcc/testsuite/gfortran.dg/pointer_function_actual_1.f90 b/gcc/testsuite/gfortran.dg/pointer_function_actual_1.f90 new file mode 100644 index 00000000000..91c340c3dc8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_function_actual_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Tests the fix for PR31219, in which an ICE would result because +! the reference to the pointer function f would be indirected, as +! if it were the result that is being passed. +! +! COntributed by Joost VandeVondele +! +FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + ALLOCATE(RES) + RES=2 +END FUNCTION F + +SUBROUTINE S1(f,*,*) + INTERFACE + FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + END FUNCTION F + END INTERFACE + RETURN F() +END SUBROUTINE + +PROGRAM TEST + INTERFACE + FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + END FUNCTION F + END INTERFACE + + + INTERFACE + SUBROUTINE S1(f,*,*) + INTERFACE + FUNCTION F() RESULT(RES) + INTEGER, POINTER :: RES + END FUNCTION F + END INTERFACE + END SUBROUTINE + END INTERFACE + + CALL S1(F,*1,*2) + + 1 CONTINUE + CALL ABORT() + + GOTO 3 + 2 CONTINUE + + 3 CONTINUE +END + diff --git a/gcc/testsuite/gfortran.dg/pointer_function_actual_2.f90 b/gcc/testsuite/gfortran.dg/pointer_function_actual_2.f90 new file mode 100644 index 00000000000..11457ffd9a6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_function_actual_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Tests the fix for PR31200, in which the target x would +! not be associated with p +! +! COntributed by Joost VandeVondele +! + REAL,TARGET :: x + CALL s3(f(x)) +CONTAINS + FUNCTION f(a) + REAL,POINTER :: f + REAL,TARGET :: a + f => a + END FUNCTION + SUBROUTINE s3(targ) + REAL,TARGET :: targ + REAL,POINTER :: p + p => targ + IF (.NOT. ASSOCIATED(p,x)) CALL ABORT() + END SUBROUTINE +END + diff --git a/gcc/testsuite/gfortran.dg/result_in_spec_1.f90 b/gcc/testsuite/gfortran.dg/result_in_spec_1.f90 new file mode 100644 index 00000000000..bfb5412224b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/result_in_spec_1.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! Tests the check for PR31215, in which actual/formal interface +! was not being correctly handled for the size of 'r' because +! it is a result. +! +! Contributed by Joost VandeVondele +! +module test1 + implicit none +contains + character(f(x)) function test2(x) result(r) + implicit integer (x) + dimension r(len(r)+1) + integer, intent(in) :: x + interface + pure function f(x) + integer, intent(in) :: x + integer f + end function f + end interface + integer i + do i = 1, len(r) + r(:)(i:i) = achar(mod(i,32)+iachar('@')) + end do + end function test2 +end module test1 + +program test + use test1 + implicit none +! Original problem + if (len(test2(10)) .ne. 21) call abort () +! Check non-intrinsic calls are OK and check that fix does +! not confuse result variables. + if (any (myfunc (test2(1)) .ne. "ABC")) call abort () +contains + function myfunc (ch) result (chr) + character(len(ch)) :: chr(2) + character (*) :: ch(:) + if (len (ch) .ne. 3) call abort () + if (any (ch .ne. "ABC")) call abort () + chr = test2 (1) + if (len(test2(len(chr))) .ne. 7) call abort () + end function myfunc +end program test + +pure function f(x) + integer, intent(in) :: x + integer f + f = 2*x+1 +end function f +! { dg-final { cleanup-modules "test1" } }