[Patch, fortran] PR122902 - [PDT] seg fault on assigning composite PDT array section to allocatable array

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index a47e970eda9..fa5aeced2f3 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -7105,3 +7105,17 @@ gfc_pdt_find_component_copy_initializer (gfc_symbol *sym, const char *name)
     }
   return NULL;
 }
+
+
+/* Test for parameterized array or string components.  */
+
+bool has_parameterized_comps (gfc_symbol * der_type)
+{
+  bool parameterized_comps = false;
+  for (gfc_component *c = der_type->components; c; c = c->next)
+    if (c->attr.pdt_array || c->attr.pdt_string)
+      parameterized_comps = true;
+    else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name))
+      parameterized_comps = has_parameterized_comps (c->ts.u.derived);
+  return parameterized_comps;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c9242a3adcc..bbf3968eacb 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4046,7 +4046,7 @@ gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
 				    locus, unsigned, ...);
 bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
 gfc_expr* gfc_pdt_find_component_copy_initializer (gfc_symbol *, const char *);
-
+bool has_parameterized_comps (gfc_symbol *);
 
 /* st.cc */
 extern gfc_code new_st;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 73bb90a4b60..70cea46c6b0 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11588,22 +11588,10 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
 /* Recursively traverse an object of parameterized derived type, generating
    code to deallocate parameterized components.  */
 
-static bool
-has_parameterized_comps (gfc_symbol * der_type)
-{
-  /* A type without parameterized components causes gimplifier problems.  */
-  bool parameterized_comps = false;
-  for (gfc_component *c = der_type->components; c; c = c->next)
-    if (c->attr.pdt_array || c->attr.pdt_string)
-      parameterized_comps = true;
-    else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name))
-      parameterized_comps = has_parameterized_comps (c->ts.u.derived);
-  return parameterized_comps;
-}
-
 tree
 gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
 {
+  /* A type without parameterized components causes gimplifier problems.  */
   if (!has_parameterized_comps (der_type))
     return NULL_TREE;
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 58dc1eb04c1..8bd2689d744 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11739,7 +11739,7 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
     }
   else if (gfc_bt_struct (ts.type)
 	   && (ts.u.derived->attr.alloc_comp
-		|| (deep_copy && ts.u.derived->attr.pdt_type)))
+	       || (deep_copy && has_parameterized_comps (ts.u.derived))))
     {
       tree tmp_var = NULL_TREE;
       cond = NULL_TREE;
diff --git a/gcc/testsuite/gfortran.dg/pdt_39.f03 b/gcc/testsuite/gfortran.dg/pdt_39.f03
index 7cfd232a72f..f03ab19ced8 100644
--- a/gcc/testsuite/gfortran.dg/pdt_39.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_39.f03
@@ -119,5 +119,9 @@ program p
      print *, " error deallocating mat_r4: stat = ", istat
      stop
   end if
+
+! Make sure valgrind shows no leaks.
+  if (allocated (a_r4)) deallocate (a_r4)
+  if (allocated (a_r8)) deallocate (a_r8)
   stop
 end program p
diff --git a/gcc/testsuite/gfortran.dg/pdt_86.f03 b/gcc/testsuite/gfortran.dg/pdt_86.f03
new file mode 100644
index 00000000000..6e7798ecfba
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_86.f03
@@ -0,0 +1,57 @@
+! { dg-do run }
+!
+! Test the fix for PR122902. Line 47 gave "free(): invalid pointer".
+!
+! Contributed by Damian Rouson  <[email protected]>
+!
+module input_output_pair_m
+  implicit none
+
+  type tensor_t(k)
+    integer, kind :: k = kind(1.)
+    real(k), allocatable :: values_(:)
+  end type
+
+  type input_output_pair_t(k)
+    integer, kind :: k = kind(1.)
+    type(tensor_t(k)) inputs_, expected_outputs_
+  end type
+
+  interface
+    type(input_output_pair_t) elemental module function input_output_pair(inputs, expected_outputs)
+      implicit none
+      type(tensor_t), intent(in) :: inputs, expected_outputs
+    end function
+  end interface
+
+end module
+
+submodule(input_output_pair_m) input_output_pair_s
+  implicit none
+contains
+  module procedure input_output_pair
+    input_output_pair%inputs_ = inputs
+    input_output_pair%expected_outputs_ = expected_outputs
+  end procedure
+end submodule
+
+  use input_output_pair_m
+  implicit none
+  type(tensor_t), allocatable :: inputs(:), outputs(:)
+  type(input_output_pair_t), allocatable :: input_output_pairs(:), mini_batch(:)
+  integer i
+
+  inputs = [(tensor_t([real(i)]), i=1,7)]
+  outputs = inputs
+  input_output_pairs = input_output_pair(inputs, outputs)
+  mini_batch = input_output_pairs(1:1)     ! Original failure
+  if (any (mini_batch(1)%inputs_%values_ /= 1.0)) stop 1
+  mini_batch = input_output_pairs(1:2)     ! Also failed
+  if (any (mini_batch(2)%inputs_%values_ /= 2.0)) stop 2
+  mini_batch = input_output_pairs          ! Was OK
+  if (any (mini_batch(5)%inputs_%values_ /= 5.0)) stop 3
+  if (allocated(inputs)) deallocate(inputs)
+  if (allocated(outputs)) deallocate(outputs)
+  if (allocated(input_output_pairs)) deallocate(input_output_pairs)
+  if (allocated(mini_batch)) deallocate(mini_batch)
+end