[multiple changes]
2009-11-01 Tobias Burnus <burnus@net-b.de> 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 <burnus@net-b.de> PR fortran/41872 * gfortran.dg/allocatable_scalar_4.f90: New test. From-SVN: r153795
This commit is contained in:
parent
745ff31ff7
commit
958dd42b03
|
@ -1,3 +1,13 @@
|
|||
2009-11-01 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
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 <burnus@net-b.de>
|
||||
|
||||
PR fortran/41850
|
||||
|
|
|
@ -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)
|
||||
{
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2009-11-01 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/41872
|
||||
* gfortran.dg/allocatable_scalar_4.f90: New test.
|
||||
|
||||
2009-11-01 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/41850
|
||||
|
|
|
@ -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
|
Loading…
Reference in New Issue