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

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

[Harald Anlauf]

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

Dear all,

the attached patch fixes a long-standing issue with the
order of evaluation of procedure argument expressions and
deallocation of allocatable actual arguments passed to
allocatable dummies with intent(out) attribute.

It is based on an initial patch by Steve, handles issues
pointed out by Tobias, and includes a suggestion by Tobias
to scan the procedure arguments first to decide whether the
creation of temporaries is needed.

There is one unresolved issue left that might be more
general: it appears to affect character arguments (only)
in that quite often there still is no temporary generated.
I haven't found the reason why and would like to defer this,
unless someone has a good suggestion.

Regtested on x86_64-pc-linux-gnu. OK for mainline?

Thanks,
Harald


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr92178.diff --]
[-- Type: text/x-patch, Size: 9059 bytes --]

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

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

[Mikael Morin]

Hello,

Le 02/07/2023 à 22:38, Harald Anlauf via Fortran a écrit :
> Dear all,
> 
> the attached patch fixes a long-standing issue with the
> order of evaluation of procedure argument expressions and
> deallocation of allocatable actual arguments passed to
> allocatable dummies with intent(out) attribute.
> 
> It is based on an initial patch by Steve, handles issues
> pointed out by Tobias, and includes a suggestion by Tobias
> to scan the procedure arguments first to decide whether the
> creation of temporaries is needed.
> 
> There is one unresolved issue left that might be more
> general: it appears to affect character arguments (only)
> in that quite often there still is no temporary generated.
> I haven't found the reason why and would like to defer this,
> unless someone has a good suggestion.
> 
No problem, let's fix the easier parts first.

> Regtested on x86_64-pc-linux-gnu. OK for mainline?
> 
A few thing to double check below.

> pr92178.diff
> 
> 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
(...)
> @@ -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;
> +	}
> +    }
> +
The function is already big enough, would you mind outlining this to its 
own function?

