diff options
| author | Mikael Morin <mikael@gcc.gnu.org> | 2023-07-14 14:15:07 +0200 |
|---|---|---|
| committer | Mikael Morin <mikael@gcc.gnu.org> | 2023-07-14 14:15:07 +0200 |
| commit | e93452a5712e87ba624562ba7164b1e1394d18fb (patch) | |
| tree | f6e29e091a8a91fe29b82b373937a61936113724 /gcc/fortran | |
| parent | a85a106c35c6d1d9fd40627e149501e5e854bcc3 (diff) | |
| download | gcc-e93452a5712e87ba624562ba7164b1e1394d18fb.zip gcc-e93452a5712e87ba624562ba7164b1e1394d18fb.tar.gz gcc-e93452a5712e87ba624562ba7164b1e1394d18fb.tar.bz2 | |
fortran: defer class wrapper initialization after deallocation [PR92178]
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.
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 18 |
1 files changed, 17 insertions, 1 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 7017b65..b7e95e6 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -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 |