From b2b247f9864d751c6ebf696292b93b477d2c6c96 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 8 May 2007 12:45:31 +0000 Subject: [PATCH] re PR fortran/31692 (Wrong code when passing function name as result to procedures) 2007-05-08 Paul Thomas PR fortran/31692 * trans-array.c (gfc_conv_array_parameter): Convert full array references to the result of the procedure enclusing the call. 2007-05-08 Paul Thomas PR fortran/31692 * gfortran.dg/actual_array_result_1.f90: New test. From-SVN: r124546 --- gcc/fortran/ChangeLog | 6 ++ gcc/fortran/trans-array.c | 38 ++++++++++-- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/actual_array_result_1.f90 | 71 ++++++++++++++++++++++ 4 files changed, 115 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/actual_array_result_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7a145fa..3fc67d7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,11 @@ 2007-05-08 Paul Thomas + PR fortran/31692 + * trans-array.c (gfc_conv_array_parameter): Convert full array + references to the result of the procedure enclusing the call. + +2007-05-08 Paul Thomas + PR fortran/29397 PR fortran/29400 * decl.c (add_init_expr_to_sym): Expand a scalar initializer diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 92fd67c..4997673 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4748,14 +4748,25 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) tree desc; tree tmp; tree stmt; + tree parent = DECL_CONTEXT (current_function_decl); + bool full_array_var, this_array_result; gfc_symbol *sym; stmtblock_t block; + full_array_var = (expr->expr_type == EXPR_VARIABLE + && expr->ref->u.ar.type == AR_FULL); + sym = full_array_var ? expr->symtree->n.sym : NULL; + + /* Is this the result of the enclosing procedure? */ + this_array_result = (full_array_var && sym->attr.flavor == FL_PROCEDURE); + if (this_array_result + && (sym->backend_decl != current_function_decl) + && (sym->backend_decl != parent)) + this_array_result = false; + /* 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) + if (full_array_var && g77 && !this_array_result) { - sym = expr->symtree->n.sym; tmp = gfc_get_symbol_decl (sym); if (sym->ts.type == BT_CHARACTER) @@ -4784,8 +4795,25 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) } } - se->want_pointer = 1; - gfc_conv_expr_descriptor (se, expr, ss); + if (this_array_result) + { + /* Result of the enclosing function. */ + gfc_conv_expr_descriptor (se, expr, ss); + se->expr = build_fold_addr_expr (se->expr); + + if (g77 && 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)); + + return; + } + else + { + /* Every other type of array. */ + se->want_pointer = 1; + gfc_conv_expr_descriptor (se, expr, ss); + } + /* Deallocate the allocatable components of structures that are not variable. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 3c6d9c4..1542977 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2007-05-08 Paul Thomas + PR fortran/31692 + * gfortran.dg/actual_array_result_1.f90: New test. + +2007-05-08 Paul Thomas + PR fortran/29397 * gfortran.dg/parameter_array_init_1.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/actual_array_result_1.f90 b/gcc/testsuite/gfortran.dg/actual_array_result_1.f90 new file mode 100644 index 0000000..cf79315 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/actual_array_result_1.f90 @@ -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" } } -- 2.7.4