procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

fortran: defer class wrapper initialization after deallocation [PR92178]

Browse source 
If an actual argument is associated with an INTENT(OUT) dummy, and code
to deallocate it is generated, generate the class wrapper initialization
after the actual argument deallocation.

This is achieved by passing a cleaned up expression to
gfc_conv_class_to_class, so that the class wrapper initialization code
can be isolated and moved independently after the deallocation.

	PR fortran/92178

gcc/fortran/ChangeLog:

	* trans-expr.cc (gfc_conv_procedure_call): Use a separate gfc_se
	struct, initalized from parmse, to generate the class wrapper.
	After the class wrapper code has been generated, copy it back
	depending on whether parameter deallocation code has been
	generated.

gcc/testsuite/ChangeLog:

	* gfortran.dg/intent_out_19.f90: New test.
This commit is contained in:
Mikael Morin 2023-07-14 14:15:07 +02:00
parent a85a106c35
commit e93452a571
2 changed files with 39 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/trans-expr.cc
View file

@ -6500,6 +6500,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else
{
bool defer_to_dealloc_blk = false;
if (e->ts.type == BT_CLASS && fsym
&& fsym->ts.type == BT_CLASS
&& (!CLASS_DATA (fsym)->as
@ -6661,6 +6662,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
stmtblock_t block;
tree ptr;
defer_to_dealloc_blk = true;
gfc_init_block (&block);
ptr = parmse.expr;
if (e->ts.type == BT_CLASS)
@ -6717,7 +6720,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& ((CLASS_DATA (fsym)->as
&& CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
|| CLASS_DATA (e)->attr.dimension))
gfc_conv_class_to_class (&parmse, e, fsym->ts, false,
{
gfc_se class_se = parmse;
gfc_init_block (&class_se.pre);
gfc_init_block (&class_se.post);
gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
fsym->attr.intent != INTENT_IN
&& (CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable),
@ -6727,6 +6735,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
CLASS_DATA (fsym)->attr.class_pointer
|| CLASS_DATA (fsym)->attr.allocatable);
parmse.expr = class_se.expr;
stmtblock_t *class_pre_block = defer_to_dealloc_blk
? &dealloc_blk
: &parmse.pre;
gfc_add_block_to_block (class_pre_block, &class_se.pre);
gfc_add_block_to_block (&parmse.post, &class_se.post);
}
if (fsym && (fsym->ts.type == BT_DERIVED
|| fsym->ts.type == BT_ASSUMED)
&& e->ts.type == BT_CLASS

22
gcc/testsuite/gfortran.dg/intent_out_19.f90 Normal file
View file

@ -0,0 +1,22 @@
! { dg-do run }
!
! PR fortran/92178
! Check that if a data reference passed is as actual argument whose dummy
! has INTENT(OUT) attribute, any other argument depending on the
! same data reference is evaluated before the data reference deallocation.
program p
implicit none
class(*), allocatable :: c
c = 3
call bar (allocated(c), c, allocated (c))
if (allocated (c)) stop 14
contains
subroutine bar (alloc, x, alloc2)
logical :: alloc, alloc2
class(*), allocatable, intent(out) :: x(..)
if (allocated (x)) stop 5
if (.not. alloc) stop 6
if (.not. alloc2) stop 16
end subroutine bar
end