https://gcc.gnu.org/g:11b351c59be7d306b1460a2be2cfde472a0dee5c
commit r16-7959-g11b351c59be7d306b1460a2be2cfde472a0dee5c Author: Paul Thomas <[email protected]> Date: Mon Mar 9 16:07:48 2026 +0000 Fortran: Fix invalid free for PDTs without LEN components [PR122902] 2026-03-09 Paul Thomas <[email protected]> gcc/fortran PR fortran/122902 * expr.cc (has_parameterized_comps): Moved from trans-array.cc. * gfortran.h : Add prototype for has_parameterized_comps. * trans-array.cc : Move has_parameterized_comps to expr.cc. * trans-expr.cc (gfc_trans_scalar_assign): Don't deep copy PDTs unless they have parameterized components. gcc/testsuite/ PR fortran/122902 * gfortran.dg/pdt_39.f03: Deallocate a_r4 and a_r8. * gfortran.dg/pdt_86.f03: New test. Diff: --- gcc/fortran/expr.cc | 14 +++++++++ gcc/fortran/gfortran.h | 2 +- gcc/fortran/trans-array.cc | 14 +-------- gcc/fortran/trans-expr.cc | 2 +- gcc/testsuite/gfortran.dg/pdt_39.f03 | 4 +++ gcc/testsuite/gfortran.dg/pdt_86.f03 | 57 ++++++++++++++++++++++++++++++++++++ 6 files changed, 78 insertions(+), 15 deletions(-) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a47e970eda9f..fa5aeced2f36 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 c9242a3adccb..bbf3968eacbb 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 73bb90a4b601..70cea46c6b0e 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 58dc1eb04c17..8bd2689d7440 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 7cfd232a72f9..f03ab19ced8f 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 000000000000..6e7798ecfbae --- /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
