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

[Harald Anlauf <anlauf@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 1836 bytes --]

Hi Mikael,

Am 05.07.23 um 16:54 schrieb Mikael Morin:
> Here is an example, admittedly artificial.  Fails with the above change,
> but fails with master as well.
>
> program p
>    implicit none
>    type t
>      integer :: i
>    end type t
>    type u
>      class(t), allocatable :: ta(:)
>    end type u
>    type(u), allocatable, target :: 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

while it looks artificial, it is valid, and IMHO it is a beast...

I've played around and added another argument gfc_se *convse to
gfc_conv_class_to_class in an attempt to implement what I thought
you suggested (to get the .pre/.post separately), but in the end
this did not lead to working code.  And the tree-dump for your
example above is beyond what I can grasp.

I've noticed that my attempt does not properly handle the
parmse.post; at least this is what the above example shows:
there is a small part after the call to bar that should have
been executed before that call, which I attribute to .post.
But my attempts in moving that part regresses on a couple
of testcases with class and intent(out).  I am at a loss now.

I am attaching the latest version of my patch to give you or
Paul or others the opportunity to see what is wrong or add the
missing pieces.

Thanks for your help so far.

Harald


[-- Attachment #2: pr92178-v2.diff --]
[-- Type: text/x-patch, Size: 11003 bytes --]

From 989030fc04eacf97a034ab1f7ed85b932669f82d Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Wed, 5 Jul 2023 22:21:09 +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/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>
---
 gcc/fortran/trans-expr.cc                   | 54 +++++++++++--
 gcc/testsuite/gfortran.dg/intent_out_16.f90 | 89 +++++++++++++++++++++
 gcc/testsuite/gfortran.dg/intent_out_17.f90 | 46 +++++++++++
 gcc/testsuite/gfortran.dg/intent_out_18.f90 | 31 +++++++
 4 files changed, 215 insertions(+), 5 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/intent_out_16.f90
 create mode 100644 gcc/testsuite/gfortran.dg/intent_out_17.f90
 create mode 100644 gcc/testsuite/gfortran.dg/intent_out_18.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 30946ba3f63..7017b652d6e 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 00000000000..e8d635fed57
--- /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 00000000000..bc9208dcf6d
--- /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 00000000000..50f9948bf11
--- /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
-- 
2.35.3