diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 90df7a4aa87b..717ffa025cb1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2009-11-01 Tobias Burnus + + PR fortran/41872 + * trans-decl.c (gfc_trans_deferred_vars): Do not nullify + autodeallocated allocatable scalars at the end of scope. + (gfc_generate_function_code): Fix indention. + * trans-expr.c (gfc_conv_procedure_call): For allocatable + scalars, fix calling by reference and autodeallocating + of intent out variables. + 2009-11-01 Tobias Burnus PR fortran/41850 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 8812675990f7..8ac6b9acc197 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3193,7 +3193,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) gfc_expr *e; gfc_se se; stmtblock_t block; - + e = gfc_lval_expr_from_sym (sym); if (sym->ts.type == BT_CLASS) gfc_add_component_ref (e, "$data"); @@ -3206,13 +3206,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) gfc_start_block (&block); gfc_add_expr_to_block (&block, fnbody); + /* Note: Nullifying is not needed. */ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true, NULL); gfc_add_expr_to_block (&block, tmp); - - tmp = fold_build2 (MODIFY_EXPR, void_type_node, - se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); - gfc_add_expr_to_block (&block, tmp); - fnbody = gfc_finish_block (&block); } else if (sym->ts.type == BT_CHARACTER) @@ -4396,10 +4392,10 @@ gfc_generate_function_code (gfc_namespace * ns) /* Reset recursion-check variable. */ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive) - { - gfc_add_modify (&block, recurcheckvar, boolean_false_node); - recurcheckvar = NULL; - } + { + gfc_add_modify (&block, recurcheckvar, boolean_false_node); + recurcheckvar = NULL; + } if (result == NULL_TREE) { diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 8255bb1aea58..d8f8303fdbd3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2892,6 +2892,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else { gfc_conv_expr_reference (&parmse, e); + + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + allocated on entry, it must be deallocated. */ + if (fsym && fsym->attr.allocatable + && fsym->attr.intent == INTENT_OUT) + { + stmtblock_t block; + + gfc_init_block (&block); + tmp = gfc_deallocate_with_status (parmse.expr, NULL_TREE, + true, NULL); + gfc_add_expr_to_block (&block, tmp); + tmp = fold_build2 (MODIFY_EXPR, void_type_node, + parmse.expr, null_pointer_node); + gfc_add_expr_to_block (&block, tmp); + + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + tmp = fold_build3 (COND_EXPR, void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + + gfc_add_expr_to_block (&se->pre, tmp); + } + if (fsym && e->expr_type != EXPR_NULL && ((fsym->attr.pointer && fsym->attr.flavor != FL_PROCEDURE) @@ -2899,7 +2930,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy)) || (e->expr_type == EXPR_VARIABLE - && gfc_is_proc_ptr_comp (e, NULL)))) + && gfc_is_proc_ptr_comp (e, NULL)) + || fsym->attr.allocatable)) { /* Scalar pointer dummy args require an extra level of indirection. The null pointer already contains @@ -3169,7 +3201,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, cl.backend_decl = formal->sym->ts.u.cl->backend_decl; } } - else + else { tree tmp; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 363e9cba7d79..bd400052ad42 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-11-01 Tobias Burnus + + PR fortran/41872 + * gfortran.dg/allocatable_scalar_4.f90: New test. + 2009-11-01 Tobias Burnus PR fortran/41850 diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_4.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_4.f90 new file mode 100644 index 000000000000..9f7a7a07d708 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_4.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! +! PR fortran/41872 +! +! +program test + implicit none + integer, allocatable :: a + integer, allocatable :: b + allocate(a) + call foo(a) + if(.not. allocated(a)) call abort() + if (a /= 5) call abort() + + call bar(a) + if (a /= 7) call abort() + + deallocate(a) + if(allocated(a)) call abort() + call check3(a) + if(.not. allocated(a)) call abort() + if(a /= 6874) call abort() + call check4(a) + if(.not. allocated(a)) call abort() + if(a /= -478) call abort() + + allocate(b) + b = 7482 + call checkOptional(.false.,.true., 7482) + if (b /= 7482) call abort() + call checkOptional(.true., .true., 7482, b) + if (b /= 46) call abort() +contains + subroutine foo(a) + integer, allocatable, intent(out) :: a + if(allocated(a)) call abort() + allocate(a) + a = 5 + end subroutine foo + + subroutine bar(a) + integer, allocatable, intent(inout) :: a + if(.not. allocated(a)) call abort() + if (a /= 5) call abort() + a = 7 + end subroutine bar + + subroutine check3(a) + integer, allocatable, intent(inout) :: a + if(allocated(a)) call abort() + allocate(a) + a = 6874 + end subroutine check3 + + subroutine check4(a) + integer, allocatable, intent(inout) :: a + if(.not.allocated(a)) call abort() + if (a /= 6874) call abort + deallocate(a) + if(allocated(a)) call abort() + allocate(a) + if(.not.allocated(a)) call abort() + a = -478 + end subroutine check4 + + subroutine checkOptional(prsnt, alloc, val, x) + logical, intent(in) :: prsnt, alloc + integer, allocatable, optional :: x + integer, intent(in) :: val + if (present(x) .neqv. prsnt) call abort() + if (present(x)) then + if (allocated(x) .neqv. alloc) call abort() + end if + if (present(x)) then + if (allocated(x)) then + if (x /= val) call abort() + end if + end if + call checkOptional2(x) + if (present(x)) then + if (.not. allocated(x)) call abort() + if (x /= -6784) call abort() + x = 46 + end if + call checkOptional2() + end subroutine checkOptional + subroutine checkOptional2(x) + integer, allocatable, optional, intent(out) :: x + if (present(x)) then + if (allocated(x)) call abort() + allocate(x) + x = -6784 + end if + end subroutine checkOptional2 +end program test