Hello All, The attached patch fixes the last of the runtime bugs in pr82173 comment #10.
The patch fixes double frees of parameterized components of source expressions in calls to array transformational functions. Before this fix, the contents of the parameterized components were shallow copied to the result. In all cases, a deep copy was required and is implemented here. Merge and transfer are inlined and scalarized, which then need the new copy function to be called from three locations. The testcase, pdt_bug26.f90 is free of double frees, memory leaks and errors, according to valgrind. The patch passes regression testing on FC44/x86_64. OK for mainline? Patch 15/16, provided by Jerry, will provide a fix for a problem with--with-arch=armv8-a reported by Linaro. Patch 16/16 will provide a fix for the 11 missing F2023 constraints for PDTs. Then I will analyze the existing pdt tests to see if any cover cases not included in the full comment #10 testsuite. These will be retained, the rest eliminated and replaced by a consolidated version of the new testsuite. After this, apart from regressions, I am done with PDTs forever! One gratifying feature of this PDT campaign is that the original design, especially with LEN components, has stood the test of time. Complexity of implementation has been the problem all along. Regards Paul
From 7a974eca4a7e67501f7af33c311421fd771eeb35 Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Thu, 12 Nov 2026 11:48:07 +0000 Subject: [PATCH] Fortran: [PDT] (14/16) Parameterized derived type errors [PR82173] 2026-11-12 Paul Thomas <[email protected]> gcc/fortran PR fortran/82173 * expr.cc (gfc_pdt_requires_hidden_arg): Change attr.pointer to attr->class_pointer to obtain intended result. * trans-expr.cc (gfc_conv_procedure_call): Extend result copying for array transformational functions to include parameterized as well as allocatable components. For function calls that are not direct_byref, deallocate the temporary paramterized components to prevent double frees of the argument components on leaving scope. (gfc_trans_arrayfunc_assign): For array transformational like- wise deallocate paramterized components. * trans-intrinsic.cc (copy_pdt_components): New function to copy the result paramterized componts for the same reason. (gfc_conv_intrinsic_merge, gfc_conv_intrinsic_transfer): Use it. gcc/testsuite/ PR fortran/82173 * gfortran.dg/pdt_bug26.f90: New test. --- gcc/fortran/expr.cc | 2 +- gcc/fortran/trans-expr.cc | 21 ++++++- gcc/fortran/trans-intrinsic.cc | 22 ++++++- gcc/testsuite/gfortran.dg/pdt_bug26.f90 | 84 +++++++++++++++++++++++++ 4 files changed, 126 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_bug26.f90 diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a88cd9a8c1f..67c9aa6ac6f 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4018,7 +4018,7 @@ bool gfc_pdt_requires_hidden_arg (gfc_symbol *arg) if (IS_CLASS_PDT (arg) && (CLASS_DATA (arg)->attr.allocatable - || CLASS_DATA (arg)->attr.pointer)) + || CLASS_DATA (arg)->attr.class_pointer)) return true; return false; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 92e42195256..08428820fea 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -9474,13 +9474,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && isym->id != GFC_ISYM_REDUCE && arg->expr && arg->expr->ts.type == BT_DERIVED - && arg->expr->ts.u.derived->attr.alloc_comp) + && (arg->expr->ts.u.derived->attr.alloc_comp + || arg->expr->ts.u.derived->attr.pdt_type)) { tree tmp2; /* Copy the allocatable components. We have to use a temporary here to prevent source allocatable components from being corrupted. */ tmp2 = gfc_evaluate_now (result, &se->pre); + tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived, result, tmp2, expr->rank, 0); gfc_add_expr_to_block (&se->pre, tmp); @@ -9488,6 +9490,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, expr->rank); gfc_add_expr_to_block (&se->pre, tmp); + /* Free the result PST components if not direct_byref. */ + if (!se->direct_byref && arg->expr->ts.u.derived->attr.pdt_type) + { + tmp = gfc_deallocate_pdt_comp (arg->expr->ts.u.derived, result, + expr->rank); + gfc_add_expr_to_block (&se->pre, tmp); + } /* Finally free the temporary's data field. */ tmp = gfc_conv_descriptor_data_get (tmp2); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, @@ -12948,6 +12957,16 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) expr1->rank); gfc_add_expr_to_block (&se.pre, tmp); } + else if (expr1->ts.type == BT_DERIVED + && has_parameterized_comps (expr1->ts.u.derived) && expr1->rank > 0 + && expr2->value.function.isym + && expr2->value.function.isym->transformational + && expr2->value.function.isym->id != GFC_ISYM_REDUCE) + { + tmp = build_fold_indirect_ref_loc (input_location, se.expr); + tmp = gfc_deallocate_pdt_comp (expr1->ts.u.derived, tmp, expr1->rank); + gfc_add_expr_to_block (&se.pre, tmp); + } se.direct_byref = 1; se.ss = gfc_walk_expr (expr2); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index b39216f527e..8afa33cbc84 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -440,6 +440,19 @@ build_fix_expr (stmtblock_t * pblock, tree arg, tree type, } +/* Copy the PDT components of the result for MERGE and TRAQNSFER. */ + +static void +copy_pdt_components (gfc_se *se, gfc_expr *expr) +{ + tree tmp, pdt_tmp; + pdt_tmp = gfc_evaluate_now (se->expr, &se->pre); + tmp = gfc_copy_alloc_comp (expr->ts.u.derived, + pdt_tmp, se->expr, expr->rank, 0); + gfc_add_expr_to_block (&se->pre, tmp); +} + + /* Round a real value using the specified rounding mode. We use a temporary integer of that same kind size as the result. Values larger than those that can be represented by this kind are @@ -7950,6 +7963,9 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) type = TREE_TYPE (tsource); se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource, fold_convert (type, fsource)); + se->expr = gfc_evaluate_now (se->expr, &se->pre); + if (IS_PDT (expr)) + copy_pdt_components (se, expr); } @@ -9098,6 +9114,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) dest_word_len, tmp); } + if (IS_PDT (expr)) + copy_pdt_components (se, expr); return; /* Deal with scalar results. */ @@ -9187,8 +9205,10 @@ scalar_transfer: /* For CLASS results, set the _vptr. */ if (mold_expr->ts.type == BT_CLASS) gfc_reset_vptr (&se->pre, nullptr, tmpdecl, source_expr->ts.u.derived); - se->expr = tmpdecl; + + if (IS_PDT (expr)) + copy_pdt_components (se, expr); } } diff --git a/gcc/testsuite/gfortran.dg/pdt_bug26.f90 b/gcc/testsuite/gfortran.dg/pdt_bug26.f90 new file mode 100644 index 00000000000..5cf092ed662 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug26.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! Sourced from comment #10 of PR82173. +! This test brings together ../pos/p67_N_array_intrinsics.f90: +! Array intrinsics applied to arrays of parameterized derived type. +! and ../pos/p66_N_transfer.f90 +! F2023 16.9.193: TRANSFER with a parameterized derived type source. +! Valgrind shows no errors or memory leaks. +! +module m_p67 + implicit none + type :: t(n) + integer, len :: n = 1 + integer :: v(n) + integer :: tag + end type +end module +module m_p66 + implicit none + type :: t(n) + integer, len :: n = 1 + integer :: v(n) + end type +end module + + call p67 + call p66 +contains +subroutine p67 + use m_p67 + implicit none + type(t(2)) :: a(6), b(2, 3), c(6), one + logical :: mask(6) + integer :: i + + do i = 1, 6 + a(i)%v = i + a(i)%tag = i + end do + one%v = 0 + one%tag = 99 + + ! RESHAPE + b = reshape (a, [2, 3]) + if (size (b, 1) /= 2 .or. size (b, 2) /= 3) error stop 1 + if (b(1, 1)%tag /= 1 .or. b(2, 3)%tag /= 6) error stop 2 + if (b(2, 1)%n /= 2) error stop 3 + + ! PACK + mask = [.true., .false., .true., .false., .true., .false.] + c(1:3) = pack (a, mask) + if (c(1)%tag /= 1 .or. c(2)%tag /= 3 .or. c(3)%tag /= 5) error stop 4 + + ! SPREAD + if (size (spread (one, 1, 4)) /= 4) error stop 5 + + ! CSHIFT / EOSHIFT + c = cshift (a, 2) + if (c(1)%tag /= 3 .or. c(6)%tag /= 2) error stop 6 + c = eoshift (a, 1, one) + if (c(6)%tag /= 99) error stop 7 + + ! MERGE + c = merge (a, a(6:1:-1), mask) + if (c(1)%tag /= 1 .or. c(2)%tag /= 5) error stop 8 +end subroutine + +subroutine p66 + use m_p66 + implicit none + type(t(3)) :: a, b + integer, allocatable :: buf(:) + + a%v = [11, 22, 33] + + buf = transfer (a, [0]) + if (size (buf) < 3) error stop 101 + + b = transfer (buf, b) + if (any (b%v /= [11, 22, 33])) stop 102 + if (b%n /= 3) error stop 103 + if (allocated (buf)) deallocate (buf) +end subroutine + +end -- 2.56.0
