https://gcc.gnu.org/g:020d4084028bb4a5280094be6b8d90fb3085ad5b
commit r16-8493-g020d4084028bb4a5280094be6b8d90fb3085ad5b Author: Paul Thomas <[email protected]> Date: Sun Apr 5 10:53:08 2026 +0100 Fortran: Bugs found while testing r16-8436 [PR124780] 2026-04-07 Paul Thomas <[email protected]> gcc/fortran PR fortran/124780 * resolve.cc (resolve_ordinary_assign): Do not add the class data component to an operator expression. * trans-expr.cc (gfc_trans_scalar_assign): If class to class assignment uses ordinary scalar assignment and neither lhs or rhs are class types, do a deep copy for allocatable components. gcc/testsuite/ PR fortran/124780 * gfortran.dg/pr124780.f90: New test. Diff: --- gcc/fortran/resolve.cc | 3 ++- gcc/fortran/trans-expr.cc | 27 +++++++++++++++++++++---- gcc/testsuite/gfortran.dg/pr124780.f90 | 36 ++++++++++++++++++++++++++++++++++ 3 files changed, 61 insertions(+), 5 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 767bbdea1140..638c36595d9c 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -13219,7 +13219,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) /* Assign the 'data' of a class object to a derived type. */ if (lhs->ts.type == BT_DERIVED && rhs->ts.type == BT_CLASS - && rhs->expr_type != EXPR_ARRAY) + && (rhs->expr_type != EXPR_ARRAY + && rhs->expr_type != EXPR_OP)) gfc_add_data_component (rhs); /* Make sure there is a vtable and, in particular, a _copy for the diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 6c0bd5ce9107..3b9a9337984a 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -11777,6 +11777,7 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, stmtblock_t block; tree tmp; tree cond; + int caf_mode; gfc_init_block (&block); @@ -11865,7 +11866,7 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, same as the lhs. */ if (deep_copy) { - int caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) : 0; tmp = gfc_copy_alloc_comp (ts.u.derived, rse->expr, lse->expr, 0, caf_mode); @@ -11892,12 +11893,30 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, if (!trans_scalar_class_assign (&block, lse, rse)) { - /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR - for the lhs which ensures that class data rhs cast as a string assigns - correctly. */ + /* ..otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR + for the lhs which ensures that class data rhs cast as a string + assigns correctly. */ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, TREE_TYPE (rse->expr), lse->expr); gfc_add_modify (&block, tmp, rse->expr); + + /* Copy allocatable components but guard against class pointer + assign, which arrives here. */ +#define DATA_DT ts.u.derived->components->ts.u.derived + if (deep_copy + && !(GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) + && ts.u.derived->components + && DATA_DT && DATA_DT->attr.alloc_comp) + { + caf_mode = in_coarray ? (GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY + | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) + : 0; + tmp = gfc_copy_alloc_comp (DATA_DT, rse->expr, lse->expr, 0, + caf_mode); + gfc_add_expr_to_block (&block, tmp); + } +#undef DATA_DT } } else if (ts.type != BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/pr124780.f90 b/gcc/testsuite/gfortran.dg/pr124780.f90 new file mode 100644 index 000000000000..79245948a549 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr124780.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Test the fix for PR124780, which failes as in comments below. +! +! Contributed by Harald Anlauf <[email protected]> +! +program p + integer :: i + type :: t + integer, allocatable :: i(:) + end type + type (t), allocatable :: src(:), ans(:) + src = [t([1,2]), t([3,4])] ! Leaks memory 16 bytes in 2 blocks; + ! familiar from PDT memory leaks :-( + ans = f(src) + do i = 1,2 + if (any (src(i)%i /= ans(i)%i)) stop 1 + deallocate (ans(i)%i, src(i)%i) + enddo + deallocate (ans, src) +contains + function f(x) result(z) + class(t), intent(inout) :: x(:) + type(t) :: z (size(x)) + class(t), allocatable :: a(:) + class(t), allocatable :: b(:) + allocate (a(size(x))) + select type (x) + type is (t) + a = x ! Mangled src and caused + ! double free at line 12 + end select + b = x + z = (b) ! ICE, without patch + end +end
