From e93452a5712e87ba624562ba7164b1e1394d18fb Mon Sep 17 00:00:00 2001
From: Mikael Morin <mikael@gcc.gnu.org>
Date: Fri, 14 Jul 2023 14:15:07 +0200
Subject: [PATCH] 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.
---
 gcc/fortran/trans-expr.cc                   | 18 ++++++++++++++++-
 gcc/testsuite/gfortran.dg/intent_out_19.f90 | 22 +++++++++++++++++++++
 2 files changed, 39 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/intent_out_19.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 7017b652d6e..b7e95e6d04d 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
diff --git a/gcc/testsuite/gfortran.dg/intent_out_19.f90 b/gcc/testsuite/gfortran.dg/intent_out_19.f90
new file mode 100644
index 00000000000..03036ed382a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_19.f90
@@ -0,0 +1,22 @@
+! { 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
+  class(*),  allocatable :: c
+  c = 3
+  call bar (allocated(c), c, allocated (c))
+  if (allocated (c)) stop 14
+contains
+  subroutine bar (alloc, x, alloc2)
+    logical :: alloc, alloc2
+    class(*), allocatable, intent(out) :: x(..)
+    if (allocated (x)) stop 5
+    if (.not. alloc)   stop 6
+    if (.not. alloc2)  stop 16
+  end subroutine bar
+end