>    /* 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);
>  		}
>  	    }
>  	}
These look good, but I'm surprised that there is no similar change at 
the 6819 line.
This is the class array actual vs class array dummy case.
It seems to be checked by the "bar" subroutine in your testcase, except 
that the intent(out) argument comes last there, whereas it was coming 
first with the original testcases in the PR.
Can you double check?

> @@ -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);
> +
I'm not sure about the guarding condition.
It looks like it may miss evaluation in some cases (one testcase below).
With a value dummy, it is always safe to evaluate to a temporary 
variable, and with a non-value dummy, parmse.expr contains a pointer, so 
it is safe as well to evaluate that to a temporary pointer?
At least a || fsym->attr.value condition is missing somewhere, but I 
think the condition can be reduced to this:
       if (e && fsym && force_eval_args
	  && !gfc_is_constant_expr (e))
Were there failures that drove to your above guarding conditions?


Mikael

PS: The testcase (as promised):

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

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

[Harald Anlauf]

Hi Mikael,

Am 03.07.23 um 13:46 schrieb Mikael Morin:
> A few thing to double check below.
>
>> 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
> (...)
>> @@ -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;
>> +    }
>> +    }
>> +
> The function is already big enough, would you mind outlining this to its
> own function?

This can be done.  At least it is not part of the monster loop.

>
>>    /* 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);
>>          }
>>          }
>>      }
> These look good, but I'm surprised that there is no similar change at
> the 6819 line.
> This is the class array actual vs class array dummy case.
> It seems to be checked by the "bar" subroutine in your testcase, except
> that the intent(out) argument comes last there, whereas it was coming
> first with the original testcases in the PR.
> Can you double check?

I believe I tried that before and encountered regressions.
The change

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 16e8f037cfc..43e013fa720 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6844,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 (&se->pre, tmp);
+                 gfc_add_expr_to_block (&dealloc_blk, tmp);
                 }

               /* The conversion does not repackage the reference to a class

regresses on:
gfortran.dg/class_array_16.f90
gfortran.dg/finalize_12.f90
gfortran.dg/optional_class_1.f90

A simplified testcase for further study:

program p
   implicit none
   class(*),  allocatable :: c(:)
   c = [3, 4]
   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

(This fails in a different place for the posted patch and for
the above trial change.  Need to go to the drawing board...)


>> @@ -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);
>> +
> I'm not sure about the guarding condition.
> It looks like it may miss evaluation in some cases (one testcase below).
> With a value dummy, it is always safe to evaluate to a temporary
> variable, and with a non-value dummy, parmse.expr contains a pointer, so
> it is safe as well to evaluate that to a temporary pointer?
> At least a || fsym->attr.value condition is missing somewhere, but I
> think the condition can be reduced to this:
>        if (e && fsym && force_eval_args
>        && !gfc_is_constant_expr (e))
> Were there failures that drove to your above guarding conditions?

It seems that your simpler version essentially behaves the same way,
at least as far as regtesting is concerned.

>
> Mikael
>
> PS: The testcase (as promised):
>
> 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

Indeed, this is a nice demonstration.

While playing, I was wondering whether the following code is conforming:

program p
   call s ((1))
contains
   subroutine s (x)
     integer :: x
     x = 42
   end subroutine
end

(It crashes with gfortran, but not with any foreign brand tested).

Harald

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

[Steve Kargl]

On Mon, Jul 03, 2023 at 10:49:36PM +0200, Harald Anlauf via Fortran wrote:
> 
> Indeed, this is a nice demonstration.
> 
> While playing, I was wondering whether the following code is conforming:
> 
> program p
>   call s ((1))
> contains
>   subroutine s (x)
>     integer :: x
>     x = 42
>   end subroutine
> end
> 
> (It crashes with gfortran, but not with any foreign brand tested).
> 

It's not conforming.  '(1)' is an expression and it cannot appear
in a variable definition condition.  I am not aware of any numbered
constraint tha would require a Fortran processor to generate an
error.

-- 
Steve

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

[Mikael Morin]

Le 04/07/2023 à 01:56, Steve Kargl a écrit :
> On Mon, Jul 03, 2023 at 10:49:36PM +0200, Harald Anlauf via Fortran wrote:
>>
>> Indeed, this is a nice demonstration.
>>
>> While playing, I was wondering whether the following code is conforming:
>>
>> program p
>>    call s ((1))
>> contains
>>    subroutine s (x)
>>      integer :: x
>>      x = 42
>>    end subroutine
>> end
>>
>> (It crashes with gfortran, but not with any foreign brand tested).
>>
> 
> It's not conforming.  '(1)' is an expression and it cannot appear
> in a variable definition condition.  I am not aware of any numbered
> constraint tha would require a Fortran processor to generate an
> error.
> 

I think you would be right if X had INTENT(OUT) or INTENT(INOUT) attribute.
This is F2023, 15.5.2.4 (no mention of variable definition context here):
> If a dummy argument has INTENT (OUT) or INTENT (INOUT), the actual argument shall be definable. 

However, with unspecified intent, I can't find the rule explicitly 
forbidding the above example.
I'm tempted to say it is conforming.

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

[Mikael Morin]

Le 03/07/2023 à 22:49, Harald Anlauf a écrit :
> Hi Mikael,
> 
> Am 03.07.23 um 13:46 schrieb Mikael Morin:
>> These look good, but I'm surprised that there is no similar change at
>> the 6819 line.
>> This is the class array actual vs class array dummy case.
>> It seems to be checked by the "bar" subroutine in your testcase, except
>> that the intent(out) argument comes last there, whereas it was coming
>> first with the original testcases in the PR.
>> Can you double check?
> 
> I believe I tried that before and encountered regressions.
> The change
> 
> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
> index 16e8f037cfc..43e013fa720 100644
> --- a/gcc/fortran/trans-expr.cc
> +++ b/gcc/fortran/trans-expr.cc
> @@ -6844,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 (&se->pre, tmp);
> +                 gfc_add_expr_to_block (&dealloc_blk, tmp);
>                  }
> 
>                /* The conversion does not repackage the reference to a 
> class
> 
> regresses on:
> gfortran.dg/class_array_16.f90
> gfortran.dg/finalize_12.f90
> gfortran.dg/optional_class_1.f90
> 
> A simplified testcase for further study:
> 
> program p
>    implicit none
>    class(*),  allocatable :: c(:)
>    c = [3, 4]
>    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
> 
> (This fails in a different place for the posted patch and for
> the above trial change.  Need to go to the drawing board...)
> 
I've had a quick look.

The code originally generated looks like:

     D.4343 = (void *[0:] * restrict) c._data.data != 0B;
     if (c._data.data != 0B)
       // free c._data.data
     c._data.data = 0B;
     ...
     class.3._data = c._data;
     ...
     D.4345 = (void *[0:] * restrict) c._data.data != 0B;
     bar (&D.4343, &class.3, &D.4345);

this fails because D.4345 has the wrong value.
With your change, it becomes:

     D.4343 = (void *[0:] * restrict) c._data.data != 0B;
     ...
     class.3._data = c._data;
     ...
     D.4345 = (void *[0:] * restrict) c._data.data != 0B;
     if (c._data.data != 0B)
       // free c._data.data
     c._data.data = 0B;
     bar (&D.4343, &class.3, &D.4345);

and then it is class.3._data that has the wrong value.
So basically the initialization of class.3 should move with the 
deallocation.

I can reproduce a similar problem with your unmodified patch on the 
following variant:

program p
   implicit none
   class(*),  allocatable :: c
   c = 3
   call bar (c, allocated (c))
   if (allocated (c)) stop 14
contains
   subroutine bar (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

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

[Steve Kargl]

On Tue, Jul 04, 2023 at 11:26:26AM +0200, Mikael Morin wrote:
> Le 04/07/2023 à 01:56, Steve Kargl a écrit :
> > On Mon, Jul 03, 2023 at 10:49:36PM +0200, Harald Anlauf via Fortran wrote:
> > > 
> > > Indeed, this is a nice demonstration.
> > > 
> > > While playing, I was wondering whether the following code is conforming:
> > > 
> > > program p
> > >    call s ((1))
> > > contains
> > >    subroutine s (x)
> > >      integer :: x
> > >      x = 42
> > >    end subroutine
> > > end
> > > 
> > > (It crashes with gfortran, but not with any foreign brand tested).
> > > 
> > 
> > It's not conforming.  '(1)' is an expression and it cannot appear
> > in a variable definition condition.  I am not aware of any numbered
> > constraint tha would require a Fortran processor to generate an
> > error.
> > 
> 
> I think you would be right if X had INTENT(OUT) or INTENT(INOUT) attribute.
> This is F2023, 15.5.2.4 (no mention of variable definition context here):
> > If a dummy argument has INTENT (OUT) or INTENT (INOUT), the actual
> > argument shall be definable.
> 
> However, with unspecified intent, I can't find the rule explicitly
> forbidding the above example.
> I'm tempted to say it is conforming.

I thought it was in Sec. 19, but failed to locate any prohibition.
The best I can find is

23-007r1.pdf

8.5.10 INTENT attribute

pg. 114 (following Note 1) 

If no INTENT attribute is specified for a dummy argument,
its use is subject to the limitations of its effective
argument (15.5.2).

pg. 115 (within Note 4, so non-normative text)

INTENT (INOUT) is not equivalent to omitting the INTENT attribute.
The actual argument corresponding to an INTENT (INOUT) dummy argument
is always required to be definable, while an actual argument corresponding
to a dummy argument without an INTENT attribute need be definable only
if the dummy argument is actually redefined.

Searching for "definable" does not lead to a prohibition of the form
"An expression is not definable."

-- 
Steve

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

[Harald Anlauf]

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

Hi Mikael, all,

I think I've found it: there is a call to gfc_conv_class_to_class
that - according to a comment - does a repackaging to a class array.
Deferring that repackaging along with the deallocation not only fixes
the regression, but also the cases I tested.

Attached is a "sneak preview", hoping that the experts (Paul, Mikael,
...) can tell if I am going down the wrong road.

I'll wrap up all pieces and resubmit when the dust settles.

We can then address the other findings later.

Harald

Am 04.07.23 um 15:35 schrieb Mikael Morin:
> Le 03/07/2023 à 22:49, Harald Anlauf a écrit :
>> Hi Mikael,
>>
>> Am 03.07.23 um 13:46 schrieb Mikael Morin:
>>> These look good, but I'm surprised that there is no similar change at
>>> the 6819 line.
>>> This is the class array actual vs class array dummy case.
>>> It seems to be checked by the "bar" subroutine in your testcase, except
>>> that the intent(out) argument comes last there, whereas it was coming
>>> first with the original testcases in the PR.
>>> Can you double check?
>>
>> I believe I tried that before and encountered regressions.
>> The change
>>
>> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
>> index 16e8f037cfc..43e013fa720 100644
>> --- a/gcc/fortran/trans-expr.cc
>> +++ b/gcc/fortran/trans-expr.cc
>> @@ -6844,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 (&se->pre, tmp);
>> +                 gfc_add_expr_to_block (&dealloc_blk, tmp);
>>                  }
>>
>>                /* The conversion does not repackage the reference to a
>> class
>>
>> regresses on:
>> gfortran.dg/class_array_16.f90
>> gfortran.dg/finalize_12.f90
>> gfortran.dg/optional_class_1.f90
>>
>> A simplified testcase for further study:
>>
>> program p
>>    implicit none
>>    class(*),  allocatable :: c(:)
>>    c = [3, 4]
>>    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
>>
>> (This fails in a different place for the posted patch and for
>> the above trial change.  Need to go to the drawing board...)
>>
> I've had a quick look.
>
> The code originally generated looks like:
>
>      D.4343 = (void *[0:] * restrict) c._data.data != 0B;
>      if (c._data.data != 0B)
>        // free c._data.data
>      c._data.data = 0B;
>      ...
>      class.3._data = c._data;
>      ...
>      D.4345 = (void *[0:] * restrict) c._data.data != 0B;
>      bar (&D.4343, &class.3, &D.4345);
>
> this fails because D.4345 has the wrong value.
> With your change, it becomes:
>
>      D.4343 = (void *[0:] * restrict) c._data.data != 0B;
>      ...
>      class.3._data = c._data;
>      ...
>      D.4345 = (void *[0:] * restrict) c._data.data != 0B;
>      if (c._data.data != 0B)
>        // free c._data.data
>      c._data.data = 0B;
>      bar (&D.4343, &class.3, &D.4345);
>
> and then it is class.3._data that has the wrong value.
> So basically the initialization of class.3 should move with the
> deallocation.
>
> I can reproduce a similar problem with your unmodified patch on the
> following variant:
>
> program p
>    implicit none
>    class(*),  allocatable :: c
>    c = 3
>    call bar (c, allocated (c))
>    if (allocated (c)) stop 14
> contains
>    subroutine bar (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
>
>
>

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

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 16e8f037cfc..a68c8d33acc 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6804,6 +6804,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_repackage = false;
 
 	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		 allocated on entry, it must be deallocated.  */
