diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 5169fbcd974..dbb04f8c434 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -529,24 +529,32 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, } -/* Reset the vptr to the declared type, e.g. after deallocation. */ +/* Reset the vptr to the declared type, e.g. after deallocation. + Use the variable in CLASS_CONTAINER if available. Otherwise, recreate + one with E. The generated assignment code is added at the end of BLOCK. */ void -gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) +gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container) { - gfc_symbol *vtab; - tree vptr; - tree vtable; - gfc_se se; + tree vptr = NULL_TREE; - /* Evaluate the expression and obtain the vptr from it. */ - gfc_init_se (&se, NULL); - if (e->rank) - gfc_conv_expr_descriptor (&se, e); - else - gfc_conv_expr (&se, e); - gfc_add_block_to_block (block, &se.pre); - vptr = gfc_get_vptr_from_expr (se.expr); + if (class_container != NULL_TREE) + vptr = gfc_get_vptr_from_expr (class_container); + + if (vptr == NULL_TREE) + { + gfc_se se; + + /* Evaluate the expression and obtain the vptr from it. */ + gfc_init_se (&se, NULL); + if (e->rank) + gfc_conv_expr_descriptor (&se, e); + else + gfc_conv_expr (&se, e); + gfc_add_block_to_block (block, &se.pre); + + vptr = gfc_get_vptr_from_expr (se.expr); + } /* If a vptr is not found, we can do nothing more. */ if (vptr == NULL_TREE) @@ -556,6 +564,9 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); else { + gfc_symbol *vtab; + tree vtable; + /* Return the vptr to the address of the declared type. */ vtab = gfc_find_derived_vtab (e->ts.u.derived); vtable = vtab->backend_decl; @@ -6847,6 +6858,24 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr_descriptor (&parmse, e); bool defer_to_dealloc_blk = false; + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + { + stmtblock_t block; + + gfc_init_block (&block); + gfc_add_block_to_block (&block, &parmse.pre); + + tree t = fold_build3_loc (input_location, COND_EXPR, + void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + + gfc_add_expr_to_block (&parmse.pre, t); + } + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym->attr.intent == INTENT_OUT @@ -6855,6 +6884,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t block; tree ptr; + /* In case the data reference to deallocate is dependent on + its own content, save the resulting pointer to a variable + and only use that variable from now on, before the + expression becomes invalid. */ + parmse.expr = gfc_evaluate_data_ref_now (parmse.expr, + &parmse.pre); + + if (parmse.class_container != NULL_TREE) + parmse.class_container + = gfc_evaluate_data_ref_now (parmse.class_container, + &parmse.pre); + gfc_init_block (&block); ptr = parmse.expr; ptr = gfc_class_data_get (ptr); @@ -6868,7 +6909,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, void_type_node, ptr, null_pointer_node); gfc_add_expr_to_block (&block, tmp); - gfc_reset_vptr (&block, e); + gfc_reset_vptr (&block, e, parmse.class_container); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE @@ -6890,9 +6931,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, defer_to_dealloc_blk = true; } + gfc_se class_se = parmse; + gfc_init_block (&class_se.pre); + gfc_init_block (&class_se.post); + /* 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 (&class_se, e, fsym->ts, false, fsym->attr.intent != INTENT_IN && (CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable), @@ -6902,9 +6947,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, CLASS_DATA (fsym)->attr.class_pointer || CLASS_DATA (fsym)->attr.allocatable); - /* Defer repackaging after deallocation. */ - if (defer_to_dealloc_blk) - gfc_add_block_to_block (&dealloc_blk, &parmse.pre); + 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); } else { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 82cdd694073..7b41e8912b4 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -451,7 +451,7 @@ tree gfc_vptr_def_init_get (tree); tree gfc_vptr_copy_get (tree); tree gfc_vptr_final_get (tree); tree gfc_vptr_deallocate_get (tree); -void gfc_reset_vptr (stmtblock_t *, gfc_expr *); +void gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE); void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_class_from_gfc_expr (gfc_expr *); tree gfc_get_class_from_expr (tree); diff --git a/gcc/testsuite/gfortran.dg/intent_out_21.f90 b/gcc/testsuite/gfortran.dg/intent_out_21.f90 new file mode 100644 index 00000000000..5f61a547471 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_21.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/92178 +! Check that in the case of a data reference depending on its own content +! passed as actual argument to an INTENT(OUT) dummy, no reference to the +! content happens after the deallocation. + +program p + implicit none + type t + integer :: i + end type t + type u + class(t), allocatable :: ta(:) + end type u + type(u), allocatable :: c(:) + c = [u([t(1), t(3)]), u([t(4), t(9)])] + call bar ( & + allocated (c(c(1)%ta(1)%i)%ta), & + c(c(1)%ta(1)%i)%ta, & + allocated (c(c(1)%ta(1)%i)%ta) & + ) + if (allocated(c(1)%ta)) stop 11 + if (.not. allocated(c(2)%ta)) stop 12 +contains + subroutine bar (alloc, x, alloc2) + logical :: alloc, alloc2 + class(t), allocatable, intent(out) :: x(:) + if (allocated (x)) stop 1 + if (.not. alloc) stop 2 + if (.not. alloc2) stop 3 + end subroutine bar +end