https://gcc.gnu.org/g:4cb1f7fe1480b535e946361ab7e7a9ef82f8872c
commit r16-5612-g4cb1f7fe1480b535e946361ab7e7a9ef82f8872c Author: Paul Thomas <[email protected]> Date: Wed Nov 26 06:59:20 2025 +0000 Fortran: Implement finalization PDTs [PR104650] 2025-11-26 Paul Thomas <[email protected]> gcc/fortran PR fortran/104650 * decl.cc (gfc_get_pdt_instance): If the PDT template has finalizers, make a new f2k_derived namespace for this intance and copy the template namespace into it. Set the instance template_sym field to point to the template. * expr.cc (gfc_check_pointer_assign): Allow array value pointer lvalues to point to scalar null expressions in initialization. * gfortran.h : Add the template_sym field to gfc_symbol. * resolve.cc (gfc_resolve_finalizers): For a pdt_type, copy the final subroutines with the same type argument into the pdt_type finalizer list. Prevent final subroutine type checking and creation of the vtab for pdt_templates. * symbol.cc (gfc_free_symbol): Do not call gfc_free_namespace for pdt_type with finalizers. Instead, free the finalizers and the namespace. gcc/testsuite PR fortran/104650 * gfortran.dg/pdt_70.f03: New test. Diff: --- gcc/fortran/decl.cc | 10 ++++ gcc/fortran/expr.cc | 3 +- gcc/fortran/gfortran.h | 1 + gcc/fortran/resolve.cc | 52 ++++++++++++++-- gcc/fortran/symbol.cc | 16 ++++- gcc/testsuite/gfortran.dg/pdt_70.f03 | 112 +++++++++++++++++++++++++++++++++++ 6 files changed, 186 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 1346f329e612..2568f7378926 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4200,6 +4200,16 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, instance->attr.pdt_type = 1; instance->declared_at = gfc_current_locus; + /* In resolution, the finalizers are copied, according to the type of the + argument, to the instance finalizers. However, they are retained by the + template and procedures are freed there. */ + if (pdt->f2k_derived && pdt->f2k_derived->finalizers) + { + instance->f2k_derived = gfc_get_namespace (NULL, 0); + instance->template_sym = pdt; + *instance->f2k_derived = *pdt->f2k_derived; + } + /* Add the components, replacing the parameters in all expressions with the expressions for their values in 'type_param_spec_list'. */ c1 = pdt->components; diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index a11ff79ab6be..00abd9e8734c 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4577,7 +4577,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, return false; } - if (lvalue->rank != rvalue->rank && !rank_remap) + if (lvalue->rank != rvalue->rank && !rank_remap + && !(rvalue->expr_type == EXPR_NULL && is_init_expr)) { gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where); return false; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 848ad9ca1fa2..2997c0326ca1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1958,6 +1958,7 @@ typedef struct gfc_symbol /* List of PDT parameter expressions */ struct gfc_actual_arglist *param_list; + struct gfc_symbol *template_sym; struct gfc_expr *value; /* Parameter/Initializer value */ gfc_array_spec *as; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 2390858424e2..e4e7751dbf04 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -15836,7 +15836,7 @@ check_formal: static bool gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) { - gfc_finalizer* list; + gfc_finalizer *list, *pdt_finalizers = NULL; gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ bool result = true; bool seen_scalar = false; @@ -15866,6 +15866,41 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) return true; } + /* If a PDT has finalizers, the pdt_type's f2k_derived is a copy of that of + the template. If the finalizers field has the same value, it needs to be + supplied with finalizers of the same pdt_type. */ + if (derived->attr.pdt_type + && derived->template_sym + && derived->template_sym->f2k_derived + && (pdt_finalizers = derived->template_sym->f2k_derived->finalizers) + && derived->f2k_derived->finalizers == pdt_finalizers) + { + gfc_finalizer *tmp = NULL; + derived->f2k_derived->finalizers = NULL; + prev_link = &derived->f2k_derived->finalizers; + for (list = pdt_finalizers; list; list = list->next) + { + gfc_formal_arglist *args = gfc_sym_get_dummy_args (list->proc_sym); + if (args->sym + && args->sym->ts.type == BT_DERIVED + && args->sym->ts.u.derived + && !strcmp (args->sym->ts.u.derived->name, derived->name)) + { + tmp = gfc_get_finalizer (); + *tmp = *list; + tmp->next = NULL; + if (*prev_link) + { + (*prev_link)->next = tmp; + prev_link = &tmp; + } + else + *prev_link = tmp; + list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); + } + } + } + /* Walk over the list of finalizer-procedures, check them, and if any one does not fit in with the standard's definition, print an error and remove it from the list. */ @@ -15922,7 +15957,8 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) } /* This argument must be of our type. */ - if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) + if (!derived->attr.pdt_template + && (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived)) { gfc_error ("Argument of FINAL procedure at %L must be of type %qs", &arg->declared_at, derived->name); @@ -15977,7 +16013,7 @@ gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) /* Argument list might be empty; that is an error signalled earlier, but we nevertheless continued resolving. */ dummy_args = gfc_sym_get_dummy_args (i->proc_sym); - if (dummy_args) + if (dummy_args && !derived->attr.pdt_template) { gfc_symbol* i_arg = dummy_args->sym; const int i_rank = (i_arg->as ? i_arg->as->rank : 0); @@ -16025,9 +16061,13 @@ error: " rank finalizer has been declared", derived->name, &derived->declared_at); - vtab = gfc_find_derived_vtab (derived); - c = vtab->ts.u.derived->components->next->next->next->next->next; - gfc_set_sym_referenced (c->initializer->symtree->n.sym); + if (!derived->attr.pdt_template) + { + vtab = gfc_find_derived_vtab (derived); + c = vtab->ts.u.derived->components->next->next->next->next->next; + if (c && c->initializer && c->initializer->symtree && c->initializer->symtree->n.sym) + gfc_set_sym_referenced (c->initializer->symtree->n.sym); + } if (finalizable) *finalizable = true; diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index b4d3ed6394db..becaaf394509 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -3225,7 +3225,21 @@ gfc_free_symbol (gfc_symbol *&sym) gfc_free_formal_arglist (sym->formal); - gfc_free_namespace (sym->f2k_derived); + /* The pdt_type f2k_derived namespaces are copies of that of the pdt_template + and are only made if there are finalizers. The complete list of finalizers + is kept by the pdt_template and are freed with its f2k_derived. */ + if (!sym->attr.pdt_type) + gfc_free_namespace (sym->f2k_derived); + else if (sym->f2k_derived && sym->f2k_derived->finalizers) + { + gfc_finalizer *p, *q = NULL; + for (p = sym->f2k_derived->finalizers; p; p = q) + { + q = p->next; + free (p); + } + free (sym->f2k_derived); + } set_symbol_common_block (sym, NULL); diff --git a/gcc/testsuite/gfortran.dg/pdt_70.f03 b/gcc/testsuite/gfortran.dg/pdt_70.f03 new file mode 100644 index 000000000000..25801ed95494 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_70.f03 @@ -0,0 +1,112 @@ +! { dg-do run } +! +! PR104650 +! Contributed by Gerhard Steinmetz <[email protected]> +! +module m1 + type t1 + integer :: i + contains + final :: s + end type + type t2(n) + integer, len :: n = 1 + type(t1) :: a + end type + integer :: ctr = 0 + +contains + + impure elemental subroutine s(x) + type(t1), intent(in) :: x + ctr = ctr + x%i + end +end + +! From F2018: C.2.6 Final subroutines (7.5.6, 7.5.6.2, 7.5.6.3, 7.5.6.4) +module m2 + + type t(k) + integer, kind :: k + real(k), pointer :: vector(:) => NULL () + contains + final :: finalize_t1s, finalize_t1v, finalize_t2e + end type + + integer :: flag = 0 + +contains + + impure subroutine finalize_t1s(x) + type(t(kind(0.0))) x + if (associated(x%vector)) deallocate(x%vector) + flag = flag + 1 + END subroutine + + impure subroutine finalize_t1v(x) + type(t(kind(0.0))) x(:) + do i = lbound(x,1), ubound(x,1) + if (associated(x(i)%vector)) deallocate(x(i)%vector) + flag = flag + 1 + end do + end subroutine + + impure elemental subroutine finalize_t2e(x) + type(t(kind(0.0d0))), intent(inout) :: x + if (associated(x%vector)) deallocate(x%vector) + flag = flag + 1 + end subroutine + + elemental subroutine alloc_ts (x) + type(t(kind(0.0))), intent(inout) :: x + allocate (x%vector, source = [42.0,-42.0]) + end subroutine + + elemental subroutine alloc_td (x) + type(t(kind(0.0d0))), intent(inout) :: x + allocate (x%vector, source = [42.0d0,-42.0d0]) + end subroutine + +end module + + use m1 + use m2 + integer, parameter :: dims = 2 + integer :: p = 42 + +! Test pr104650 + call u (kind(0e0), p) + if (ctr /= p * (1 + kind(0e0))) stop 1 + +! Test the standard example + call example (dims) + if (flag /= 11 + dims**2) stop 2 + +contains + + subroutine u (k, p) + integer :: k, p + type (t2(k)) :: u_k, v_k(k) + u_k%a%i = p + v_k%a%i = p + end + +! Returning from 'example' will effectively do +! call finalize_t1s(a) +! call finalize_t1v(b) +! call finalize_t2e(d) +! No final subroutine will be called for variable C because the user +! omitted to define a suitable specific procedure for it. + subroutine example(n) + type(t(kind(0.0))) a, b(10), c(n,2) + type(t(kind(0.0d0))) d(n,n) + real(kind(0.0)),target :: tgt(1) + + ! Explicit allocation to provide a valid memory refence for deallocation. + call alloc_ts(a) + call alloc_ts(b) + call alloc_ts(c) + call alloc_td(d) + end subroutine + +end
