fortran: Reorder array argument evaluation parts [PR92178]

In the case of an array actual arg passed to a polymorphic array dummy
with INTENT(OUT) attribute, reorder the argument evaluation code to
the following:
 - first evaluate arguments' values, and data references,
 - deallocate data references associated with an allocatable,
   intent(out) dummy,
 - create a class container using the freed data references.

The ordering used to be incorrect between the first two items,
when one argument was deallocated before a later argument evaluated
its expression depending on the former argument.
r14-2395-gb1079fc88f082d3c5b583c8822c08c5647810259 fixed it by treating
arguments associated with an allocatable, intent(out) dummy in a
separate, later block.  This, however, wasn't working either if the data
reference of such an argument was depending on its own content, as
the class container initialization was trying to use deallocated
content.

This change generates class container initialization code in a separate
block, so that it is moved after the deallocation block without moving
the rest of the argument evaluation code.

This alone is not sufficient to fix the problem, because the class
container generation code repeatedly uses the full expression of
the argument at a place where deallocation might have happened
already.  This is non-optimal, but may also be invalid, because the data
reference may depend on its own content.  In that case the expression
can't be evaluated after the data has been deallocated.

As in the scalar case previously treated, this is fixed by saving
the data reference to a pointer before any deallocation happens,
and then only refering to the pointer.  gfc_reset_vptr is updated
to take into account the already evaluated class container if it's
available.

Contrary to the scalar case, one hunk is needed to wrap the parameter
evaluation in a conditional, to avoid regressing in
optional_class_2.f90.  This used to be handled by the class wrapper
construction which wrapped the whole code in a conditional.  With
this change the class wrapper construction can't see the parameter
evaluation code, so the latter is updated with an additional handling
for optional arguments.

	PR fortran/92178

gcc/fortran/ChangeLog:

	* trans.h (gfc_reset_vptr): Add class_container argument.
	* trans-expr.cc (gfc_reset_vptr): Ditto.  If a valid vptr can
	be obtained through class_container argument, bypass evaluation
	of e.
	(gfc_conv_procedure_call):  Wrap the argument evaluation code
	in a conditional if the associated dummy is optional.  Evaluate
	the data reference to a pointer now, and replace later
	references with usage of the pointer.

gcc/testsuite/ChangeLog:

	* gfortran.dg/intent_out_21.f90: New test.

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 5169fbcd9741482a8ebe4b490c48c7f259f7a8d3..dbb04f8c434a3a776690d27fc8b3bc7812132600 100644 (file)
--- 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 82cdd69407325f36e7e5028505708eb7724f17ef..7b41e8912b48e252c745fdeff96528d3631e0cf7 100644 (file)
--- 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 (file)
index 0000000..5f61a54
--- /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