On 10/23/19 8:12 PM, Steve Kargl wrote:
* trans-expr.c (gfc_conv_procedure_call): Evaluate args and then
deallocate actual args assocated with intent(out) dummies.
I think the patch by itself looks fine to me – except that the
saw_dealloc is not needed. You can either check "if (dealloc_blk->head)"
or you can use gfc_add_block_to_block unconditionally as it handles
NULL_TREE.
However, the following test case shows that expressions which can be
transferred into a tree (se->expr) without needing more evaluations and
a temporary (i.e. evaluating things in se->pre) do not work. – The
allocated(a) check is really artificial, however, the test() call looks
as if it might appear in the real world. First the dump:
foo ((integer(kind=4)[0:] * restrict) a.data != 0B,
(integer(kind=4)) MAX_EXPR <(D.3958->dim[0].ubound -
D.3958->dim[0].lbound) + 1, 0>, test ((integer(kind=4)[0:] * restrict)
a.data), &a);
And then the test case:
implicit none (type, external)
integer, allocatable :: a(:)
a = [1, 2]
call foo(allocated(a), size(a), test(a), a)
contains
subroutine foo(alloc, sz, tst, x)
logical, value :: alloc, tst
integer, value :: sz
integer, allocatable, intent(out) :: x(:)
if (allocated(x)) stop 1
if (.not.alloc) stop 2
if (sz /= 2) stop 3
if (.not. tst) stop 4
end subroutine foo
logical function test(zz)
integer :: zz(2)
test = zz(2) == 2
end function test
end
Hence, I wonder whether one needs to do (pseudo code):
if (any dummy argument is allocatable + intent-out)
force_func_eval = true
if (actual is an expression + force_func_eval)
parmse->expr = gfc_evaluate_now (parmse->expr, &parmse)
Such that one uses a temporary variable for those, but keeps the status quo for
the rest.
Note, in gfc_conv_procedure_call() there are 3 blocks of
code that deal with the deallocation of actual arguments
assocated with intent(out) dummy arguments. The patch
affects the first and third blocks. The 2nd block, lines
6071-6111, concerns CLASS and finalization. I use neither,
so have no idea what Fortran requires. More importantly,
I have very little understanding of gfortran's internal
implementation for CLASS and finalization. Someone who
cares about CLASS and finalization will need to consider
how to possibly fix a possible issue.
I wonder how to test for it. I tried to create a test case
(pr92178-3.f90) but as it turns out, the deallocation happens (via
zz->_vptr->_final) directly in the called function and not in the callee.
For this one, I was playing with the attached patch – but if one cannot
trigger it, it might not be needed.
I have also created another test case pr92178-2.f90 which essentially
does what pr92178.f90 already did (nearly same code path, covered by
your patch).
The question is how to proceed from here.
Tobias
! { dg-do run }
!
! PR fortran/92178
program foo
implicit none (type, external)
type t0
integer, allocatable :: X0
end type t0
type, extends(t0) :: t
end type t
type, extends(t) :: t2
end type t2
type(t2) :: x2
class(t), allocatable :: aa(:)
allocate(t2 :: aa(1))
allocate(aa(1)%x0)
contains
subroutine caller(xx)
class(t) :: xx(:)
if (.not. allocated(xx(1)%x0)) stop 10
if (.not. same_type_as(xx, x2)) stop 11
call check_intentout(allocated(xx(1)%x0), same_type_as(xx, x2), xx, &
allocated(xx(1)%x0), same_type_as(xx, x2))
end subroutine caller
subroutine check_intentout(alloc1, same1, zz, alloc2, same2)
logical, value :: alloc1, alloc2, same1, same2
class(t0), intent(out) :: zz(:)
if (allocated(zz(1)%x0)) stop 1
if (.not.alloc1) stop 2
if (.not.alloc2) stop 3
if (.not.same1) stop 4
if (.not.same2) stop 5
end subroutine
end program
! { dg-do run }
!
! PR fortran/92178
program foo
implicit none (type, external)
type t
end type t
type, extends(t) :: t2
end type t2
type(t2) :: x2
class(t), allocatable :: aa
call check_intentout_false(allocated(aa), aa, &
allocated(aa))
if (allocated(aa)) stop 1
allocate(t2 :: aa)
if (.not.allocated(aa)) stop 2
if (.not.same_type_as(aa, x2)) stop 3
call check_intentout_true(allocated(aa), (same_type_as(aa, x2)), aa, &
allocated(aa), (same_type_as(aa, x2)))
if (allocated(aa)) stop 4
contains
subroutine check_intentout_false(alloc1, yy, alloc2)
logical, value :: alloc1, alloc2
class(t), allocatable, intent(out) :: yy
if (allocated(yy)) stop 11
if (alloc1) stop 12
if (alloc2) stop 13
end subroutine
subroutine check_intentout_true(alloc1, same1, zz, alloc2, same2)
logical, value :: alloc1, alloc2, same1, same2
class(t), allocatable, intent(out) :: zz
if (allocated(zz)) stop 21
if (.not.alloc1) stop 22
if (.not.alloc2) stop 23
if (.not.same1) stop 24
if (.not.same2) stop 25
end subroutine
end program
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7eba1bbd082..d44da6d02ef 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5392,6 +5392,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_component *comp = NULL;
int arglen;
unsigned int argc;
+ stmtblock_t dealloc_blk;
arglist = NULL;
retargs = NULL;
@@ -5432,6 +5433,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
info = NULL;
gfc_init_block (&post);
+ gfc_init_block (&dealloc_blk);
gfc_init_interface_mapping (&mapping);
if (!comp)
{
@@ -5963,8 +5965,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else
tmp = gfc_finish_block (&block);
-
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
}
if (fsym && (fsym->ts.type == BT_DERIVED
@@ -6049,6 +6050,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& (CLASS_DATA (fsym)->attr.dimension
|| CLASS_DATA (fsym)->attr.codimension))
{
+ gfc_se tmpse;
+
/* Pass a class array. */
parmse.use_offset = 1;
gfc_conv_expr_descriptor (&parmse, e);
@@ -6092,12 +6095,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
tmp = gfc_finish_block (&block);
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
}
+ /* The 'pre' part of the gfc_conv_class_to_class conversion has to
+ come after the deallocation of INTENT_OUT, which in turn is
+ done after all arguments have been evaluated. */
+ gfc_init_se (&tmpse, NULL);
+ tmpse.expr = parmse.expr;
+ tmpse.class_vptr = parmse.class_vptr;
+
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
- gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
+ gfc_conv_class_to_class (&tmpse, e, fsym->ts, false,
fsym->attr.intent != INTENT_IN
&& (CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable),
@@ -6106,6 +6116,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& e->symtree->n.sym->attr.optional,
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
+__builtin_fprintf(stderr,"DEBUg – IS – CALLED\n");
+ gfc_add_block_to_block (&dealloc_blk, &tmpse.pre);
+ parmse.expr = tmpse.expr;
+ parmse.class_vptr = tmpse.class_vptr;
+ gfc_add_block_to_block (&parmse.post, &tmpse.post);
}
else
{
@@ -6258,7 +6273,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
void_type_node,
gfc_conv_expr_present (e->symtree->n.sym),
tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_expr_to_block (&dealloc_blk, tmp);
}
}
}
@@ -6629,6 +6644,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
vec_safe_push (arglist, parmse.expr);
}
+ gfc_add_block_to_block (&se->pre, &dealloc_blk);
gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
if (comp)
