From: Paul Thomas Date: Wed, 1 Jul 2026 16:14:25 +0000 (+0100) Subject: Fortran: Fix asan problems with PDT testcases [PR121972] X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=95dbc32189ab0433283f337b4b490bfcec0bd475;p=thirdparty%2Fgcc.git Fortran: Fix asan problems with PDT testcases [PR121972] Co-authored-by: Jerry DeLisle PR fortran/121972 gcc/fortran * expr.cc (has_parameterized_comps): Return false if the DT is neither a pdt_type nor has PDT components. Correct the logic for a PDT component. * trans-expr.cc (alloc_scalar_allocatable_for_assignment): Use calloc for types with paramterized components as well as those with allocatable components. * trans-stmt.cc (gfc_trans_allocate): Merge the allocation of parameterized components of PDTs and class PDTs into one block If an allocate type_spec is present that has allocatable comps where the class declared type does not, nullify the allocatable components. gcc/testsuite/ * gfortran.dg/asan/pdt_46.f03: Copy of original with tree dump for counts of frees, mallocs and callocs removed. * gfortran.dg/asan/pdt_77.f03: Ditto. * gfortran.dg/pdt_46.f03: Calloc count added, corresponding to reduction in mallocs.. * gfortran.dg/pdt_50.f03: Ditto. --- diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 04f0c513a7d..9fb152074db 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -7115,10 +7115,16 @@ gfc_pdt_find_component_copy_initializer (gfc_symbol *sym, const char *name) bool has_parameterized_comps (gfc_symbol * der_type) { bool parameterized_comps = false; + + if (!der_type->attr.pdt_type && !der_type->attr.pdt_comp) + return 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); + else if (IS_PDT (c) && strcmp (der_type->name, c->ts.u.derived->name) + && has_parameterized_comps (c->ts.u.derived)) + parameterized_comps = true; + return parameterized_comps; } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 9108e92b446..0d6a42687c1 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -12838,7 +12838,9 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, NULL_TREE, NULL_TREE, NULL_TREE, jump_label1, expr1, 1); } - else if (expr1->ts.type == BT_DERIVED && expr1->ts.u.derived->attr.alloc_comp) + else if (expr1->ts.type == BT_DERIVED + && (expr1->ts.u.derived->attr.alloc_comp + || has_parameterized_comps (expr1->ts.u.derived))) { tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_CALLOC), diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 0b1a8fa6b14..06fa076cff5 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -7690,9 +7690,23 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) gfc_add_expr_to_block (&block, tmp); } /* Set KIND and LEN PDT components and allocate those that are - parameterized. */ - else if (IS_PDT (expr)) + parameterized and make sure that allocatable components are + nullified. */ + else if (IS_PDT (expr) || IS_CLASS_PDT (expr)) { + gfc_symbol *declared; + gfc_symbol *type_spec_dt; + tree type; + tree ptr; + + declared = IS_PDT (expr) ? expr->ts.u.derived + : CLASS_DATA (expr)->ts.u.derived; + + if (code->ext.alloc.ts.type == BT_DERIVED) + type_spec_dt = code->ext.alloc.ts.u.derived; + else + type_spec_dt = NULL; + if (code->expr3 && code->expr3->param_list) param_list = code->expr3->param_list; else if (expr->param_list) @@ -7706,25 +7720,21 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr)) : expr->rank); - tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr, + tmp = gfc_allocate_pdt_comp (declared, se.expr, pdt_rank, param_list); gfc_add_expr_to_block (&block, tmp); - } - /* Ditto for CLASS expressions. */ - else if (IS_CLASS_PDT (expr)) - { - if (code->expr3 && code->expr3->param_list) - param_list = code->expr3->param_list; - else if (expr->param_list) - param_list = expr->param_list; - else - param_list = expr->symtree->n.sym->param_list; - int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) - ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr)) - : expr->rank); - tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, - se.expr, pdt_rank, param_list); - gfc_add_expr_to_block (&block, tmp); + + /* If this is a CLASS allocation and the declared type does not have + allocatable components but the explicit type_spec does, nullify + the allocatable components of the type_spec derived type. */ + if (pdt_rank == 0 && type_spec_dt + && !declared->attr.alloc_comp && type_spec_dt->attr.alloc_comp) + { + type = build_pointer_type (gfc_get_derived_type (type_spec_dt)); + ptr = fold_convert (type, se.expr); + tmp = gfc_nullify_alloc_comp (type_spec_dt, ptr, 0); + gfc_add_expr_to_block (&block, tmp); + } } else if (code->expr3 && code->expr3->mold && code->expr3->ts.type == BT_CLASS) diff --git a/gcc/testsuite/gfortran.dg/asan/pdt_46.f03 b/gcc/testsuite/gfortran.dg/asan/pdt_46.f03 new file mode 100644 index 00000000000..c71a9063a62 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/pdt_46.f03 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! Test the fix for PR83763 in which a dependency was not handled correctly, which +! resulted in a runtime segfault. +! +! Contributed by Berke Durak +! +module bar + implicit none + + type :: foo(n) + integer, len :: n = 10 + real :: vec(n) + end type foo + +contains + + function baz(a) result(b) + type(foo(n = *)), intent(in) :: a + type(foo(n = a%n)) :: b + + b%vec = a%vec * 10 + end function baz + +end module bar + +program test + use bar + implicit none + call main1 ! Original report + call main2 ! Check for memory loss with allocatable 'x' and 'y'. + +contains + + subroutine main1 + type(foo(5)) :: x, y + integer :: a(5) = [1,2,3,4,5] + + x = foo(5)(a) + x = baz (x) ! Segmentation fault because dependency not handled. + if (any (x%vec /= 10 * a)) stop 1 + y = x + x = baz (y) ! No dependecy and so this worked. + if (any (x%vec /= 100 * a)) stop 2 + end subroutine main1 + + subroutine main2 + type(foo(5)), allocatable :: x, y + integer :: a(5) = [1,2,3,4,5] + + x = foo(5)(a) + x = baz (x) ! Segmentation fault because dependency not handled. + if (any (x%vec /= 10 * a)) stop 3 + y = x + x = baz (y) ! No dependecy and so this worked. + if (any (x%vec /= 100 * a)) stop 4 + end subroutine main2 + +end program test diff --git a/gcc/testsuite/gfortran.dg/asan/pdt_77.f03 b/gcc/testsuite/gfortran.dg/asan/pdt_77.f03 new file mode 100644 index 00000000000..a8efe189c79 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/asan/pdt_77.f03 @@ -0,0 +1,75 @@ +! { dg-do run } +! +! Test the fix for PR110012, which failed to compile with an ICE. +! Later, it was found that mfe_disc_test was leaking memory because +! the 'navier_stokes' component p was given the PDT template dynamic +! type, rather than that of the correct instance. This is detected +! by the added, final subroutine being called twice, rather than +! once (PR121972). +! +! Contributed by Neil Carlson +! +module pde_class + type, abstract :: pde(npde) + integer,len :: npde + end type +end module + +module navier_stokes_type + use pde_class + type, extends(pde) :: navier_stokes + integer, allocatable :: data_(:) + contains + final :: finalIze_navier_stokes + end type + integer :: ctr = 0 +contains + subroutine alloc_navier_stokes(p , n) + class(pde(:)), allocatable :: p + integer :: n + allocate(navier_stokes(npde=n) :: p) + select type (p) + type is (navier_stokes(*)) + p%data_ = [(i, i = 1, p%npde)] + end select + end subroutine + impure elemental subroutine finalIze_navier_stokes (self) + type(navier_stokes), intent(inout) :: self + ctr = ctr + 1 + end +end module + +module mfe_disc_type + use pde_class + type :: foo + class(pde(:)), allocatable :: p ! This caused the ICE in resolution. + end type +end module + +program test + use navier_stokes_type + call navier_stokes_test + call mfe_disc_test + if (ctr /= 2) stop 3 +contains + subroutine navier_stokes_test + class (pde(:)), allocatable :: x + call alloc_navier_stokes (x, 4) + select type (x) + type is (navier_stokes(*)) + if (any (x%data_ /= [1,2,3,4])) stop 1 + end select + end subroutine + + subroutine mfe_disc_test + use mfe_disc_type + type (foo), allocatable :: x + allocate (x) + call alloc_navier_stokes (x%p, 3) + select type (z => x%p) + type is (navier_stokes(*)) + if (any (z%data_ /= [1,2,3])) stop 2 + end select + if (allocated (x) .and. allocated (x%p)) deallocate (x%p) + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/pdt_46.f03 b/gcc/testsuite/gfortran.dg/pdt_46.f03 index 67d32df66a5..fdccbc5cded 100644 --- a/gcc/testsuite/gfortran.dg/pdt_46.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_46.f03 @@ -59,4 +59,5 @@ contains end program test ! { dg-final { scan-tree-dump-times "__builtin_free" 16 "original" } } -! { dg-final { scan-tree-dump-times "__builtin_malloc" 12 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_calloc" 4 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_50.f03 b/gcc/testsuite/gfortran.dg/pdt_50.f03 index 9c036e43563..270989d2fe9 100644 --- a/gcc/testsuite/gfortran.dg/pdt_50.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_50.f03 @@ -50,5 +50,6 @@ call sr deallocate (d%p_t1) end -! { dg-final { scan-tree-dump-times "__builtin_malloc" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 7 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_calloc" 1 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 9 "original" } }