From 8c6cb782a355e540036b38f8124a1870612c4950 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 27 Jan 2012 21:11:51 +0100 Subject: [PATCH] re PR fortran/52022 (Wrong-code with procedures passed as actual argument) 2012-01-27 Tobias Burnus PR fortran/52022 * trans-expr.c (gfc_conv_procedure_call): Fix passing of functions, which return allocatables. 2012-01-27 Tobias Burnus PR fortran/52022 * gfortran.dg/dummy_procedure_7.f90: New. From-SVN: r183643 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/trans-expr.c | 3 +- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/dummy_procedure_7.f90 | 65 +++++++++++++++++++ 4 files changed, 78 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/dummy_procedure_7.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b54ad3d6a1a..b1e9402b604 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2012-01-27 Tobias Burnus + + PR fortran/52022 + * trans-expr.c (gfc_conv_procedure_call): Fix passing + of functions, which return allocatables. + 2012-01-27 Tobias Burnus PR fortran/52016 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 250f30fa41b..7543149e32c 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3662,7 +3662,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, || (fsym->attr.proc_pointer && e->expr_type == EXPR_VARIABLE && gfc_is_proc_ptr_comp (e, NULL)) - || fsym->attr.allocatable)) + || (fsym->attr.allocatable + && fsym->attr.flavor != FL_PROCEDURE))) { /* 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 c64db73f997..7ebce8dd4de 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-01-27 Tobias Burnus + + PR fortran/52022 + * gfortran.dg/dummy_procedure_7.f90: New. + 2012-01-27 Andreas Schwab * g++.dg/cpp0x/constexpr-rom.C: Don't add -G0 on *-*-darwin* diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_7.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_7.f90 new file mode 100644 index 00000000000..32cd65ae8b6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dummy_procedure_7.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR fortran/52022 +! + +module check + integer, save :: icheck = 0 +end module check + +module t +implicit none + contains +subroutine sol(cost) + use check + interface + function cost(p) result(y) + double precision,dimension(:) :: p + double precision,dimension(:),allocatable :: y + end function cost + end interface + + if (any (cost([1d0,2d0]) /= [2.d0, 4.d0])) call abort () + icheck = icheck + 1 +end subroutine + +end module t + +module tt + procedure(cost1),pointer :: pcost +contains + subroutine init() + pcost=>cost1 + end subroutine + + function cost1(x) result(y) + double precision,dimension(:) :: x + double precision,dimension(:),allocatable :: y + allocate(y(2)) + y=2d0*x + end function cost1 + + + + function cost(x) result(y) + double precision,dimension(:) :: x + double precision,dimension(:),allocatable :: y + allocate(y(2)) + y=pcost(x) + end function cost +end module + +program test + use tt + use t + use check + implicit none + + call init() + if (any (cost([3.d0,7.d0]) /= [6.d0, 14.d0])) call abort () + if (icheck /= 0) call abort () + call sol(cost) + if (icheck /= 1) call abort () +end program test + +! { dg-final { cleanup-modules "t tt check" } }