diff options
| -rw-r--r-- | gcc/fortran/trans-array.cc | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 26 | ||||
| -rw-r--r-- | gcc/fortran/trans.cc | 28 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 6 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/intent_out_20.f90 | 33 |
5 files changed, 96 insertions, 0 deletions
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e7c51ba..1c2af55 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3271,6 +3271,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) gfc_add_block_to_block (block, &se.pre); info->descriptor = se.expr; ss_info->string_length = se.string_length; + ss_info->class_container = se.class_container; if (base) { @@ -7687,6 +7688,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else if (deferred_array_component) se->string_length = ss_info->string_length; + se->class_container = ss_info->class_container; + gfc_free_ss_chain (ss); return; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index b7e95e6..5169fbc 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -1266,6 +1266,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, slen = build_zero_cst (size_type_node); } + else if (parmse->class_container != NULL_TREE) + /* Don't redundantly evaluate the expression if the required information + is already available. */ + tmp = parmse->class_container; else { /* Remove everything after the last class reference, convert the @@ -3078,6 +3082,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) return; } + if (sym->ts.type == BT_CLASS + && sym->attr.class_ok + && sym->ts.u.derived->attr.is_class) + se->class_container = se->expr; + /* Dereference the expression, where needed. */ se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only, is_classarray); @@ -3135,6 +3144,15 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + + if (ref->u.c.component->ts.type == BT_CLASS + && ref->u.c.component->attr.class_ok + && ref->u.c.component->ts.u.derived->attr.is_class) + se->class_container = se->expr; + else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED + && ref->u.c.sym->attr.is_class)) + se->class_container = NULL_TREE; + if (!ref->next && ref->u.c.sym->attr.codimension && se->want_pointer && se->descriptor_only) return; @@ -6664,6 +6682,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, defer_to_dealloc_blk = true; + 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; if (e->ts.type == BT_CLASS) diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 7ad85ae..f1a3aac 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -174,6 +174,34 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock) return gfc_evaluate_now_loc (input_location, expr, pblock); } + +/* Returns a fresh pointer variable pointing to the same data as EXPR, adding + in BLOCK the initialization code that makes it point to EXPR. */ + +tree +gfc_evaluate_data_ref_now (tree expr, stmtblock_t *block) +{ + tree t = expr; + + STRIP_NOPS (t); + + /* If EXPR can be used as lhs of an assignment, we have to take the address + of EXPR. Otherwise, reassigning the pointer would retarget it to some + other data without EXPR being retargetted as well. */ + bool lvalue_p = DECL_P (t) || REFERENCE_CLASS_P (t) || INDIRECT_REF_P (t); + + tree value; + if (lvalue_p) + { + value = gfc_build_addr_expr (NULL_TREE, expr); + value = gfc_evaluate_now (value, block); + return build_fold_indirect_ref_loc (input_location, value); + } + else + return gfc_evaluate_now (expr, block); +} + + /* Like gfc_evaluate_now, but add the created variable to the function scope. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0c8d004..82cdd69 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -57,6 +57,10 @@ typedef struct gfc_se here. */ tree class_vptr; + /* When expr is a reference to a direct subobject of a class, store + the reference to the class object here. */ + tree class_container; + /* Whether expr is a reference to an unlimited polymorphic object. */ unsigned unlimited_polymorphic:1; @@ -263,6 +267,7 @@ typedef struct gfc_ss_info gfc_ss_type type; gfc_expr *expr; tree string_length; + tree class_container; union { @@ -525,6 +530,7 @@ void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr); /* If the value is not constant, Create a temporary and copy the value. */ tree gfc_evaluate_now_loc (location_t, tree, stmtblock_t *); tree gfc_evaluate_now (tree, stmtblock_t *); +tree gfc_evaluate_data_ref_now (tree, stmtblock_t *); tree gfc_evaluate_now_function_scope (tree, stmtblock_t *); /* Find the appropriate variant of a math intrinsic. */ diff --git a/gcc/testsuite/gfortran.dg/intent_out_20.f90 b/gcc/testsuite/gfortran.dg/intent_out_20.f90 new file mode 100644 index 0000000..8e5d8c6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/intent_out_20.f90 @@ -0,0 +1,33 @@ +! { 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 + type t + integer :: i + end type t + type u + class(t), allocatable :: ta + end type u + type(u), allocatable :: c(:) + allocate(c, source = [u(t(1)), u(t(4))]) + call bar ( & + allocated (c(c(1)%ta%i)%ta), & + c(c(1)%ta%i)%ta, & + allocated (c(c(1)%ta%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 |