@@ -6844,7 +6845,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_repackage = true;
 		}
 
 	      /* The conversion does not repackage the reference to a class
@@ -6858,6 +6860,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_repackage)
+		gfc_add_block_to_block (&dealloc_blk, &parmse.pre);
 	    }
 	  else
 	    {
@@ -7131,17 +7137,12 @@ 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
+	 evaluate 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.  */
+	 to F2023:15.5.3, 15.5.4.  May create temporaries when needed.  */
       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)))
+	  && 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)

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

[Mikael Morin]

Le 04/07/2023 à 21:00, Harald Anlauf a écrit :
> Hi Mikael, all,
> 
> I think I've found it: there is a call to gfc_conv_class_to_class
> that - according to a comment - does a repackaging to a class array.
> Deferring that repackaging along with the deallocation not only fixes
> the regression, but also the cases I tested.
> 
> Attached is a "sneak preview", hoping that the experts (Paul, Mikael,
> ...) can tell if I am going down the wrong road.
> 
I think that's it mostly.  There is one last thing that I am not sure...

> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
> index 16e8f037cfc..a68c8d33acc 100644
> --- a/gcc/fortran/trans-expr.cc
> +++ b/gcc/fortran/trans-expr.cc
> @@ -6858,6 +6860,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_repackage)
> +		gfc_add_block_to_block (&dealloc_blk, &parmse.pre);
>  	    }
>  	  else
>  	    {

... whether you will not be deferring too much here.  That is parmse.pre 
contains both the argument evaluation and the class container setup from 
gfc_conv_class_to_class.  If it's safe to defer both, that's fine, 
otherwise a separate gfc_se struct should be passed to 
gfc_conv_class_to_class so that only the latter part can be deferred.
Need to think of an example...

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

[Mikael Morin]

Le 04/07/2023 à 21:37, Mikael Morin a écrit :
> Le 04/07/2023 à 21:00, Harald Anlauf a écrit :
>> Hi Mikael, all,
>>
>> I think I've found it: there is a call to gfc_conv_class_to_class
>> that - according to a comment - does a repackaging to a class array.
>> Deferring that repackaging along with the deallocation not only fixes
>> the regression, but also the cases I tested.
>>
>> Attached is a "sneak preview", hoping that the experts (Paul, Mikael,
>> ...) can tell if I am going down the wrong road.
>>
> I think that's it mostly.  There is one last thing that I am not sure...
> 
>> diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
>> index 16e8f037cfc..a68c8d33acc 100644
>> --- a/gcc/fortran/trans-expr.cc
>> +++ b/gcc/fortran/trans-expr.cc
>> @@ -6858,6 +6860,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_repackage)
>> +        gfc_add_block_to_block (&dealloc_blk, &parmse.pre);
>>          }
>>        else
>>          {
> 
> ... whether you will not be deferring too much here.  That is parmse.pre 
> contains both the argument evaluation and the class container setup from 
> gfc_conv_class_to_class.  If it's safe to defer both, that's fine, 
> otherwise a separate gfc_se struct should be passed to 
> gfc_conv_class_to_class so that only the latter part can be deferred.
> Need to think of an example...

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

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

[Harald Anlauf]

[-- 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

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

[Mikael Morin]

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

Le 05/07/2023 à 22:36, Harald Anlauf a écrit :
> 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.
> 
All that I can see after the call is a reassignment of the original data 
and vptr pointers from the temporary class container.  They seem at 
their right place there. But part of the expression seems to be 
evaluated again, instead of being picked up from parmse.expr.

> 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.
> 
I'm attaching what I have (lightly) tested so far, which doesn't work.
It seems gfc_conv_class_to_class reevaluates part of the original 
expression, which is not correct after deallocation.
Will have a look again tonight.

Mikael


[-- Attachment #2: pr92178_tmp.diff --]
[-- Type: text/x-patch, Size: 1386 bytes --]

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ebef1a36577..54249c9c615 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6819,9 +6819,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),
@@ -6831,9 +6835,10 @@ 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
 	    {

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

[Harald Anlauf]

Hi Mikael,

Am 07.07.23 um 14:21 schrieb Mikael Morin:
> I'm attaching what I have (lightly) tested so far, which doesn't work.
> It seems gfc_conv_class_to_class reevaluates part of the original
> expression, which is not correct after deallocation.

this looks much more elegant than my attempt that passed an additional
argument to gfc_conv_class_to_class, to achieve what your patch does.

> Will have a look again tonight.

Great.

Harald

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

[Mikael Morin]

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

Hello,

Le 07/07/2023 à 20:23, Harald Anlauf a écrit :
> Hi Mikael,
> 
> Am 07.07.23 um 14:21 schrieb Mikael Morin:
>> I'm attaching what I have (lightly) tested so far, which doesn't work.
>> It seems gfc_conv_class_to_class reevaluates part of the original
>> expression, which is not correct after deallocation.
> 
> this looks much more elegant than my attempt that passed an additional
> argument to gfc_conv_class_to_class, to achieve what your patch does.
> 
>> Will have a look again tonight.
> 
> Great.
> 
> Harald
> 

here is what I'm finally coming to.  This patch fixes my example, but is 
otherwise untested.
The patch has grown enough that I'm tempted to fix my example 
separately, in its own commit.

Mikael

[-- Attachment #2: pr92178_tmp2.diff --]
[-- Type: text/x-patch, Size: 7052 bytes --]

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e7c51bae052..1c2af55d436 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3271,6 +3271,7 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
   gfc_add_block_to_block (block, &se.pre);
   info->descriptor = se.expr;
   ss_info->string_length = se.string_length;
+  ss_info->class_container = se.class_container;
 
   if (base)
     {
@@ -7687,6 +7688,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  else if (deferred_array_component)
 	    se->string_length = ss_info->string_length;
 
+	  se->class_container = ss_info->class_container;
+
 	  gfc_free_ss_chain (ss);
 	  return;
 	}
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ebef1a36577..01386bceaeb 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -529,24 +529,10 @@ 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.  */
-
-void
-gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
+static void
+reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_expr)
 {
-  gfc_symbol *vtab;
-  tree vptr;
-  tree vtable;
-  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);
+  tree vptr = gfc_get_vptr_from_expr (class_expr);
 
   /* If a vptr is not found, we can do nothing more.  */
   if (vptr == NULL_TREE)
@@ -556,6 +542,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;
@@ -568,6 +557,24 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
 }
 
 
+/* Reset the vptr to the declared type, e.g. after deallocation.  */
+
+void
+gfc_reset_vptr (stmtblock_t *block, gfc_expr *e)
+{
+  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);
+  reset_vptr (block, e, se.expr);
+}
+
+
 /* Reset the len for unlimited polymorphic objects.  */
 
 void
@@ -1266,6 +1273,8 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 
       slen = build_zero_cst (size_type_node);
     }
