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;
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;
/* 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;
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;
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. */
}
/* 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);
/* 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);
" 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;
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);
--- /dev/null
+! { dg-do run }
+!
+! PR104650
+! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
+!
+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
projects / thirdparty / gcc.git / commitdiff
