https://gcc.gnu.org/bugzilla/show_bug.cgi?id=125427
Jerry DeLisle <jvdelisle at gcc dot gnu.org> changed:
What |Removed |Added
----------------------------------------------------------------------------
CC| |jvdelisle at gcc dot gnu.org
--- Comment #1 from Jerry DeLisle <jvdelisle at gcc dot gnu.org> ---
Here is a draft patch. It appears to fix pr125428 as well.
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index c366d7f4dbf..90a88cd0b05 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -1546,7 +1546,56 @@ gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr
*expr1, bool init_flag)
return false;
gfc_init_block (&final_block);
- bool finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
+ bool finalizable;
+
+ /* When the LHS has already been evaluated (lse->expr is set) and is a
+ scalar finalizable derived-type element, build the finalization call
+ directly from lse->expr rather than re-evaluating finalize_expr.
+ Re-evaluation would execute side-effect-bearing subscript expressions
+ (e.g. function calls) a second time, violating F2018 10.2.1.2 which
+ requires each subscript expression to be evaluated only once.
+ PR fortran/125427. */
+ if (lse->expr != NULL_TREE && expr1->rank == 0
+ && expr1->ts.type == BT_DERIVED)
+ {
+ /* Evaluate the element address once if lse->expr still has side
+ effects, so that both finalization and the subsequent assignment
+ reference the same pre-computed element. */
+ if (TREE_SIDE_EFFECTS (lse->expr))
+ {
+ tree ptr = gfc_build_addr_expr (NULL_TREE, lse->expr);
+ ptr = gfc_evaluate_now (ptr, &lse->pre);
+ lse->expr = build_fold_indirect_ref_loc (input_location, ptr);
+ }
+
+ gfc_se fin_se, size_se, desc_se;
+ gfc_init_se (&fin_se, NULL);
+ get_final_proc_ref (&fin_se, finalize_expr, NULL_TREE);
+ gfc_add_block_to_block (&final_block, &fin_se.pre);
+
+ gfc_init_se (&size_se, NULL);
+ get_elem_size (&size_se, finalize_expr, NULL_TREE);
+ gfc_add_block_to_block (&final_block, &size_se.pre);
+
+ gfc_init_se (&desc_se, NULL);
+ symbol_attribute attr;
+ gfc_clear_attr (&attr);
+ tree desc = gfc_conv_scalar_to_descriptor (&desc_se, lse->expr, attr);
+ gfc_add_block_to_block (&final_block, &desc_se.pre);
+ if (!POINTER_TYPE_P (TREE_TYPE (desc)))
+ desc = gfc_build_addr_expr (NULL_TREE, desc);
+
+ tree fcall = build_call_expr_loc (input_location, fin_se.expr, 3,
+ desc, size_se.expr,
+ boolean_false_node);
+ gfc_add_expr_to_block (&final_block, fcall);
+ gfc_add_block_to_block (&final_block, &desc_se.post);
+ gfc_add_block_to_block (&final_block, &size_se.post);
+ finalizable = true;
+ }
+ else
+ finalizable = gfc_add_finalizer_call (&final_block, finalize_expr);
+
gfc_free_expr (finalize_expr);
if (!finalizable)