+  else if (parmse->class_container != NULL_TREE)
+    tmp = parmse->class_container;
   else
     {
       /* Remove everything after the last class reference, convert the
@@ -3078,6 +3087,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	  return;
 	}
 
+      if (sym->ts.type == BT_CLASS
+	  && sym->attr.class_ok
+	  && sym->ts.u.derived->attr.is_class)
+	se->class_container = se->expr;
+
       /* Dereference the expression, where needed.  */
       se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
 					    is_classarray);
@@ -3135,6 +3149,15 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	    conv_parent_component_references (se, ref);
 
 	  gfc_conv_component_ref (se, ref);
+
+	  if (ref->u.c.component->ts.type == BT_CLASS
+	      && ref->u.c.component->attr.class_ok
+	      && ref->u.c.component->ts.u.derived->attr.is_class)
+	    se->class_container = se->expr;
+	  else if (!(ref->u.c.sym->attr.flavor == FL_DERIVED
+		     && ref->u.c.sym->attr.is_class))
+	    se->class_container = NULL_TREE;
+		
 	  if (!ref->next && ref->u.c.sym->attr.codimension
 	      && se->want_pointer && se->descriptor_only)
 	    return;
@@ -6784,6 +6807,21 @@ 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.  */
+		  tree t = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+		  t = gfc_evaluate_now (t, &parmse.pre);
+		  parmse.expr = build_fold_indirect_ref_loc (input_location, t);
+
+		  if (parmse.class_container != NULL_TREE)
+		    {
+		      t = gfc_build_addr_expr (NULL_TREE, parmse.class_container);
+		      t = gfc_evaluate_now (t, &parmse.pre);
+		      parmse.class_container = build_fold_indirect_ref_loc (input_location, t);
+		    }
+
 		  gfc_init_block  (&block);
 		  ptr = parmse.expr;
 		  ptr = gfc_class_data_get (ptr);
