Fortran: fixes for procedures with ALLOCATABLE,INTENT(OUT) arguments [PR92178]

gcc/fortran/ChangeLog:

	PR fortran/92178
	* trans-expr.cc (gfc_conv_procedure_call): Check procedures for
	allocatable dummy arguments with INTENT(OUT) and move deallocation
	of actual arguments after evaluation of argument expressions before
	the procedure is executed.

gcc/testsuite/ChangeLog:

	PR fortran/92178
	* gfortran.dg/intent_out_16.f90: New test.
	* gfortran.dg/intent_out_17.f90: New test.
	* gfortran.dg/intent_out_18.f90: New test.

Co-authored-by: Steven G. Kargl <kargl@gcc.gnu.org>

4 files changed, 215 insertions, 5 deletions

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 30946ba..7017b65 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6085,9 +6085,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   else
     info = NULL;
 
-  stmtblock_t post, clobbers;
+  stmtblock_t post, clobbers, dealloc_blk;
   gfc_init_block (&post);
   gfc_init_block (&clobbers);
+  gfc_init_block (&dealloc_blk);
   gfc_init_interface_mapping (&mapping);
   if (!comp)
     {
@@ -6117,6 +6118,32 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	       && UNLIMITED_POLY (sym)
 	       && comp && (strcmp ("_copy", comp->name) == 0);
 
+  /* Scan for allocatable actual arguments passed to allocatable dummy
+     arguments with INTENT(OUT).  As the corresponding actual arguments are
+     deallocated before execution of the procedure, we evaluate actual
+     argument expressions to avoid problems with possible dependencies.  */
+  bool force_eval_args = false;
+  gfc_formal_arglist *tmp_formal;
+  for (arg = args, tmp_formal = formal; arg != NULL;
+       arg = arg->next, tmp_formal = tmp_formal ? tmp_formal->next : NULL)
+    {
+      e = arg->expr;
+      fsym = tmp_formal ? tmp_formal->sym : NULL;
+      if (e && fsym
+	  && e->expr_type == EXPR_VARIABLE
+	  && fsym->attr.intent == INTENT_OUT
+	  && (fsym->ts.type == BT_CLASS && fsym->attr.class_ok
+	      ? CLASS_DATA (fsym)->attr.allocatable
+	      : fsym->attr.allocatable)
+	  && e->symtree
+	  && e->symtree->n.sym
+	  && gfc_variable_attr (e, NULL).allocatable)
+	{
+	  force_eval_args = true;
+	  break;
+	}
+    }
+
   /* Evaluate the arguments.  */
   for (arg = args, argc = 0; arg != NULL;
        arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
@@ -6680,7 +6707,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      else
 			tmp = gfc_finish_block (&block);
 
-		      gfc_add_expr_to_block (&se->pre, tmp);
+		      gfc_add_expr_to_block (&dealloc_blk, tmp);
 		    }
 
 		  /* A class array element needs converting back to be a
@@ -6776,6 +6803,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      /* Pass a class array.  */
 	      parmse.use_offset = 1;
 	      gfc_conv_expr_descriptor (&parmse, e);
+	      bool defer_to_dealloc_blk = false;
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		 allocated on entry, it must be deallocated.  */
@@ -6816,7 +6844,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		  else
 		    tmp = gfc_finish_block (&block);
 
-		  gfc_add_expr_to_block (&se->pre, tmp);
+		  gfc_add_expr_to_block (&dealloc_blk, tmp);
+		  defer_to_dealloc_blk = true;
 		}
 
 	      /* The conversion does not repackage the reference to a class
@@ -6830,6 +6859,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     && e->symtree->n.sym->attr.optional,
 				     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);
 	    }
 	  else
 	    {
@@ -6980,7 +7013,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 					build_empty_stmt (input_location));
 		      }
 		    if (tmp != NULL_TREE)
-		      gfc_add_expr_to_block (&se->pre, tmp);
+		      gfc_add_expr_to_block (&dealloc_blk, tmp);
 		  }
 
 		  tmp = parmse.expr;
@@ -7004,7 +7037,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     void_type_node,
 				     gfc_conv_expr_present (e->symtree->n.sym),
 				       tmp, build_empty_stmt (input_location));
-		  gfc_add_expr_to_block (&se->pre, tmp);
+		  gfc_add_expr_to_block (&dealloc_blk, tmp);
 		}
 	    }
 	}
@@ -7101,6 +7134,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    }
 	}
 
+      /* If any actual argument of the procedure is allocatable and passed
+	 to an allocatable dummy with INTENT(OUT), we conservatively
+	 evaluate actual argument expressions before deallocations are
+	 performed and the procedure is executed.  May create temporaries.
+	 This ensures we conform to F2023:15.5.3, 15.5.4.  */
+      if (e && fsym && force_eval_args
+	  && fsym->attr.intent != INTENT_OUT
+	  && !gfc_is_constant_expr (e))
+	parmse.expr = gfc_evaluate_now (parmse.expr, &parmse.pre);
+
       if (fsym && need_interface_mapping && e)
 	gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
 
@@ -7499,6 +7542,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       vec_safe_push (arglist, parmse.expr);
     }
 
+  gfc_add_block_to_block (&se->pre, &dealloc_blk);
   gfc_add_block_to_block (&se->pre, &clobbers);
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
 
