This one is straightforward, going on obvious. Allocatable components were not being copied in the assignment of class or derived type component. Three places in gfc_trans_subcomponent_assign were touched.
The patch was reviewed and tested in January but was not pushed because of the release of 16.1.1 and then forgotten. Regression tests OK on FC44/x86_64. OK for mainline and then, after an interval, 16-branch? Paul
From 3b8aca292f08b11f7776ae08f954f2c546616f95 Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Thu, 13 Aug 2026 16:00:15 +0100 Subject: [PATCH] ortran: Fix data corruption with allocation from ctr source [P121683] 2026-08-13 Paul Thomas <[email protected]> gcc/fortran PR fortran/110626 * trans-expr.cc (gfc_trans_subcomponent_assign): For derived type expressions assigned to a class or derived type component copy allocatable components if necessary. Likewise, for a class expression assigned to a scalar class component, allocate the component and use the vptr copy. gcc/testsuite/ PR fortran/110626 * gfortran.dg/pr11026.f90: structure_constructor_18.f90. --- gcc/fortran/trans-expr.cc | 69 +++++++++++- .../gfortran.dg/structure_constructor_18.f90 | 102 ++++++++++++++++++ 2 files changed, 169 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/structure_constructor_18.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 33b7838f74a..a5fcd26aff4 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -10184,6 +10184,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, && expr->ts.type != BT_CLASS))) { tree size; + tree tmp2; gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); @@ -10245,6 +10246,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_add_expr_to_block (&block, gfc_build_memcpy_call (tmp, se.expr, size)); + if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_NULL) + { + tmp2 = gfc_class_data_get (dest); + tmp2 = gfc_copy_alloc_comp (expr->ts.u.derived, tmp2, + gfc_class_data_get (dest), + expr->rank, 0); + gfc_add_expr_to_block (&block, tmp2); + } + /* Fill the unlimited polymorphic _len field. */ if (UNLIMITED_POLY (cm) && expr->ts.type == BT_CHARACTER) { @@ -10255,8 +10267,20 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, } } else - gfc_add_modify (&block, tmp, - fold_convert (TREE_TYPE (tmp), se.expr)); + { + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), se.expr)); + if (expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_NULL) + { + tmp2 = build_fold_indirect_ref_loc (input_location, dest); + tmp2 = gfc_copy_alloc_comp (cm->ts.u.derived, tmp2, + se.expr, expr->rank, 0); + gfc_add_expr_to_block (&block, tmp2); + } + } + gfc_add_block_to_block (&block, &se.post); } else if (expr->ts.type == BT_UNION) @@ -10356,6 +10380,47 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_add_expr_to_block (&block, tmp); } } + else if (cm->ts.type == BT_CLASS + && !CLASS_DATA (cm)->as + && expr->ts.type == BT_CLASS) + { + tree vptr1, vptr2; + tree data1, data2; + tree size, fcn; + + gfc_init_se (&se, NULL); + + gfc_conv_expr (&se, expr); + + /* Copy the _vptr to the destination.... */ + vptr1 = gfc_class_vptr_get (dest); + vptr2 = gfc_class_vptr_get (se.expr); + gfc_add_modify (&block, vptr1, + fold_convert (TREE_TYPE (vptr1), vptr2)); + + /* ....and the _len field if necessary. */ + size = gfc_vptr_size_get (vptr2); + if (UNLIMITED_POLY (cm) && UNLIMITED_POLY (expr)) + { + gfc_add_modify (&block, gfc_class_len_get (dest), + gfc_class_len_get (se.expr)); + size = gfc_resize_class_size_with_len (&block, se.expr, size); + } + + /* Allocate the destination data. */ + data1 = gfc_class_data_get (dest); + data2 = gfc_class_data_get (se.expr); + tmp = gfc_call_malloc (&block, TREE_TYPE (data1), size); + gfc_add_modify (&block, data1, tmp); + + /* Now call the copy function. */ + fcn = gfc_vptr_copy_get (vptr2); + if (POINTER_TYPE_P (TREE_TYPE (fcn))) + fcn = build_fold_indirect_ref_loc (input_location, fcn); + tmp = build_call_expr_loc (input_location, fcn, 2, + data2, data1); + gfc_add_expr_to_block (&block, tmp); + } else if (!cm->attr.artificial) { /* Scalar component (excluding deferred parameters). */ diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_18.f90 b/gcc/testsuite/gfortran.dg/structure_constructor_18.f90 new file mode 100644 index 00000000000..08b12c83ab6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_18.f90 @@ -0,0 +1,102 @@ +! { dg-do run } +! +! Test the fix for PR121683 and a variant from Jerry Delisle. Explicit +! deallocations were added, when both original and variant were stand +! alone programs. +! +! Contributed by Neil Carlson <[email protected]> +! and Jerry Delisle <[email protected]> +! +module mod + implicit none + type, abstract :: func + end type + type, extends(func) :: poly + real, allocatable :: array(:) + end type + type, extends(func) :: func_deriv + class(func), allocatable :: f + end type + +contains + + subroutine alloc_deriv(f, df) + class(func), intent(in) :: f + class(func), allocatable, intent(out) :: df + allocate(df, source=func_deriv(f)) ! THIS CORRUPTS F + end subroutine + +end module + +program fubar + call original + call variant +contains + + subroutine original + use mod + type(poly), allocatable :: p + class(func), allocatable :: f, df + real :: array(2) = [1, 2] + allocate(p) + p%array = array + call move_alloc(p, f) + call alloc_deriv(f, df) + if (.not.allocated(f)) stop 1 + select type (f) + type is (poly) + if (.not.allocated(f%array)) stop 2 ! SANITIZER: HEAP-USE-AFTER-FREE + if (size(f%array) /= size(array)) stop 3 + if (any(f%array /= array)) stop 4 ! SEGFAULTS HERE WITHOUT SANITIZER + class default + stop 5 + end select + deallocate (f) + select type (df) ! Verify that df is OK + type is (func_deriv) + if (.not.allocated(df%f)) stop 6 + select type (f => df%f) + type is (poly) + if (.not.allocated(f%array)) stop 7 + if (size(f%array) /= size(array)) stop 8 + if (any(f%array /= array)) stop 9 + class default + stop 10 + end select + class default + stop 11 + end select + deallocate (df) + end + + subroutine variant + type :: base + integer :: i = 1 + end type + type, extends(base) :: t1 + integer, allocatable :: array(:) + end type + type(t1) :: x + type :: t2 + class(base), allocatable :: b + end type + type(t2), allocatable :: y + type :: t3 + type(t1), allocatable :: b + end type + type(t3), allocatable :: z + type :: t4 + type(t1) :: b + end type + type(t4), allocatable :: z2 + + x%array = [1,2] + allocate(y, source = t2(x)) ! This was the original problem... + if (any (x%array /= [1,2])) stop 12 ! ... x%array was overwritten + allocate(z, source = t3(x)) + if (any (x%array /= [1,2])) stop 13 ! -ditto- + allocate(z2, source = t4(x)) + if (any (x%array /= [1,2])) stop 14 ! Was already OK + deallocate (x%array, y, z, z2%b%array) + end +end ! Valgrind shows " in use at exit: 0 bytes in 0 blocks" -- 2.55.0