@@ -6797,7 +6835,10 @@ 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);
+		  if (parmse.class_container == NULL_TREE)
+		    gfc_reset_vptr (&block, e);
+		  else
+		    reset_vptr (&block, e, parmse.class_container);
 
 		  if (fsym->attr.optional
 		      && e->expr_type == EXPR_VARIABLE
@@ -6819,9 +6860,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),
@@ -6831,9 +6876,10 @@ 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 0c8d004736d..9254de733de 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -57,6 +57,10 @@ typedef struct gfc_se
      here.  */
   tree class_vptr;
 
+  /* When expr is a reference to class subobject, store the class object
+     here.  */
+  tree class_container;
+
   /* Whether expr is a reference to an unlimited polymorphic object.  */
   unsigned unlimited_polymorphic:1;
 
@@ -263,6 +267,7 @@ typedef struct gfc_ss_info
   gfc_ss_type type;
   gfc_expr *expr;
   tree string_length;
+  tree class_container;
 
   union
   {

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

[Harald Anlauf]

Hi Mikael,

Am 08.07.23 um 14:07 schrieb Mikael Morin:
> here is what I'm finally coming to.  This patch fixes my example, but is
> otherwise untested.
> The patch has grown enough that I'm tempted to fix my example
> separately, in its own commit.

alright.  I've interpreted this as a green light for v2 of my patch
and pushed it as r14-2395-gb1079fc88f082d

https://gcc.gnu.org/g:b1079fc88f082d3c5b583c8822c08c5647810259

so that you can build upon it.

> Mikael

Thanks,
Harald