Hi All, The attached patch implements PDT finalizers and, in doing so, fixes the PR. The testcase also tests the second PDT example in the F2018 standard, which used to fail in spectacular fashion.
I have checked that all the symbols are indeed deleted during post compilation clean up. I have also checked that the ongoing work to get fiats to compile (nearly there!) and run is not affected by this patch. The new field in gfc_symbol, 'template_sym' is going to come in handy for all sorts of future housekeeping such as providing a more concise type name in error messages. Although the patch looks fairly weighty, I believe that it is well described by the ChangeLog and the comments in the patch. Regtests on FC43/x86_64. OK for mainline? Cheers Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 1346f329e61..2568f737892 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 a11ff79ab6b..00abd9e8734 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 848ad9ca1fa..2997c0326ca 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 2390858424e..e4e7751dbf0 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 b4d3ed6394d..becaaf39450 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 00000000000..25801ed9549
--- /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 reference for deallocation.
+ call alloc_ts(a)
+ call alloc_ts(b)
+ call alloc_ts(c)
+ call alloc_td(d)
+ end subroutine
+
+end
