[Patch, fortran] PR31692 - Wrong code when passing function name as result to procedures
Paul Richard Thomas
paul.richard.thomas@gmail.com
Fri May 4 14:05:00 GMT 2007
:ADDPATCH fortran:
This problem arises because an actual argument that is a full array
reference to an implicit result, within the procedure itself, results
in the procedure declaration being passed rather than the "fake result
declaration". The patch detects the condition in trans-array.c
(gfc_conv_array_parameter) and treats the correct declaration
appropriately for passing as an actual argument.
The testcase is based on that of the reporter, has been embellished by
Tobias Burnus and added to by yours truly. It now checks that assumed
size and assumed shape formal arguments work, with implicit and
explicit procedure results. In addition, the passing of sections of
the result are also checked.
Bootstrapped and regtested on x86_ia64/FC5 - OK for trunk?
Paul
2007-05-04 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31292
* trans-array.c (gfc_conv_array_parameter): Convert full array
references to the result of the procedure enclusing the call.
2007-05-04 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31292
* gfortran.dg/actual_array_result_1.f90: New test.
-------------- next part --------------
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (r?vision 124351)
--- gcc/fortran/trans-array.c (copie de travail)
*************** gfc_conv_array_parameter (gfc_se * se, g
*** 4748,4786 ****
tree desc;
tree tmp;
tree stmt;
gfc_symbol *sym;
stmtblock_t block;
! /* Passing address of the array if it is not pointer or assumed-shape. */
! if (expr->expr_type == EXPR_VARIABLE
! && expr->ref->u.ar.type == AR_FULL && g77)
{
sym = expr->symtree->n.sym;
- tmp = gfc_get_symbol_decl (sym);
! if (sym->ts.type == BT_CHARACTER)
! se->string_length = sym->ts.cl->backend_decl;
! if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
! && !sym->attr.allocatable)
! {
! /* Some variables are declared directly, others are declared as
! pointers and allocated on the heap. */
! if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
! se->expr = tmp;
! else
! se->expr = build_fold_addr_expr (tmp);
return;
! }
! if (sym->attr.allocatable)
! {
! if (sym->attr.dummy)
! {
! gfc_conv_expr_descriptor (se, expr, ss);
! se->expr = gfc_conv_array_data (se->expr);
}
- else
- se->expr = gfc_conv_array_data (tmp);
- return;
}
}
--- 4748,4818 ----
tree desc;
tree tmp;
tree stmt;
+ tree parent = DECL_CONTEXT (current_function_decl);
gfc_symbol *sym;
stmtblock_t block;
! if (expr->expr_type == EXPR_VARIABLE && expr->ref->u.ar.type == AR_FULL)
{
sym = expr->symtree->n.sym;
! /* Deal with the result of the enclosing procedure. */
! if (sym->attr.flavor == FL_PROCEDURE
! && (sym->backend_decl == current_function_decl
! ||
! sym->backend_decl == parent))
! {
! int b = (parent == sym->backend_decl) ? 1 : 0;
! se->expr = gfc_get_fake_result_decl (sym, b);
!
! /* Pass a descriptor if required. */
! if (g77 == 0 && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
! {
! tmp = gfc_conv_array_data (se->expr);
! gfc_conv_expr_descriptor (se, expr, ss);
! se->expr = build_fold_addr_expr (se->expr);
! }
!
! /* Provide the data pointer, if needed. */
! else if (g77 == 1 && TREE_TYPE (TREE_TYPE (se->expr)) != NULL_TREE
! && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
! se->expr = gfc_conv_array_data (build_fold_indirect_ref (se->expr));
!
! if (sym->ts.type == BT_CHARACTER)
! se->string_length = sym->ts.cl->backend_decl;
!
return;
! }
!
! /* Passing address of the array if it is not pointer or assumed-shape. */
! if (g77)
! {
! tmp = gfc_get_symbol_decl (sym);
!
! if (sym->ts.type == BT_CHARACTER)
! se->string_length = sym->ts.cl->backend_decl;
! if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
! && !sym->attr.allocatable)
! {
! /* Some variables are declared directly, others are declared as
! pointers and allocated on the heap. */
! if (sym->attr.dummy || POINTER_TYPE_P (TREE_TYPE (tmp)))
! se->expr = tmp;
! else
! se->expr = build_fold_addr_expr (tmp);
! return;
! }
! if (sym->attr.allocatable)
! {
! if (sym->attr.dummy)
! {
! gfc_conv_expr_descriptor (se, expr, ss);
! se->expr = gfc_conv_array_data (se->expr);
! }
! else
! se->expr = gfc_conv_array_data (tmp);
! return;
}
}
}
Index: gcc/testsuite/gfortran.dg/actual_array_result_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/actual_array_result_1.f90 (r?vision 0)
--- gcc/testsuite/gfortran.dg/actual_array_result_1.f90 (r?vision 0)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ ! PR fortan/31692
+ ! Passing array valued results to procedures
+ !
+ ! Test case contributed by rakuen_himawari@yahoo.co.jp
+ module one
+ integer :: flag = 0
+ contains
+ function foo1 (n)
+ integer :: n
+ integer :: foo1(n)
+ if (flag == 0) then
+ call bar1 (n, foo1)
+ else
+ call bar2 (n, foo1)
+ end if
+ end function
+
+ function foo2 (n)
+ implicit none
+ integer :: n
+ integer,ALLOCATABLE :: foo2(:)
+ allocate (foo2(n))
+ if (flag == 0) then
+ call bar1 (n, foo2)
+ else
+ call bar2 (n, foo2)
+ end if
+ end function
+
+ function foo3 (n)
+ implicit none
+ integer :: n
+ integer,ALLOCATABLE :: foo3(:)
+ allocate (foo3(n))
+ foo3 = 0
+ call bar2(n, foo3(2:(n-1))) ! Check that sections are OK
+ end function
+
+ subroutine bar1 (n, array) ! Checks assumed size formal arg.
+ integer :: n
+ integer :: array(*)
+ integer :: i
+ do i = 1, n
+ array(i) = i
+ enddo
+ end subroutine
+
+ subroutine bar2(n, array) ! Checks assumed shape formal arg.
+ integer :: n
+ integer :: array(:)
+ integer :: i
+ do i = 1, size (array, 1)
+ array(i) = i
+ enddo
+ end subroutine
+ end module
+
+ program main
+ use one
+ integer :: n
+ n = 3
+ if(any (foo1(n) /= [ 1,2,3 ])) call abort()
+ if(any (foo2(n) /= [ 1,2,3 ])) call abort()
+ flag = 1
+ if(any (foo1(n) /= [ 1,2,3 ])) call abort()
+ if(any (foo2(n) /= [ 1,2,3 ])) call abort()
+ n = 5
+ if(any (foo3(n) /= [ 0,1,2,3,0 ])) call abort()
+ end program
+ ! { dg-final { cleanup-modules "one" } }
More information about the Fortran
mailing list