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.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e614924..85c16d7 100644 (file)
--- 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 (file)
--- 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 (file)
index 0000000..ef5edbf
--- /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