Hi All, The source of this bug was hard to find but, once located, easy to fix. With the benefit of hindsight, it is rather obviously a poor idea to attempt to deep copy a PDT without parameterized components!
Regtests OK on FC43/x86_64 - OK for mainline? Paul
Change.Logs
Description: Binary data
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