diff --git a/gcc/testsuite/gfortran.dg/intent_out_16.f90 b/gcc/testsuite/gfortran.dg/intent_out_16.f90
new file mode 100644
index 0000000..e8d635f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_16.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! PR fortran/92178
+! Re-order argument deallocation
+
+program p
+  implicit none
+  integer,   allocatable :: a(:)
+  class(*),  allocatable :: c(:)
+  type t
+    integer, allocatable :: a(:)
+  end type t
+  type(t) :: b
+  integer :: k = -999
+
+  ! Test based on original PR
+  a = [1]
+  call assign (a, (max(a(1),0)))
+  if (allocated (a)) stop 9
+  if (k /= 1)        stop 10
+
+  ! Additional variations based on suggestions by Tobias Burnus
+  ! to check that argument expressions are evaluated early enough
+  a = [1, 2]
+  call foo (allocated (a), size (a), test (a), a, allocated (a))
+  if (allocated (a)) stop 11
+
+  a = [1, 2]
+  k = 1
+  call foo (allocated (a), size (a), test (k*a), a, allocated (a))
+  if (allocated (a)) stop 12
+
+  b% a = [1, 2]
+  call foo (allocated (b% a), size (b% a), test (b% a), b% a, allocated (b% a))
+  if (allocated (b% a)) stop 13
+
+  c = [3, 4]
+  call bar (allocated (c), size (c), test2 (c), c, &
+            allocated (c), size (c), test2 (c)     )
+  if (allocated (c)) stop 14
+
+contains
+
+  subroutine assign (a, i)
+    integer, allocatable, intent(out) :: a(:) 
+    integer,              value  :: i
+    k = i
+  end subroutine
+
+  subroutine foo (alloc, sz, tst, x, alloc2)
+    logical, value :: alloc, tst
+    integer, value :: sz
+    logical        :: alloc2
+    integer, allocatable, intent(out) :: x(:)
+    if (allocated (x)) stop 1
+    if (.not. alloc)   stop 2
+    if (sz /= 2)       stop 3
+    if (.not. tst)     stop 4
+    if (.not. alloc2)  stop 15
+  end subroutine foo
+  !
+  logical function test (zz)
+    integer :: zz(2)
+    test = zz(2) == 2
+  end function test
+  !
+  subroutine bar (alloc, sz, tst, x, alloc2, sz2, tst2)
+    logical, value :: alloc, tst, alloc2, tst2
+    integer, value :: sz, sz2
+    class(*), allocatable, intent(out) :: x(:)
+    if (allocated (x)) stop 5
+    if (.not. alloc)   stop 6
+    if (sz /= 2)       stop 7
+    if (.not. tst)     stop 8
+    if (.not. alloc2)  stop 16
+    if (sz2 /= 2)      stop 17
+    if (.not. tst2)    stop 18
+  end subroutine bar
+  !
+  logical function test2 (zz)
+    class(*), intent(in) :: zz(:)
+    select type (zz)
+    type is (integer)
+       test2 = zz(2) == 4
+    class default
+       stop 99
+    end select
+  end function test2
+end
diff --git a/gcc/testsuite/gfortran.dg/intent_out_17.f90 b/gcc/testsuite/gfortran.dg/intent_out_17.f90
new file mode 100644
index 0000000..bc9208d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_17.f90
@@ -0,0 +1,46 @@
+! { dg-do run }
+!
+! PR fortran/92178
+! Contributed by Tobias Burnus
+
+program foo
+  implicit none (type, external)
+
+  type t
+  end type t
+
+  type, extends(t) :: t2
+  end type t2
+
+  type(t2) :: x2
+  class(t), allocatable :: aa
+
+  call check_intentout_false(allocated(aa), aa, &
+                             allocated(aa))
+  if (allocated(aa)) stop 1
+
+  allocate(t2 :: aa)
+  if (.not.allocated(aa)) stop 2
+  if (.not.same_type_as(aa, x2)) stop 3
+  call check_intentout_true(allocated(aa), (same_type_as(aa, x2)), aa, &
+                            allocated(aa), (same_type_as(aa, x2)))
+  if (allocated(aa)) stop 4
+
+contains
+  subroutine check_intentout_false(alloc1, yy, alloc2)
+    logical, value :: alloc1, alloc2
+    class(t), allocatable, intent(out) :: yy
+    if (allocated(yy)) stop 11
+    if (alloc1) stop 12
+    if (alloc2) stop 13
+  end subroutine check_intentout_false
+  subroutine check_intentout_true(alloc1, same1, zz, alloc2, same2)
+    logical, value :: alloc1, alloc2, same1, same2
+    class(t), allocatable, intent(out) :: zz
+    if (allocated(zz)) stop 21
+    if (.not.alloc1) stop 22
+    if (.not.alloc2) stop 23
+    if (.not.same1) stop 24
+    if (.not.same2) stop 25
+  end subroutine check_intentout_true
+end program
diff --git a/gcc/testsuite/gfortran.dg/intent_out_18.f90 b/gcc/testsuite/gfortran.dg/intent_out_18.f90
new file mode 100644
index 0000000..50f9948
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_18.f90
@@ -0,0 +1,31 @@
+! { dg-do run }
+!
+! PR fortran/92178
+! Contributed by Mikael Morin
+
+program p
+  implicit none
+  type t
+    integer :: i
+    integer, pointer :: pi
+  end type t
+  integer, target :: j
+  type(t), allocatable :: ta
+  j = 1
+  ta = t(2, j)
+  call assign(ta, id(ta%pi))
+  if (ta%i /= 1) stop 1
+  if (associated(ta%pi)) stop 2
+contains
+  subroutine assign(a, b)
+    type(t), intent(out), allocatable :: a
+    integer, intent(in) , value       :: b
+    allocate(a)
+    a%i = b
+    a%pi => null()
+  end subroutine assign
+  function id(a)
+    integer, pointer :: id, a
+    id => a
+  end function id
+end program p