Fortran: Fix memory problems with assumed rank formal args [PR98342].

2021-02-24  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/98342
	* trans-expr.c (gfc_conv_derived_to_class): Add optional arg.
	'derived_array' to hold the fixed, parmse expr in the case of
	assumed rank formal arguments. Deal with optional arguments.
	(gfc_conv_procedure_call): Null 'derived' array for each actual
	argument. Add its address to the call to gfc_conv_derived_to_
	class. Access the 'data' field of scalar descriptors before
	deallocating allocatable components. Also strip NOPs before the
	calls to gfc_deallocate_alloc_comp. Use 'derived' array as the
	input to gfc_deallocate_alloc_comp if it is available.
	* trans.h : Include the optional argument 'derived_array' to
	the prototype of gfc_conv_derived_to_class. The default value
	is NULL_TREE.

gcc/testsuite/
	PR fortran/98342
	* gfortran.dg/assumed_rank_21.f90 : New test.

3 files changed, 131 insertions, 7 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e614924..85c16d7 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -613,11 +613,15 @@ class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
    class object of the 'declared' type.  If vptr is not NULL, this is
    used for the temporary class object.
    optional_alloc_ptr is false when the dummy is neither allocatable
-   nor a pointer; that's only relevant for the optional handling.  */
+   nor a pointer; that's only relevant for the optional handling.
+   The optional argument 'derived_array' is used to preserve the parmse
+   expression for deallocation of allocatable components. Assumed rank
+   formal arguments made this necessary.  */
 void
 gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 			   gfc_typespec class_ts, tree vptr, bool optional,
-			   bool optional_alloc_ptr)
+			   bool optional_alloc_ptr,
+			   tree *derived_array)
 {
   gfc_symbol *vtab;
   tree cond_optional = NULL_TREE;
@@ -747,6 +751,13 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	    {
 	      gcc_assert (class_ts.u.derived->components->as->type
 			  == AS_ASSUMED_RANK);
+	      if (derived_array
+		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
+		{
+		  *derived_array = gfc_create_var (TREE_TYPE (parmse->expr),
+						   "array");
+		  gfc_add_modify (&block, *derived_array , parmse->expr);
+		}
 	      class_array_data_assign (&block, ctree, parmse->expr, false);
 	    }
 	  else
@@ -765,6 +776,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 
 	      gfc_init_block (&block);
 	      gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
+	      if (derived_array && *derived_array != NULL_TREE)
+		gfc_conv_descriptor_data_set (&block, *derived_array,
+					      null_pointer_node);
 
 	      tmp = build3_v (COND_EXPR, cond_optional, tmp,
 			      gfc_finish_block (&block));
@@ -5665,6 +5679,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
     {
       bool finalized = false;
       bool non_unity_length_string = false;
+      tree derived_array = NULL_TREE;
 
       e = arg->expr;
       fsym = formal ? formal->sym : NULL;
@@ -5770,7 +5785,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     && e->expr_type == EXPR_VARIABLE
 				     && e->symtree->n.sym->attr.optional,
 				     CLASS_DATA (fsym)->attr.class_pointer
-				     || CLASS_DATA (fsym)->attr.allocatable);
+				     || CLASS_DATA (fsym)->attr.allocatable,
+				     &derived_array);
 	}
       else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS
 	       && gfc_expr_attr (e).flavor != FL_PROCEDURE)
@@ -6595,6 +6611,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 					&& parm_rank == 0
 					&& parmse.loop;
 
+	      /* Scalars passed to an assumed rank argument are converted to
+		 a descriptor. Obtain the data field before deallocating any
+		 allocatable components.  */
+	      if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		tmp = gfc_conv_descriptor_data_get (tmp);
+
 	      if (scalar_res_outside_loop)
 		{
 		  /* Go through the ss chain to find the argument and use
@@ -6610,9 +6632,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      }
 		}
 
-	      if ((e->ts.type == BT_CLASS
-		   && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
-		  || e->ts.type == BT_DERIVED)
+	      STRIP_NOPS (tmp);
+
+	      if (derived_array != NULL_TREE)
+		tmp = gfc_deallocate_alloc_comp (e->ts.u.derived,
+						 derived_array,
+						 parm_rank);
+	      else if ((e->ts.type == BT_CLASS
+			&& GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+		       || e->ts.type == BT_DERIVED)
 		tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
 						 parm_rank);
 	      else if (e->ts.type == BT_CLASS)
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 1e4ab39..44cbfb6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -452,7 +452,7 @@ bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
 
 void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
-				bool);
+				bool, tree *derived_array = NULL);
 void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
 			      bool, bool);
 
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_21.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_21.f90
new file mode 100644
index 0000000..ef5edbfb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_21.f90
@@ -0,0 +1,96 @@
+! { dg-do run }
+!
+! Test the fix for PR98342.
+!
+! Contributed by Martin Stein  <mscfd@gmx.net>
+!
+module mod
+  implicit none
+  private
+  public get_tuple, sel_rank1, sel_rank2, sel_rank3
+
+  type, public :: tuple
+  integer, dimension(:), allocatable :: t
+end type tuple
+
+contains
+
+function sel_rank1(x) result(s)
+  character(len=:), allocatable :: s
+  type(tuple), dimension(..), intent(in) :: x
+  select rank (x)
+    rank (0)
+      s = '10'
+    rank (1)
+      s = '11'
+    rank default
+      s = '?'
+  end select
+end function sel_rank1
+
+function sel_rank2(x) result(s)
+  character(len=:), allocatable :: s
+  class(tuple), dimension(..), intent(in) :: x
+  select rank (x)
+    rank (0)
+      s = '20'
+    rank (1)
+      s = '21'
+    rank default
+      s = '?'
+  end select
+end function sel_rank2
+
+function sel_rank3(x) result(s)
+  character(len=:), allocatable :: s
+  class(*), dimension(..), intent(in) :: x
+  select rank (x)
+    rank (0)
+      s = '30'
+    rank (1)
+      s = '31'
+    rank default
+      s = '?'
+  end select
+end function sel_rank3
+
+function get_tuple(t) result(a)
+  type(tuple) :: a
+  integer, dimension(:), intent(in) :: t
+  allocate(a%t, source=t)
+end function get_tuple
+
+end module mod
+
+
+program alloc_rank
+  use mod
+  implicit none
+
+  integer, dimension(1:3) :: x
+  character(len=:), allocatable :: output
+  type(tuple) :: z
+
+  x = [1,2,3]
+  z = get_tuple (x)
+                                       ! Derived type formal arg
+  output = sel_rank1(get_tuple (x))    ! runtime: Error in `./alloc_rank.x':
+  if (output .ne. '10') stop 1
+  output = sel_rank1([z])              ! This worked OK
+  if (output .ne. '11') stop 2
+
+                                       ! Class formal arg
+  output = sel_rank2(get_tuple (x))    ! runtime: Error in `./alloc_rank.x':
+  if (output .ne. '20') stop 3
+  output = sel_rank2([z])              ! This worked OK
+  if (output .ne. '21') stop 4
+
+                                       ! Unlimited polymorphic formal arg
+  output = sel_rank3(get_tuple (x))    ! runtime: Error in `./alloc_rank.x':
+  if (output .ne. '30') stop 5
+  output = sel_rank3([z])              ! runtime: segmentation fault
+  if (output .ne. '31') stop 6
+
+  deallocate (output)
+  deallocate (z%t)
+end program alloc_rank