From 609ba636927811cddc74fb815cb18809c7d33565 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sun, 2 Jul 2023 22:14:19 +0200
Subject: [PATCH] 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/pr92178.f90: New test.
	* gfortran.dg/pr92178_2.f90: New test.

Co-authored-by: Steven G. Kargl <kargl@gcc.gnu.org>
---
 gcc/fortran/trans-expr.cc               | 52 ++++++++++++++--
 gcc/testsuite/gfortran.dg/pr92178.f90   | 83 +++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/pr92178_2.f90 | 46 ++++++++++++++
 3 files changed, 177 insertions(+), 4 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr92178.f90
 create mode 100644 gcc/testsuite/gfortran.dg/pr92178_2.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 30946ba3f63..16e8f037cfc 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,33 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	       && UNLIMITED_POLY (sym)
 	       && comp && (strcmp ("_copy", comp->name) == 0);

+  /* First scan argument list 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 +6708,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
@@ -6980,7 +7008,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 +7032,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 +7129,21 @@ 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 all actual argument expressions before deallocations are
+	 performed and the procedure is executed.  This ensures we conform
+	 to F2023:15.5.3, 15.5.4.  Create temporaries except for constants,
+	 variables, and functions returning pointers that can appear in a
+	 variable definition context.  */
+      if (e && fsym && force_eval_args
+	  && e->expr_type != EXPR_VARIABLE
+	  && !gfc_is_constant_expr (e)
+	  && (e->expr_type != EXPR_FUNCTION
+	      || !(gfc_expr_attr (e).pointer
+		   || gfc_expr_attr (e).proc_pointer)))
+	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/pr92178.f90 b/gcc/testsuite/gfortran.dg/pr92178.f90
new file mode 100644
index 00000000000..de3998d6b8c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr92178.f90
@@ -0,0 +1,83 @@
+! { 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)
+  if (allocated (a)) stop 11
+
+  a = [1, 2]
+  k = 1
+  call foo (allocated (a), size (a), test (k*a), a)
+  if (allocated (a)) stop 12
+
+  b% a = [1, 2]
+  call foo (allocated (b% a), size (b% a), test (b% a), b% a)
+  if (allocated (b% a)) stop 13
+
+  c = [3, 4]
+  call bar (allocated (c), size (c), test2 (c), 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)
+    logical, value :: alloc, tst
+    integer, value :: sz
+    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
+  end subroutine foo
+  !
+  logical function test (zz)
+    integer :: zz(2)
+    test = zz(2) == 2
+  end function test
+  !
+  subroutine bar (alloc, sz, tst, x)
+    logical, value :: alloc, tst
+    integer, value :: sz
+    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
+  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/pr92178_2.f90 b/gcc/testsuite/gfortran.dg/pr92178_2.f90
new file mode 100644
index 00000000000..bc9208dcf6d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr92178_2.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
--
2.35.3

