This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [PATCH, Fortran] Derived type finalization: Already somewhat useable...
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches at gcc dot gnu dot org
- Date: Mon, 23 Jun 2008 10:30:11 +0200
- Subject: Re: [PATCH, Fortran] Derived type finalization: Already somewhat useable...
- References: <485E2BA8.4020003@domob.eu>
Daniel Kraft wrote:
here's what I would call a "first official patch" for derived type
finalization, despite the numerous ones already cycled to the list :D
Updated patch and changelog to implement correct auto-deallocation
behaviour, as discussed in my thread on comp.lang.fortran.
I adapted finalize_exec_7.f03 to reflect the correct behaviour and did
minor changes to the patch to implement this (only expr.c and resolve.c).
Daniel
It's already gotten rather big I'd say, but also already works for most
cases and events. Maybe we could work this out fully and get it checked
in even despite the not-yet-implemented special cases discuessed below?
Ok, about my patch: As usual with me, I've "some" XXX marks in it at
places that I wanted to remember, partly for me to look at later and
partly because of questions. I hope to resolve all of those before
check-in, so no XXX will be checked in ;).
General points I'm unsure about and would like to get extra-detailed
review:
* Because of my code generation, I'm at multiple places building
gfc_code/gfc_expr nodes (and others). I'm nearly nowhere sure if I did
this correctly (it just works), i.e. I filled in all members I need to,
didn't fill in members I shouldn't, use invalid intialization values,
and so on.
* For the same reason, at a lot of places I'm using gfc_expr nodes
somewhere in a built expression/statement. Most of the time I believe I
did wrap it into gfc_copy_expr because I intuitively think this is
correct, but please check if I somewhere copy an expression that should
not be copied and somewhere don't copy one that should be.
* build_intrinsic_call is surely absolutelly ugly and wrong, I'd love to
get correction here as to how to do this the right way without this
symbol stuff, which seems to be causing some testsuite failures (for
instance, use_allocated_1.f90). The current version just works for me
most of the time so I could use it for testing the other things based on
it.
My patch currently does not handle finalization of entities returned by
a function or structure constructor after they have been used as I think
that one could be difficult to do (but I haven't done much research yet,
it could also be easy; we'll see in the future), and the similar clause
about specification expressions.
As I pointed out on the list before, finalization of entities "when they
are deallocated" caused some extra-headache because of automatic
deallocation; I had to effectively duplicate the logic there to insert
finalization code each time before automatic deallocation would happen.
On the other hand, finalization and automatic deallocation have much
in common, so it wasn't that bad. I even propose we could remove the
implementation of auto-deallocation in trans and reuse the finalization
logic (only insert an additional EXEC_DEALLOCATE node at the place
marked in gfc_finalize_expr) once this patch and logic is working
properly. But this decision has time until finalization is done.
Regarding the auto-deallocation, I also came about some things in the
standard that are unclear to me, see my current thread at
comp.lang.fortran. For instance, according to my interpretation,
allocated ALLOCATABLE components of derived types should be
auto-deallocated when their parent type is *deallocated* (as pointer
target or being ALLOCATABLE itself), but I can't see why they are
auto-deallocated when a static entity of the parent derived type goes
out of scope. gfortran trunk *does* auto-deallocate such entities,
which seems reasonable to me but I can't read from the standard.
The standard also requires the implementation to auto-deallocate
ALLOCATABLE components in derived type function results, like the
requirement of those being finalized. This is currently not done by
gforran, too (as I pointed out, that could be difficult). That's the
reason for why I think we could try to check the current patch in before
working on that issue, as we could do the finalization *and*
auto-deallocation in this case together in a new patch.
I did implement the finalization in every case the way I read the
standard, which means that for instance with the static entity thing
finalization and auto-deallocation does not match as should be (gfortran
will deallocate the ALLOCATABLE components while they will not be
finalized first), but please clarify to me what of my understanding of
the standard is wrong, so I can adapt my implementation accordingly.
The patch as attached succeeds most of the testsuite on
GNU/Linux-x86-32, and I believe the old tests that fail are all due to
the build_intrinsic_call problem talked about above while the new
failures are due to lack of this temporary-result-finalization. For
checking this patch in we could take those checks out of their current
place and put them in new tests later when working on the new patch.
This got rather long, sorry... But I hope you've not been scared away.
Daniel
--
Done: Bar-Sam-Val-Wiz, Dwa-Elf-Hum-Orc, Cha-Law, Fem-Mal
Underway: Ran-Gno-Neu-Fem
To go: Arc-Cav-Hea-Kni-Mon-Pri-Rog-Tou
2008-06-22 Daniel Kraft <d@domob.eu>
* gfortran.h (gfc_finalizer): Renamed procedure member to proc_sym and
added new member proc_tree for saving already resolved symtree's.
(gfc_is_type_finalizable), (gfc_finalize_expr): New methods.
(gfc_resolve_code), (gfc_resolve_call), (gfc_find_sym_in_symtree): Made
those public.
* decl.c (gfc_match_final_decl): Changed usage of procedure member of
gfc_finalizer to proc_sym and set new proc_tree to NULL.
* expr.c (gfc_is_type_finalizable), (gfc_finalize_expr): New methods.
(generate_reference_expr), (build_intrinsic_call): New static helper
methods used for finalization.
(scalarize_derived_component_finalization),
(finalize_derived_components): New working methods for finalization.
* interface.c (gfc_find_sym_in_symtree): Made this public, renamed from
find_sym_in_symtree.
(gfc_extend_expr): Changed find_sym_in_symtree call to new name.
(gfc_extend_assign): Ditto.
* module.c (mio_finalizer): New function for storing FINAL procedures
in the module file.
(mio_f2k_derived), (mio_full_f2k_derived): Ditto.
(mio_symbol): Added call to load/save f2k_derived namespace using the
new methods above.
* resolve.c (generated_finalizers): New global static needed for
derived type finalization.
(finalize_intent_out_args), (put_finalizers_before): New helper
function for finalization.
(resolve_function): Call finalize_inten_out_args.
(gfc_resolve_call): Ditto and made public, renamed from reslve_call.
(resolve_deallocate_expr): Finalize expr before it is deallocated.
(resolve_allocate_deallocate): Call reslve_deallocate_expr with new
locus argument.
(resolve_where), (gfc_resolve_where_code_in_forall),
(gfc_resolve_forall_body): Adapted name in call to gfc_resolve_call.
(gfc_resolve_blocks): Ditto for gfc_resolve_code.
(gfc_resolve_code): Made public, insert code to generate finalization
code at appropriate places (RETURN, LHS of assignment).
(gfc_resolve_finalizers): Removed "not implemented" error and now
looking up the proc_sym symbol here to get the proc_tree symtree.
(finalize_sym_list): New private type used for finalization.
(finalize_only_allocatable), (finalize_symbols),
(finalize_symbols_tail): New private variabes used for finalization.
(find_finalizable_symbols), (call_finalizing_procedures_at),
(call_finalizing_procedures): New methods used for finalization of
symbols when going out of scope.
(resolve_codes): Initiate finalization of symbols at the end of scope.
2008-06-22 Daniel Kraft <d@domob.eu>
* gfortran.dg/finalize_4.f03: Removed expected "not implemented" error.
* gfortran.dg/finalize_5.f03: Ditto.
* gfortran.dg/finalize_6.f90: Ditto.
* gfortran.dg/finalize_7.f03: Ditto.
* gfortran.dg/finalize_exec_1.f03: New test.
* gfortran.dg/finalize_exec_2.f03: New test.
* gfortran.dg/finalize_exec_3.f03: New test.
* gfortran.dg/finalize_exec_4.f03: New test.
* gfortran.dg/finalize_exec_5.f03: New test.
* gfortran.dg/finalize_exec_6.f03: New test.
* gfortran.dg/finalize_exec_7.f03: New test.
* gfortran.dg/module_md5_1.f90: Corrected checksum for changed format
of module files due to storing FINAL procedures with derived types.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 136895)
+++ gcc/fortran/interface.c (working copy)
@@ -2502,8 +2502,8 @@ find_symtree0 (gfc_symtree *root, gfc_sy
/* Find a symtree for a symbol. */
-static gfc_symtree *
-find_sym_in_symtree (gfc_symbol *sym)
+gfc_symtree *
+gfc_find_sym_in_symtree (gfc_symbol *sym)
{
gfc_symtree *st;
gfc_namespace *ns;
@@ -2641,7 +2641,7 @@ gfc_extend_expr (gfc_expr *e)
/* Change the expression node to a function call. */
e->expr_type = EXPR_FUNCTION;
- e->symtree = find_sym_in_symtree (sym);
+ e->symtree = gfc_find_sym_in_symtree (sym);
e->value.function.actual = actual;
e->value.function.esym = NULL;
e->value.function.isym = NULL;
@@ -2707,7 +2707,7 @@ gfc_extend_assign (gfc_code *c, gfc_name
/* Replace the assignment with the call. */
c->op = EXEC_ASSIGN_CALL;
- c->symtree = find_sym_in_symtree (sym);
+ c->symtree = gfc_find_sym_in_symtree (sym);
c->expr = NULL;
c->expr2 = NULL;
c->ext.actual = actual;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 136895)
+++ gcc/fortran/symbol.c (working copy)
@@ -2069,6 +2069,7 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
lval->where = sym->declared_at;
lval->ts = sym->ts;
lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+ lval->ref = NULL;
/* It will always be a full array. */
lval->rank = sym->as ? sym->as->rank : 0;
@@ -2918,9 +2919,13 @@ gfc_free_finalizer (gfc_finalizer* el)
{
if (el)
{
- --el->procedure->refs;
- if (!el->procedure->refs)
- gfc_free_symbol (el->procedure);
+ if (el->proc_sym)
+ {
+ --el->proc_sym->refs;
+ if (!el->proc_sym->refs)
+ gfc_free_symbol (el->proc_sym);
+ }
+ /* XXX: Do we need to do something (deref) for the tree? */
gfc_free (el);
}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 136895)
+++ gcc/fortran/decl.c (working copy)
@@ -6535,6 +6535,7 @@ cleanup:
}
+
/* Match a FINAL declaration inside a derived type. */
match
@@ -6615,7 +6616,7 @@ gfc_match_final_decl (void)
/* Check if we already have this symbol in the list, this is an error. */
for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next)
- if (f->procedure == sym)
+ if (f->proc_sym == sym)
{
gfc_error ("'%s' at %C is already defined as FINAL procedure!",
name);
@@ -6626,7 +6627,8 @@ gfc_match_final_decl (void)
gcc_assert (gfc_current_block ()->f2k_derived);
++sym->refs;
f = gfc_getmem (sizeof (gfc_finalizer));
- f->procedure = sym;
+ f->proc_sym = sym;
+ f->proc_tree = NULL;
f->where = gfc_current_locus;
f->next = gfc_current_block ()->f2k_derived->finalizers;
gfc_current_block ()->f2k_derived->finalizers = f;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 136895)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1952,14 +1952,21 @@ typedef struct iterator_stack
iterator_stack;
extern iterator_stack *iter_stack;
-
/* Node in the linked list used for storing finalizer procedures. */
typedef struct gfc_finalizer
{
struct gfc_finalizer* next;
- gfc_symbol* procedure;
locus where; /* Where the FINAL declaration occured. */
+
+ /* Up to resolution, we want the gfc_symbol, there we lookup the corresponding
+ symtree and later need only that. This way, we can access and call the
+ finalizers from every context as they should be "always accessible". I
+ don't make this a union because we need the information whether proc_sym is
+ still referenced or not for dereferencing it on deleting a gfc_finalizer
+ structure. */
+ gfc_symbol* proc_sym;
+ gfc_symtree* proc_tree;
}
gfc_finalizer;
@@ -2321,6 +2328,9 @@ bool gfc_traverse_expr (gfc_expr *, gfc_
int);
void gfc_expr_set_symbols_referenced (gfc_expr *);
+bool gfc_is_type_finalizable (const gfc_typespec*, bool);
+bool gfc_finalize_expr (gfc_expr*, bool, gfc_code*, locus);
+
/* st.c */
extern gfc_code new_st;
@@ -2344,6 +2354,8 @@ try gfc_resolve_dim_arg (gfc_expr *);
int gfc_is_formal_arg (void);
void gfc_resolve_substring_charlen (gfc_expr *);
match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
+void gfc_resolve_code (gfc_code *, gfc_namespace *);
+try gfc_resolve_call (gfc_code *);
/* array.c */
@@ -2395,6 +2407,7 @@ try gfc_extend_assign (gfc_code *, gfc_n
try gfc_add_interface (gfc_symbol *);
gfc_interface *gfc_current_interface_head (void);
void gfc_set_current_interface_head (gfc_interface *);
+gfc_symtree *gfc_find_sym_in_symtree (gfc_symbol *);
/* io.c */
extern gfc_st_label format_asterisk;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 136895)
+++ gcc/fortran/expr.c (working copy)
@@ -3255,3 +3255,452 @@ gfc_expr_set_symbols_referenced (gfc_exp
{
gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
}
+
+
+/* Check if a given type is finalizable or if it has finalizable components.
+ ALLOCATABLE components are always "finalizable" in this context as they ought
+ to be auto-deallocated. */
+
+bool
+gfc_is_type_finalizable (const gfc_typespec* ts, bool comp_only)
+{
+ gfc_component* comp;
+
+ /* Only derived types are finalizable. */
+ if (ts->type != BT_DERIVED)
+ return false;
+
+ /* See if we have finalizable components. */
+ for (comp = ts->derived->components; comp; comp = comp->next)
+ if (comp->allocatable || (!comp->pointer
+ && gfc_is_type_finalizable (&comp->ts, false)))
+ return true;
+
+ /* If components only is requested, return here. */
+ if (comp_only)
+ return false;
+
+ /* Now the type is finalizable iff it has finalizer procedures. */
+ return ts->derived->f2k_derived && ts->derived->f2k_derived->finalizers;
+}
+
+
+/* Helper function to generate a gfc_expr from another one and adding one more
+ reference to the ref-chain. This reference itself is not filled, only a
+ pointer to it returned and the caller must ensure it is intialized
+ properly. */
+/* XXX: Make this a global, general purpose function? */
+
+static gfc_expr*
+generate_reference_expr (gfc_expr* expr, gfc_ref** reftail, ref_type type)
+{
+ gfc_expr* ref_expr = gfc_copy_expr (expr);
+
+ /* Find the tail of the references-list. */
+ if (!ref_expr->ref)
+ ref_expr->ref = *reftail = gfc_get_ref ();
+ else
+ {
+ for (*reftail = ref_expr->ref; (*reftail)->next; )
+ *reftail = (*reftail)->next;
+
+ /* If we are building an array-reference and the last element is AR_FULL,
+ just re-use that one instead of creating a new. So create and append
+ a new node if this is not the case. */
+ if (!(type == REF_ARRAY && (*reftail)->type == REF_ARRAY
+ && (*reftail)->u.ar.type == AR_FULL))
+ {
+ /* XXX: Can we assume this? This means we never get things like
+ arr(:, 42) and have to add another array-reference after that.
+ This way, we don't need to do the business of updating such an
+ already existing reference to our needs, as multiple
+ array-references in chain are not allowed/possible. */
+ gcc_assert ((*reftail)->type != REF_ARRAY || type != REF_ARRAY);
+
+ (*reftail)->next = gfc_get_ref ();
+ *reftail = (*reftail)->next;
+ }
+ }
+
+ /* Initialize with what is already known about the reference. */
+ (*reftail)->next = NULL;
+ (*reftail)->type = type;
+
+ return ref_expr;
+}
+
+
+/* Helper-function to build an intrinsic-call expression given some arguments.
+ This is used in finalization both for the ALLOCATED and SIZE intrinsics. */
+/* XXX: Is this already somewhere implemented? Make it general-purpose method?
+ Something else? Oh, and I believe the current implementation is rather
+ ugly and buggy (seems to cause some testsuite failures). */
+static gfc_expr* build_intrinsic_call (const char* name, ...)
+{
+ gfc_expr* result;
+ gfc_actual_arglist** args_out;
+ va_list args_in;
+
+ /* Build the basic function expression. */
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_FUNCTION;
+ result->ts.type = BT_UNKNOWN;
+ gfc_get_sym_tree (name, NULL, &result->symtree);
+ gfc_commit_symbols (); /* XXX: Need this here? */
+ gfc_set_sym_referenced (result->symtree->n.sym);
+
+ /* Walk the arguments and build the list of actual args. */
+ va_start (args_in, name);
+ result->value.function.actual = NULL;
+ for (args_out = &result->value.function.actual; ;
+ args_out = &(*args_out)->next)
+ {
+ gfc_expr* cur_arg;
+
+ cur_arg = va_arg (args_in, gfc_expr*);
+ if (!cur_arg)
+ break;
+
+ gcc_assert (*args_out == NULL);
+ *args_out = gfc_get_actual_arglist ();
+ (*args_out)->expr = gfc_copy_expr (cur_arg);
+ (*args_out)->next = NULL;
+ }
+ gcc_assert (*args_out == NULL);
+ va_end (args_in);
+
+ return result;
+}
+
+
+/* Build DO-loops to scalarize the finalization of components of
+ arrays of derived types. This function is used as a helper-function within
+ finalize_derived_components. */
+
+static bool finalize_derived_components (gfc_expr*, gfc_code*);
+
+static bool
+scalarize_derived_component_finalization (gfc_expr* expr, gfc_code* code,
+ gfc_array_spec* as)
+{
+ gfc_code* loop;
+ gfc_code* loop_head;
+ gfc_expr* aref_expr;
+ gfc_ref* aref;
+ int dim;
+ bool generated;
+
+ /* XXX: Do we need special care for as->type == AS_UNKNOWN or AS_ASSUMED_SIZE
+ or do we always know the rank and can call SIZE to get the boundaries? */
+
+ /* Copy the expression and initialize the array-reference element. */
+ aref_expr = generate_reference_expr (expr, &aref, REF_ARRAY);
+ aref->u.ar.type = AR_ELEMENT;
+ aref->u.ar.dimen = as->rank;
+ aref->u.ar.as = as;
+ aref->u.ar.offset = NULL;
+
+ /* Loop over the dimensions and build the nested loops. */
+ loop = loop_head = NULL;
+ for (dim = 0; dim != as->rank; ++dim)
+ {
+ gfc_symbol* itervar;
+ static int itervar_id;
+ char itername[16]; /* "__final_i_XXXXX\0" => 16 characters. */
+
+ /* Generate an INTEGER iteration-variable. */
+ /* XXX: Is this done correctly? Need to set any more members? */
+ /* XXX: Maybe use gfc_get_unique_symtree? */
+ snprintf(itername, sizeof (itername), "__final_i_%d", itervar_id++);
+ gfc_get_symbol (itername, gfc_current_ns, &itervar);
+ gfc_commit_symbols ();
+ itervar->ts.type = BT_INTEGER;
+ itervar->ts.kind = gfc_default_integer_kind;
+ gfc_set_sym_referenced (itervar);
+
+ /* Build a loop over the leading index. */
+ /* TODO: These could be DO CONCURRENT loops once supported. */
+
+ if (!loop_head)
+ loop_head = loop = gfc_get_code ();
+ else
+ {
+ loop->block->next = gfc_get_code ();
+ loop = loop->block->next;
+ }
+
+ loop->op = EXEC_DO;
+ loop->next = NULL;
+ loop->ext.iterator = gfc_get_iterator ();
+ loop->ext.iterator->var = gfc_lval_expr_from_sym (itervar);
+ loop->ext.iterator->step = gfc_int_expr(1);
+
+ /* XXX: Maybe there's a better way to do this? */
+ loop->ext.iterator->start = build_intrinsic_call ("lbound", expr,
+ gfc_int_expr (dim + 1),
+ NULL);
+ loop->ext.iterator->end = build_intrinsic_call ("ubound", expr,
+ gfc_int_expr (dim + 1),
+ NULL);
+
+ /* Generate the entry-point for the loop-body. */
+ loop->block = gfc_get_code ();
+ loop->block->op = EXEC_DO;
+ loop->block->next = NULL;
+
+ /* Index with our itervar into the current dimension. */
+ aref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
+ aref->u.ar.start[dim] = gfc_lval_expr_from_sym (itervar);
+ aref->u.ar.stride[dim] = aref->u.ar.end[dim] = NULL;
+ }
+ gcc_assert (loop && loop_head);
+
+ /* Try to finalize the scalarized expression. */
+ gfc_resolve_expr (aref_expr);
+ gcc_assert (aref_expr->rank == 0);
+ generated = finalize_derived_components (aref_expr, loop->block);
+
+ /* If nothing was generated, free everything done so far. This can happen
+ even for types with finalizable components if no matching finalizer was
+ found there. */
+ if (!generated)
+ {
+ gfc_free_statements (loop_head);
+ return false;
+ }
+
+ /* Otherwise, put the code in the chain. */
+ gfc_resolve_code (loop_head, gfc_current_ns);
+ loop_head->next = code->next;
+ code->next = loop_head;
+
+ return true;
+}
+
+
+/* Finalize the components of a derived type. */
+
+static bool
+finalize_derived_components (gfc_expr* expr, gfc_code* code)
+{
+ gfc_component* comp;
+ gfc_array_spec* as;
+ int rank;
+ bool generated = false;
+
+ if (!gfc_is_type_finalizable (&expr->ts, true))
+ return false;
+
+ /* XXX: How to do component ref for non-variable expressions? Might this even
+ ever be needed? */
+ gcc_assert (expr->expr_type == EXPR_VARIABLE);
+
+ /* Find array-specification and rank. */
+ as = expr->symtree->n.sym->as;
+ rank = expr->rank;
+ if (expr->ref)
+ {
+ gfc_ref* ref;
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ as = ref->u.c.component->as;
+ }
+ gcc_assert (rank == 0 || as);
+
+ /* Scalarize finalization of components if the expression we're about to
+ finalize is an array of a derived type with finalizable components. */
+ if (rank > 0)
+ {
+ gcc_assert (as);
+ return scalarize_derived_component_finalization (expr, code, as);
+ }
+
+ /* Finalize each finalizable, non-pointer component. ALLOCATABLE components
+ are finalized, too, as they are auto-deallocated. */
+ for (comp = expr->ts.derived->components; comp; comp = comp->next)
+ if (comp->allocatable || (!comp->pointer
+ && gfc_is_type_finalizable (&comp->ts, false)))
+ {
+ gfc_expr* cref_expr;
+ gfc_ref* reftail;
+
+ cref_expr = generate_reference_expr (expr, &reftail, REF_COMPONENT);
+ cref_expr->ts = comp->ts;
+
+ reftail->u.c.component = comp;
+ reftail->u.c.sym = expr->ts.derived;
+
+ if (comp->as)
+ {
+ cref_expr = generate_reference_expr (cref_expr, &reftail,
+ REF_ARRAY);
+ reftail->u.ar.type = AR_FULL;
+ /* XXX: I'm generally unsure if all places where I do/do not copy
+ things rather than referencing them directly are correct as they
+ are done. */
+ reftail->u.ar.as = gfc_copy_array_spec (comp->as);
+ }
+
+ cref_expr->rank = 0;
+ if (comp->as)
+ cref_expr->rank = comp->as->rank;
+
+ gfc_resolve_expr (cref_expr);
+ gcc_assert ((!comp->as && cref_expr->rank == 0)
+ || (comp->as && cref_expr->rank == comp->as->rank));
+
+ /* Finalize this expression. */
+ /* XXX: Locus ok like that or use something else? */
+ if (gfc_finalize_expr (cref_expr, comp->allocatable, code, comp->loc))
+ generated = true;
+ }
+
+ return generated;
+}
+
+
+/* Generate code to finalize a given expression if it needs to be finalized.
+ The generated code is attached to the code-chain given. This method is the
+ hook for finalization, implementing what the standard calls the "finalization
+ process" and is called from the various places where expressions need to be
+ finalized.
+ While ALLOCATABLE components are always auto-deallocated after the
+ finalization process, if dealloc_self is true, too, the entity itself will
+ be auto-deallocated after its finalization; this also wraps the whole
+ generated code inside a IF (ALLOCATED (expr)) condition.
+ True is returned if any code was generated. */
+
+bool
+gfc_finalize_expr (gfc_expr* expr, bool dealloc_self, gfc_code* code,
+ locus where)
+{
+ gfc_code* whole_code = NULL;
+ gfc_code* final_after = NULL;
+ gfc_finalizer* f;
+ gfc_symtree* proc;
+ int expr_rank;
+ bool generated = false;
+
+ gcc_assert (expr);
+
+ /* If this entity itself is autodeallocated, insert conditional around all
+ generated code to check if it is allocated at runtime. */
+ if (dealloc_self)
+ {
+ /* dealloc should only be set for ALLOCATABLE entities which in turn
+ should not be scalars. */
+ /* XXX: Mark this somehow so once ALLOCATABLE scalars are implemented this
+ is found. */
+ gcc_assert (expr->rank > 0);
+
+ /* Build an IF (ALLOCATED (expr)) statement wrapping the whole
+ finalization-logic following. */
+
+ whole_code = gfc_get_code ();
+ whole_code->op = EXEC_IF;
+ whole_code->expr = NULL;
+ whole_code->next = NULL;
+
+ whole_code->block = gfc_get_code ();
+ whole_code->block->op = EXEC_IF;
+ whole_code->block->expr = build_intrinsic_call ("allocated", expr, NULL);
+ whole_code->block->next = NULL;
+ final_after = whole_code->block;
+ }
+ else
+ {
+ /* Build a NOP instead of the IF to chain finalization code to. */
+ whole_code = gfc_get_code ();
+ whole_code->op = EXEC_NOP;
+ whole_code->next = NULL;
+ final_after = whole_code;
+ }
+
+ /* If we are no derived type or don't have a finalizer ourself, skip this
+ self-finalization part. */
+ if (expr->ts.type != BT_DERIVED || !expr->ts.derived->f2k_derived
+ || !expr->ts.derived->f2k_derived->finalizers)
+ goto finish;
+
+ expr_rank = expr->rank; /* Easy for expressions. */
+
+ /* Find a finalizer with the correct rank or an elemental
+ finalizer and call it. */
+ /* TODO: Also check for correct kind type parameters once those are
+ implemented in gfortran. */
+ proc = NULL;
+ f = expr->ts.derived->f2k_derived->finalizers;
+ for (; f && !proc; f = f->next)
+ {
+ int proc_rank = 0;
+ gcc_assert (f->proc_tree);
+ gcc_assert (f->proc_tree->n.sym->formal);
+ if (f->proc_tree->n.sym->formal->sym->as)
+ proc_rank = f->proc_tree->n.sym->formal->sym->as->rank;
+
+ if (expr_rank == proc_rank)
+ proc = f->proc_tree;
+ }
+
+ f = expr->ts.derived->f2k_derived->finalizers;
+ for (; f && !proc; f = f->next)
+ {
+ if (f->proc_tree->n.sym->attr.elemental)
+ proc = f->proc_tree;
+ }
+
+ /* Warn if we didn't find a suitable finalizer but others are defined for this
+ type. In this case, the standard mandates to simply call no procedure, but
+ this is probably something not intended by the user. */
+ if (!proc)
+ {
+ /* XXX: Make this better. */
+ gfc_warning ("No matching finalizer found for derived type '%s' and"
+ " rank %d at %L", expr->ts.derived->name, expr_rank, &where);
+ goto finish;
+ }
+
+ /* Build the subroutine call. */
+ gcc_assert (!final_after->next);
+ final_after->next = gfc_get_code ();
+ final_after = final_after->next;
+ final_after->loc = gfc_current_locus;
+ final_after->op = EXEC_CALL;
+ final_after->symtree = proc;
+ final_after->ext.actual = gfc_get_actual_arglist();
+ final_after->ext.actual->next = NULL;
+ final_after->ext.actual->expr = gfc_copy_expr (expr);
+ final_after->next = NULL;
+ generated = true;
+
+finish:
+
+ /* Finalize components, should be after our own finalizer call. */
+ if (finalize_derived_components (expr, final_after))
+ generated = true;
+
+ /* TODO: Here we could insert the auto-deallocation EXEC_DEALLOCATE statement
+ when moving auto-deallocation from trans to resolution. */
+
+ /* If anything was generated, resolve our code and insert it into the
+ code-chain. */
+ if (generated)
+ {
+ gfc_code* tail;
+
+ gfc_resolve_code (whole_code, gfc_current_ns);
+
+ for (tail = whole_code; tail->next; )
+ tail = tail->next;
+ tail->next = code->next;
+ code->next = whole_code;
+ }
+ else if (whole_code)
+ gfc_free_statements (whole_code);
+
+ return generated;
+}
+
+/* XXX: Just a side-note: Should ALLOCATABLE components be auto-deallocated
+ when their containing object is given to INTENT(OUT) and related things?
+ Or is this done? It seems this is happening. */
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 136895)
+++ gcc/fortran/module.c (working copy)
@@ -3161,6 +3161,79 @@ mio_namespace_ref (gfc_namespace **nsp)
}
+/* Save/restore the f2k_derived namespace of a derived-type symbol. */
+/* XXX: Check if this format is ok like I did it. */
+
+static void
+mio_finalizer (gfc_finalizer **f)
+{
+ if (iomode == IO_OUTPUT)
+ {
+ gcc_assert (*f);
+ gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
+ mio_symtree_ref (&(*f)->proc_tree);
+ }
+ else
+ {
+ *f = gfc_getmem (sizeof (gfc_finalizer));
+ (*f)->where = gfc_current_locus; /* Value should not matter. */
+ (*f)->next = NULL;
+
+ mio_symtree_ref (&(*f)->proc_tree);
+ (*f)->proc_sym = NULL;
+ }
+}
+
+static void
+mio_f2k_derived (gfc_namespace *f2k)
+{
+ /* Handle the list of finalizer procedures. */
+ mio_lparen ();
+ if (iomode == IO_OUTPUT)
+ {
+ gfc_finalizer *f;
+ for (f = f2k->finalizers; f; f = f->next)
+ mio_finalizer (&f);
+ }
+ else
+ {
+ f2k->finalizers = NULL;
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ gfc_finalizer *cur;
+ mio_finalizer (&cur);
+ cur->next = f2k->finalizers;
+ f2k->finalizers = cur;
+ }
+ }
+ mio_rparen ();
+}
+
+static void
+mio_full_f2k_derived (gfc_symbol *sym)
+{
+ mio_lparen ();
+
+ if (iomode == IO_OUTPUT)
+ {
+ if (sym->f2k_derived)
+ mio_f2k_derived (sym->f2k_derived);
+ }
+ else
+ {
+ if (peek_atom () != ATOM_RPAREN)
+ {
+ sym->f2k_derived = gfc_get_namespace (NULL, 0);
+ mio_f2k_derived (sym->f2k_derived);
+ }
+ else
+ gcc_assert (!sym->f2k_derived);
+ }
+
+ mio_rparen ();
+}
+
+
/* Unlike most other routines, the address of the symbol node is already
fixed on input and the name/module has already been filled in. */
@@ -3223,6 +3296,9 @@ mio_symbol (gfc_symbol *sym)
sym->component_access
= MIO_NAME (gfc_access) (sym->component_access, access_types);
+ /* Load/save the f2k_derived namespace of a derived-type symbol. */
+ mio_full_f2k_derived (sym);
+
mio_namelist (sym);
/* Add the fields that say whether this is from an intrinsic module,
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 136895)
+++ gcc/fortran/resolve.c (working copy)
@@ -76,6 +76,13 @@ static int current_entry_id;
/* We use bitmaps to determine if a branch target is valid. */
static bitmap_obstack labels_obstack;
+/* During resolution, finalizer-procedures may be generated that should then
+ be inserted into the code-chain prior the element being resolved at the
+ moment. This static structure serves as head for the list of finalizers
+ being generated; the content of this one itself is never used except its
+ next member. */
+static gfc_code generated_finalizers;
+
int
gfc_is_formal_arg (void)
{
@@ -2156,6 +2163,28 @@ gfc_iso_c_func_interface (gfc_symbol *sy
}
+/* Finalize actual arguments given to a function as INTENT(OUT) before the
+ actual call happens. */
+
+static void
+finalize_intent_out_args (gfc_formal_arglist* form, gfc_actual_arglist* act,
+ locus where)
+{
+ for (; form && act; form = form->next, act = act->next)
+ {
+ /* ALLOCATABLE entities are auto-deallocated when given to INTENT(OUT)
+ just like everything else is finalized there. So just include them
+ in the condition. */
+ /* XXX: Is this form->sym check ok here? But without, for instance
+ pointer_function_actual_1.f90 fails. */
+ if (form->sym && form->sym->attr.intent == INTENT_OUT &&
+ !form->sym->attr.pointer)
+ gfc_finalize_expr (act->expr, form->sym->attr.allocatable,
+ &generated_finalizers, where);
+ }
+}
+
+
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
@@ -2202,6 +2231,20 @@ resolve_function (gfc_expr *expr)
if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
return FAILURE;
+ /* Finalize arguments given to INTENT(OUT) before the actual call. */
+ /* XXX: Is it ok to insert the finalizer-call before the whole gfc_code
+ containing this function call? And here we even assume that this
+ function was called from some gfc_resolve_code...
+ What's about things like:
+ y = x + foobar (x), where foobar's argument is INTENT(OUT)?
+ Is this defined or similar to C where there's no sequence-point undefined
+ behaviour? If defined, when should x be finalized and what should the
+ value of the first x be? */
+ /* XXX: Can we replace (part of) this condition by an assertion? */
+ if (expr->symtree && expr->symtree->n.sym)
+ finalize_intent_out_args (expr->symtree->n.sym->formal,
+ expr->value.function.actual, expr->where);
+
/* Need to setup the call to the correct c_associated, depending on
the number of cptrs to user gives to compare. */
if (sym && sym->attr.is_iso_c == 1)
@@ -2772,8 +2815,8 @@ found:
for functions, subroutines and functions are stored differently and this
makes things awkward. */
-static try
-resolve_call (gfc_code *c)
+try
+gfc_resolve_call (gfc_code *c)
{
try t;
procedure_type ptype = PROC_INTRINSIC;
@@ -2825,6 +2868,11 @@ resolve_call (gfc_code *c)
if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
return FAILURE;
+ /* Finalize arguments given to INTENT(OUT) before the actual call. */
+ /* XXX: Could/should we do this in resolve_actual_arglist? */
+ gcc_assert (c->symtree->n.sym); /* XXX: Is this ok or use if instead? */
+ finalize_intent_out_args (c->symtree->n.sym->formal, c->ext.actual, c->loc);
+
/* Resume assumed_size checking. */
need_full_assumed_size--;
@@ -4598,7 +4646,7 @@ derived_inaccessible (gfc_symbol *sym)
a pointer or a full array. */
static try
-resolve_deallocate_expr (gfc_expr *e)
+resolve_deallocate_expr (gfc_expr *e, locus where)
{
symbol_attribute attr;
int allocatable, pointer, check_intent_in;
@@ -4656,6 +4704,12 @@ resolve_deallocate_expr (gfc_expr *e)
return FAILURE;
}
+ /* Finalize the expression before it gets deallocated. */
+ /* TODO: When merging auto-deallocation into finalization, we have to flag
+ an EXEC_DEALLOCATE node that it does *not* put a finalizer before itself
+ so we can't end up in an infinite loop. */
+ gfc_finalize_expr (e, false, &generated_finalizers, where);
+
return SUCCESS;
}
@@ -4708,6 +4762,44 @@ expr_to_initialize (gfc_expr *e)
}
+/* Put a list of finalizer calls before a given code expression in the list.
+ This requires replacing it in-place and is needed so we can insert those
+ calls *before* an RETURN or DEALLOCATE statement that causes the
+ finalization. */
+
+static gfc_code*
+put_finalizers_before (gfc_code* finalizers, gfc_code* code)
+{
+ gfc_code tmp;
+ gfc_code* tail;
+
+ if (!finalizers)
+ return code;
+
+ /* XXX: This swapping thing is a bit confusing, but I don't see
+ much a better solution without having to touch much code. Is this
+ ok like this?
+ And is it ok for expressions to change address during resolution? */
+
+ /* We need to swap the structure-values of finalizers and code so
+ we effectively can insert the finalizers *before* the deallocate
+ statement. */
+ tmp = *code;
+ *code = *finalizers;
+ *finalizers = tmp;
+
+ /* Now, link the deallocate-expression in finalizers as next of the
+ finalizer tail expression in code. */
+ gcc_assert (code);
+ for (tail = code; tail->next; )
+ tail = tail->next;
+ tail->next = finalizers;
+
+ /* We return the original expression but in a new location. */
+ return finalizers;
+}
+
+
/* Resolve the expression in an ALLOCATE statement, doing the additional
checks to see whether the expression is OK or not. The expression must
have a trailing array reference that gives the size of the array. */
@@ -4916,7 +5008,7 @@ resolve_allocate_deallocate (gfc_code *c
else
{
for (a = code->ext.alloc_list; a; a = a->next)
- resolve_deallocate_expr (a->expr);
+ resolve_deallocate_expr (a->expr, code->loc);
}
}
@@ -5710,7 +5802,7 @@ resolve_where (gfc_code *code, gfc_expr
case EXEC_ASSIGN_CALL:
- resolve_call (cnext);
+ gfc_resolve_call (cnext);
if (!cnext->resolved_sym->attr.elemental)
gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
&cnext->ext.actual->expr->where);
@@ -5795,7 +5887,7 @@ gfc_resolve_where_code_in_forall (gfc_co
/* WHERE operator assignment statement */
case EXEC_ASSIGN_CALL:
- resolve_call (cnext);
+ gfc_resolve_call (cnext);
if (!cnext->resolved_sym->attr.elemental)
gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
&cnext->ext.actual->expr->where);
@@ -5840,7 +5932,7 @@ gfc_resolve_forall_body (gfc_code *code,
break;
case EXEC_ASSIGN_CALL:
- resolve_call (c);
+ gfc_resolve_call (c);
break;
/* Because the gfc_resolve_blocks() will handle the nested FORALL,
@@ -5929,8 +6021,6 @@ gfc_resolve_forall (gfc_code *code, gfc_
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
DO code nodes. */
-static void resolve_code (gfc_code *, gfc_namespace *);
-
void
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
@@ -5993,7 +6083,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
gfc_internal_error ("resolve_block(): Bad block type");
}
- resolve_code (b->next, ns);
+ gfc_resolve_code (b->next, ns);
}
}
@@ -6139,11 +6229,14 @@ resolve_ordinary_assign (gfc_code *code,
return false;
}
+
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
-static void
-resolve_code (gfc_code *code, gfc_namespace *ns)
+static void call_finalizing_procedures_at (gfc_namespace *, gfc_code *);
+
+void
+gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
int forall_save;
@@ -6158,9 +6251,14 @@ resolve_code (gfc_code *code, gfc_namesp
for (; code; code = code->next)
{
+ gfc_code* old_finalchain;
+
frame.current = code;
forall_save = forall_flag;
+ old_finalchain = generated_finalizers.next;
+ generated_finalizers.next = NULL;
+
if (code->op == EXEC_FORALL)
{
forall_flag = 1;
@@ -6243,10 +6341,13 @@ resolve_code (gfc_code *code, gfc_namesp
break;
case EXEC_RETURN:
+ call_finalizing_procedures_at (ns, &generated_finalizers);
+
if (code->expr != NULL
- && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
+ && (code->expr->ts.type != BT_INTEGER || code->expr->rank))
gfc_error ("Alternate RETURN statement at %L requires a SCALAR-"
"INTEGER return specifier", &code->expr->where);
+
break;
case EXEC_INIT_ASSIGN:
@@ -6258,6 +6359,12 @@ resolve_code (gfc_code *code, gfc_namesp
if (resolve_ordinary_assign (code, ns))
goto call;
+ else
+ /* Finalize LHS of assignment before executing it. Do only if
+ not an error occured during the above resolution. */
+ if (code->expr)
+ gfc_finalize_expr (code->expr, false, &generated_finalizers,
+ code->loc);
break;
@@ -6304,7 +6411,7 @@ resolve_code (gfc_code *code, gfc_namesp
case EXEC_CALL:
call:
- resolve_call (code);
+ gfc_resolve_call (code);
break;
case EXEC_SELECT:
@@ -6442,6 +6549,11 @@ resolve_code (gfc_code *code, gfc_namesp
default:
gfc_internal_error ("resolve_code(): Bad statement code");
}
+
+ /* If finalizers were generated during the course of resolving the current
+ gfc_code, put them before it in the chain. */
+ code = put_finalizers_before (generated_finalizers.next, code);
+ generated_finalizers.next = old_finalchain;
}
cs_base = frame.prev;
@@ -7471,22 +7583,32 @@ gfc_resolve_finalizers (gfc_symbol* deri
gfc_finalizer* i;
int my_rank;
+ /* Skip this finalizer if we already resolved it. */
+ /* XXX: Probably we could skip the entire loop as all would already be
+ resolved, speeding things up. But if this difference would not matter,
+ I believe it's better and cleaner to keep the loop. */
+ if (list->proc_tree)
+ {
+ prev_link = &(list->next);
+ continue;
+ }
+
/* Check this exists and is a SUBROUTINE. */
- if (!list->procedure->attr.subroutine)
+ if (!list->proc_sym->attr.subroutine)
{
gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
- list->procedure->name, &list->where);
+ list->proc_sym->name, &list->where);
goto error;
}
/* We should have exactly one argument. */
- if (!list->procedure->formal || list->procedure->formal->next)
+ if (!list->proc_sym->formal || list->proc_sym->formal->next)
{
gfc_error ("FINAL procedure at %L must have exactly one argument",
&list->where);
goto error;
}
- arg = list->procedure->formal->sym;
+ arg = list->proc_sym->formal->sym;
/* This argument must be of our type. */
if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
@@ -7540,16 +7662,16 @@ gfc_resolve_finalizers (gfc_symbol* deri
{
/* Argument list might be empty; that is an error signalled earlier,
but we nevertheless continued resolving. */
- if (i->procedure->formal)
+ if (i->proc_sym->formal)
{
- gfc_symbol* i_arg = i->procedure->formal->sym;
+ gfc_symbol* i_arg = i->proc_sym->formal->sym;
const int i_rank = (i_arg->as ? i_arg->as->rank : 0);
if (i_rank == my_rank)
{
gfc_error ("FINAL procedure '%s' declared at %L has the same"
" rank (%d) as '%s'",
- list->procedure->name, &list->where, my_rank,
- i->procedure->name);
+ list->proc_sym->name, &list->where, my_rank,
+ i->proc_sym->name);
goto error;
}
}
@@ -7559,6 +7681,10 @@ gfc_resolve_finalizers (gfc_symbol* deri
if (!arg->as || arg->as->rank == 0)
seen_scalar = true;
+ /* Find the symtree for this procedure. */
+ gcc_assert (!list->proc_tree);
+ list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym);
+
prev_link = &list->next;
continue;
@@ -7579,9 +7705,6 @@ error:
" defined at %L, suggest also scalar one",
derived->name, &derived->declared_at);
- /* TODO: Remove this error when finalization is finished. */
- gfc_error ("Finalization at %L is not yet implemented", &derived->declared_at);
-
return result;
}
@@ -9285,6 +9408,119 @@ resolve_types (gfc_namespace *ns)
}
+/* If a symbol is of a derived type with a finalizer, find
+ the correct subroutine and call it. */
+
+typedef struct finalize_sym_list
+{
+ gfc_symbol* sym;
+ struct finalize_sym_list* next;
+}
+finalize_sym_list;
+
+static bool finalize_only_allocatable; /* Set if we are in main PROGRAM. */
+static finalize_sym_list* finalize_symbols;
+static finalize_sym_list* finalize_symbols_tail;
+
+static void
+find_finalizable_symbols (gfc_symbol *sym)
+{
+ if (sym->attr.flavor != FL_VARIABLE || sym->attr.dummy)
+ return;
+
+ /* Don't finalize POINTER/SAVE entities. ALLOCATABLE components are
+ finalized, though, as they will be auto-deallocated here and thus need
+ finalization, too. */
+ if (sym->attr.pointer || sym->attr.save != SAVE_NONE)
+ return;
+
+ /* If we are inside the main PROGRAM, *only* ALLOCATABLE entities are
+ finalized because the standard explicitelly requests variables there not
+ to be finalized but ALLOCATABLE entities are auto-deallocated there. */
+ if (finalize_only_allocatable && !sym->attr.allocatable)
+ return;
+
+ /* Remember this symbol to be finalized. */
+ if (!finalize_symbols)
+ {
+ finalize_symbols = gfc_getmem (sizeof (finalize_sym_list));
+ finalize_symbols_tail = finalize_symbols;
+ }
+ else
+ {
+ gcc_assert (!finalize_symbols_tail->next);
+ finalize_symbols_tail->next = gfc_getmem (sizeof (finalize_sym_list));
+ finalize_symbols_tail = finalize_symbols_tail->next;
+ }
+ finalize_symbols_tail->sym = sym;
+ finalize_symbols_tail->next = NULL;
+}
+
+
+/* Generate the calls to finalizer procedures for all finalizable entities
+ in the current namespace and put then after the given code. */
+
+static void
+call_finalizing_procedures_at (gfc_namespace* ns, gfc_code* code)
+{
+ finalize_sym_list* i;
+
+ /* Variables in main program are not finalized unless ALLOCATABLE in which
+ case they are still auto-deallocated and need finalization because of
+ that. */
+ finalize_only_allocatable = (ns->proc_name
+ && ns->proc_name->attr.flavor == FL_PROGRAM);
+
+ /* First, we walk the namespace and build a list of symbols to finalize.
+ In the next step and only after this list is completed we start with the
+ actual finalization. It has to be done that way because finalization can
+ generate new symbols possibly rebalancing the tree and thus messing the
+ traversal up. */
+
+ finalize_symbols_tail = finalize_symbols = NULL;
+ gfc_traverse_ns (ns, find_finalizable_symbols);
+
+ gcc_assert (code);
+ for (i = finalize_symbols; i; )
+ {
+ finalize_sym_list* old;
+
+ if (gfc_finalize_expr (gfc_lval_expr_from_sym (i->sym),
+ i->sym->attr.allocatable, code, gfc_current_locus))
+ gfc_set_sym_referenced (i->sym);
+
+ old = i;
+ i = i->next;
+ gfc_free (old);
+ }
+ finalize_symbols_tail = finalize_symbols = NULL;
+}
+
+
+/* Generate the procedure calls for derived types with a finalizing
+ procedure by running to the end of the code and adding the calls
+ explicitly. */
+
+static void
+call_finalizing_procedures (gfc_namespace* ns)
+{
+ gfc_code* code;
+
+ /* If there's no code, generate a NOP as head of the chain. */
+ if (!ns->code)
+ {
+ ns->code = gfc_get_code ();
+ ns->code->op = EXEC_NOP;
+ ns->code->next = NULL;
+ }
+
+ /* Find the tail, and append the calls there. */
+ for(code = ns->code; code && code->next; )
+ code = code->next;
+ call_finalizing_procedures_at (ns, code);
+}
+
+
/* Call resolve_code recursively. */
static void
@@ -9301,7 +9537,8 @@ resolve_codes (gfc_namespace *ns)
current_entry_id = -1;
bitmap_obstack_initialize (&labels_obstack);
- resolve_code (ns->code, ns);
+ gfc_resolve_code (ns->code, ns);
+ call_finalizing_procedures (ns);
bitmap_obstack_release (&labels_obstack);
}
Index: gcc/testsuite/gfortran.dg/finalize_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_5.f03 (revision 136895)
+++ gcc/testsuite/gfortran.dg/finalize_5.f03 (working copy)
@@ -108,7 +108,4 @@ PROGRAM finalizer
! Nothing here, errors above
END PROGRAM finalizer
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
-
! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_7.f03 (revision 136895)
+++ gcc/testsuite/gfortran.dg/finalize_7.f03 (working copy)
@@ -53,7 +53,4 @@ PROGRAM finalizer
! Nothing here
END PROGRAM finalizer
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
-
! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_6.f90 (revision 136895)
+++ gcc/testsuite/gfortran.dg/finalize_6.f90 (working copy)
@@ -29,7 +29,4 @@ PROGRAM finalizer
! Do nothing
END PROGRAM finalizer
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
-
! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_1.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_1.f03 (revision 0)
@@ -0,0 +1,120 @@
+! { dg-do run }
+
+! Execution of finalizer procedure definitions.
+! Check that finalization finds and calls the correct FINAL procedures.
+
+! TODO: Test with different kind type parameters once they are implemented.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ INTEGER, TARGET :: sum
+
+ ! Type with scalar and matrix but not vector finalizer
+ TYPE :: type_1
+ INTEGER :: id
+ CONTAINS
+ FINAL :: fin_1_single, fin_1_matrix
+ END TYPE type_1
+
+ ! Type with elemental finalizer
+ ! We need the pointer-thing here so that the ELEMENTAL (and thus PURE)
+ ! finalizer can actually change the hash.
+ TYPE :: type_2
+ INTEGER :: id
+ INTEGER, POINTER :: sum
+ CONTAINS
+ FINAL :: fin_2_elemental, fin_2_vector
+ END TYPE type_2
+
+CONTAINS
+
+ SUBROUTINE fin_1_single (el)
+ IMPLICIT NONE
+ TYPE(type_1) :: el
+ sum = sum * 3**el%id
+ END SUBROUTINE fin_1_single
+
+ SUBROUTINE fin_1_matrix (el)
+ IMPLICIT NONE
+ TYPE(type_1) :: el(:, :)
+ sum = sum * 5**el(1, 1)%id
+ END SUBROUTINE fin_1_matrix
+
+ ELEMENTAL SUBROUTINE fin_2_elemental (el)
+ IMPLICIT NONE
+ TYPE(type_2), INTENT(INOUT) :: el
+ el%sum = el%sum * 7**el%id
+ END SUBROUTINE fin_2_elemental
+
+ SUBROUTINE fin_2_vector (el)
+ IMPLICIT NONE
+ TYPE(type_2) :: el(:)
+ sum = sum * 11**(el(1)%id + el(2)%id)
+ END SUBROUTINE fin_2_vector
+
+END MODULE final_type
+
+INTEGER FUNCTION test ()
+ USE final_type
+ IMPLICIT NONE
+
+ TYPE(type_1) :: t1_single, t1_vector(2), t1_matrix(2, 2)
+ TYPE(type_2) :: t2_single, t2_vector(2), t2_matrix(2, 2)
+
+ t1_single%id = 1
+ t1_vector%id = 2
+ t1_matrix%id = 3
+
+ t2_single%id = 4
+ t2_single%sum => sum
+
+ t2_vector(1)%id = 5
+ t2_vector(2)%id = 6
+ t2_vector(1)%sum => sum
+ t2_vector(2)%sum => sum
+
+ t2_matrix(1, 1)%id = 7
+ t2_matrix(2, 1)%id = 8
+ t2_matrix(1, 2)%id = 9
+ t2_matrix(2, 2)%id = 10
+ t2_matrix(1, 1)%sum => sum
+ t2_matrix(2, 1)%sum => sum
+ t2_matrix(1, 2)%sum => sum
+ t2_matrix(2, 2)%sum => sum
+
+ ! To do the check, we can't rely on the output as the order of finalization is
+ ! undefined. Thus, we calculate the "hash-sum" of the procedure-calls.
+ ! First, we call the procedures as the finalizer should do later manually and
+ ! store the calculated, "correct" hash-sum; this value is then returned from
+ ! the function, and then finalization should happen.
+ ! The main program must then compare if the returned, calculated hash equals
+ ! the one calculated during real finalization.
+
+ sum = 1
+ CALL fin_1_single (t1_single)
+ ! No finalization for t1_vector
+ CALL fin_1_matrix (t1_matrix)
+ CALL fin_2_elemental (t2_single)
+ CALL fin_2_vector (t2_vector)
+ CALL fin_2_elemental (t2_matrix)
+ test = sum
+
+ sum = 1
+ ! Now finalization happens
+END FUNCTION test ! { dg-warning "No matching finalizer found" }
+
+PROGRAM finalizer
+ USE final_type, ONLY: sum
+ IMPLICIT NONE
+ INTEGER :: test
+ INTEGER :: expected
+
+ expected = test ()
+ IF (expected /= sum) THEN
+ WRITE (*,*) expected, sum
+ CALL abort ()
+ END IF
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_2.f03 (revision 0)
@@ -0,0 +1,47 @@
+! { dg-do run }
+
+! Execution of finalizer procedure definitions.
+! Checks that finalizers are called even for leaving empty procedures.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ LOGICAL :: finalized
+
+ TYPE :: mytype
+ CONTAINS
+ FINAL :: finalizer
+ END TYPE mytype
+
+CONTAINS
+
+ SUBROUTINE finalizer (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el
+
+ IF (finalized) THEN
+ CALL abort ()
+ END IF
+ finalized = .TRUE.
+ END SUBROUTINE finalizer
+
+ SUBROUTINE test ()
+ IMPLICIT NONE
+ TYPE(mytype) :: var
+ ! Empty here
+ END SUBROUTINE test
+
+END MODULE final_type
+
+PROGRAM main
+ USE final_type, ONLY: finalized, test
+ IMPLICIT NONE
+
+ finalized = .FALSE.
+ CALL test ()
+ IF (.NOT. finalized) THEN
+ CALL abort ()
+ END IF
+END PROGRAM main
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_3.f03 (revision 0)
@@ -0,0 +1,96 @@
+! { dg-do run }
+
+! Execution of finalizer procedure definitions.
+! Check that POINTER- and other non-finalizable entities are
+! indeed not finalized.
+
+MODULE final_mod
+ IMPLICIT NONE
+
+ ! Instances should not be finalized
+ TYPE :: no_t
+ CONTAINS
+ FINAL :: final_no_single, final_no_vector
+ END TYPE no_t
+
+ ! This detects when it is finalized
+ TYPE :: sherlock_t
+ LOGICAL :: finalized = .FALSE.
+ CONTAINS
+ FINAL :: final_sherlock
+ END TYPE sherlock_t
+
+ ! Module-variables should not be finalized
+ TYPE(no_t) :: in_module
+
+CONTAINS
+
+ SUBROUTINE final_no_single (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el
+ WRITE (*,*) "no_t scalar finalized"
+ CALL abort ()
+ END SUBROUTINE final_no_single
+
+ SUBROUTINE final_no_vector (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el(:)
+ WRITE (*,*) "no_t vector finalized"
+ CALL abort ()
+ END SUBROUTINE final_no_vector
+
+ SUBROUTINE final_sherlock (el)
+ IMPLICIT NONE
+ TYPE(sherlock_t) :: el
+
+ IF (el%finalized) THEN
+ WRITE (*,*) "Already finalized"
+ CALL abort ()
+ END IF
+ el%finalized = .TRUE.
+ END SUBROUTINE final_sherlock
+
+ ! Check that dummy arguments and return variables are not finalized
+ TYPE(sherlock_t) FUNCTION foobar (val)
+ IMPLICIT NONE
+ TYPE(no_t) :: val
+
+ foobar = sherlock_t ()
+ ! val should not be finalized here, as shouldn't foobar
+ END FUNCTION foobar
+
+ SUBROUTINE test ()
+ IMPLICIT NONE
+
+ ! Don't finalize POINTER variables
+ TYPE(no_t), POINTER :: ptr
+
+ ! Don't finalize SAVE attributed variables
+ TYPE(no_t), SAVE :: saved
+
+ ! No check here for ALLOCATABLE variables as they are auto-deallocated and
+ ! therefore effectively finalized.
+
+ TYPE(sherlock_t) :: sher
+
+ ! Should not have been finalized before return!
+ sher = foobar (saved)
+ IF (sher%finalized) THEN
+ WRITE (*,*) "Return value finalized"
+ CALL abort ()
+ END IF
+ END SUBROUTINE test
+
+END MODULE final_mod
+
+PROGRAM main
+ USE final_mod, ONLY: no_t, test
+ IMPLICIT NONE
+
+ ! Don't finalize entities in main program
+ TYPE(no_t) :: in_main
+
+ CALL test ()
+END PROGRAM main
+
+! { dg-final { cleanup-modules "final_mod" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_4.f03 (revision 0)
@@ -0,0 +1,125 @@
+! { dg-do run }
+
+! Execution of finalizer procedure definitions.
+! Check for correct handling of finalizable components in derived types.
+
+! TODO: Handle finalization of parent type when inheritance is done
+
+MODULE final_mod
+ IMPLICIT NONE
+
+ ! Count how often yes_t is finalized
+ INTEGER :: sum = 0
+
+ ! Instances should not be finalized
+ TYPE :: no_t
+ CONTAINS
+ FINAL :: final_no_single, final_no_vector
+ END TYPE no_t
+
+ ! This detects when it is finalized
+ TYPE :: yes_t
+ LOGICAL :: finalized = .FALSE.
+ CONTAINS
+ FINAL :: final_yes
+ END TYPE yes_t
+
+ ! Derived type with no_t/yes_t components
+ ! While the ALLOCATABLE component could be finalized during auto-deallocation,
+ ! in this test it will never be allocated and thus never be finalized.
+ TYPE :: comp_t
+ TYPE(no_t), ALLOCATABLE :: alloc(:)
+ ! XXX: Why compile error otherwise?
+ !TYPE(no_t), POINTER :: ptr
+ TYPE(yes_t) :: itsok
+ CONTAINS
+ FINAL :: final_comp
+ END TYPE comp_t
+
+ ! Derived type without explicit finalizer procedure
+ TYPE :: pure_t
+ TYPE(yes_t) :: comp
+ END TYPE pure_t
+
+ ! More complex derived type
+ TYPE :: complex_t
+ TYPE(pure_t) :: matrix(2, 2)
+ END TYPE complex_t
+
+CONTAINS
+
+ SUBROUTINE final_no_single (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el
+
+ WRITE (*,*) "A no_t finalized!"
+ CALL abort ()
+ END SUBROUTINE final_no_single
+
+ SUBROUTINE final_no_vector (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el(:)
+
+ WRITE (*,*) "A no_t finalized!"
+ CALL abort ()
+ END SUBROUTINE final_no_vector
+
+ SUBROUTINE final_yes (el)
+ IMPLICIT NONE
+ TYPE(yes_t) :: el
+
+ sum = sum + 1
+ IF (el%finalized) THEN
+ CALL abort ()
+ END IF
+ el%finalized = .TRUE.
+ END SUBROUTINE final_yes
+
+ SUBROUTINE final_comp (el)
+ IMPLICIT NONE
+ TYPE(comp_t) :: el
+
+ ! Up to here, all components should still be there. Check that this
+ ! finalizer is really called before the components themselves are finalized.
+ IF (el%itsok%finalized) THEN
+ WRITE (*,*) "Wrong finalization order!"
+ CALL abort ()
+ END IF
+
+ ! Now the components should be finalized
+ END SUBROUTINE final_comp
+
+END MODULE final_mod
+
+SUBROUTINE test (n)
+ USE final_mod
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: n
+
+ TYPE(comp_t) :: hello
+ TYPE(pure_t) :: world(n)
+ TYPE(complex_t) :: compl
+
+ ! Do something so this is not empty
+ WRITE (*,*) "foobar"
+END SUBROUTINE test
+
+PROGRAM main
+ USE final_mod, ONLY: sum
+ IMPLICIT NONE
+
+ ! In sum, these instances of yes_t should be finalized in test:
+ ! * one in hello
+ ! * one each in world, in sum n=3
+ ! * 4 in compl
+ ! => 1+3+4=8
+ INTEGER, PARAMETER :: expected = 8
+
+ CALL test (3)
+ IF (sum /= expected) THEN
+ WRITE (*,*) "Mismatch in yes_t finalization:", sum, expected
+ CALL abort ()
+ END IF
+END PROGRAM main
+
+! { dg-final { cleanup-modules "final_mod" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_5.f03 (revision 0)
@@ -0,0 +1,119 @@
+! { dg-do run }
+
+! Execution of finalizer procedure definitions.
+! Check for the multiple places where entities should be finalized.
+
+! XXX: Assignment (and possible function calls and others) inside WHERE/FORALL
+
+MODULE final_mod
+ IMPLICIT NONE
+
+ ! Count how often yes_t is finalized
+ INTEGER :: cnt_single = 0
+ INTEGER :: cnt_vector = 0
+
+ ! This detects when it is finalized
+ TYPE :: yes_t
+ CONTAINS
+ FINAL :: final_yes_single, final_yes_vector
+ END TYPE yes_t
+
+CONTAINS
+
+ SUBROUTINE final_yes_single (el)
+ IMPLICIT NONE
+ TYPE(yes_t) :: el
+ cnt_single = cnt_single + 1
+ END SUBROUTINE final_yes_single
+
+ SUBROUTINE final_yes_vector (el)
+ IMPLICIT NONE
+ TYPE(yes_t) :: el(:)
+ cnt_vector = cnt_vector + 1
+ END SUBROUTINE final_yes_vector
+
+ ! Test for finalization on deallocating something
+ SUBROUTINE test_deallocate (dummy)
+ IMPLICIT NONE
+
+ TYPE(yes_t), INTENT(OUT) :: dummy
+
+ TYPE(yes_t), POINTER :: ptr
+ TYPE(yes_t), ALLOCATABLE :: alloc_vector(:)
+
+ ALLOCATE(ptr)
+ ALLOCATE(alloc_vector(5))
+
+ DEALLOCATE(ptr)
+ ! alloc_vector is deallocated automatically here
+
+ ! This subroutine should cause two scalar and one vector finalization,
+ ! including the one from INTENT(OUT).
+ END SUBROUTINE test_deallocate
+
+ ! Test for finalization on END/RETURN from a procedure.
+ ! Additionally, take some INTENT(OUT) arguments and return some value for
+ ! checks regarding those two being finalized before/after the call.
+ FUNCTION test_function (dummy, ret)
+ IMPLICIT NONE
+
+ TYPE(yes_t), INTENT(OUT) :: dummy
+ LOGICAL, INTENT(IN) :: ret
+ TYPE(yes_t) :: test_function
+
+ TYPE(yes_t) :: local
+
+ IF (ret) RETURN
+ ! Otherwise, execute END
+
+ ! A call to this function should cause one finalization here, one for the
+ ! INTENT(OUT)-argument and one of the return value. All of those scalar.
+ END FUNCTION test_function
+
+ ! An elemental-procedure with INTENT(OUT) argument.
+ ELEMENTAL SUBROUTINE test_elemental_intent_out (arg)
+ IMPLICIT NONE
+ TYPE(yes_t), INTENT(OUT) :: arg
+ ! Do nothing to arg.
+
+ ! A call to this subroutine with a vector should cause a single
+ ! vector finalization rather than finalizing all elements together.
+ END SUBROUTINE test_elemental_intent_out
+
+END MODULE final_mod
+
+PROGRAM main
+ USE final_mod
+ IMPLICIT NONE
+
+ ! 2 from test_deallocate, 2*3 from test_function, 3 for the assignments and
+ ! 1 from the structure-constructor temporary.
+ INTEGER, PARAMETER :: expected_single = 12
+
+ ! 1 vector finalization in test_deallocate and 1 from the INTENT(OUT) to
+ ! test_elemental_intent_out.
+ INTEGER, PARAMETER :: expected_vector = 2
+
+ TYPE(yes_t) :: var, vect (42)
+
+ ! Perform some test-actions
+ CALL test_deallocate (var)
+ CALL test_elemental_intent_out (vect)
+ var = test_function (var, .TRUE.)
+ var = test_function (var, .FALSE.)
+ var = yes_t ()
+
+ ! XXX: What does the specification-expression paragraph in the standard mean?
+
+ ! Check that the counters match the expectations
+ IF (cnt_vector /= expected_vector) THEN
+ WRITE (*,*) "Mismatch in vector finalization:", cnt_vector, expected_vector
+ CALL abort ()
+ END IF
+ IF (cnt_single /= expected_single) THEN
+ WRITE (*,*) "Mismatch in scalar finalization:", cnt_single, expected_single
+ CALL abort ()
+ END IF
+END PROGRAM main
+
+! { dg-final { cleanup-modules "final_mod" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_6.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_6.f03 (revision 0)
@@ -0,0 +1,113 @@
+! { dg-do run }
+! { dg-options "-std=gnu" }
+! Allow RETURN in main program
+
+! Execution of finalizer procedure definitions.
+! Some more exceptional cases where variables should *not* be finalized.
+
+MODULE final_mod
+ IMPLICIT NONE
+
+ ! Count how often yes_t is finalized
+ INTEGER :: cnt = 0
+
+ ! This detects when it is finalized
+ TYPE :: yes_t
+ CONTAINS
+ FINAL :: final_yes
+ END TYPE yes_t
+
+ ! This should not be finalized at all
+ TYPE :: no_t
+ CONTAINS
+ FINAL :: final_no_single, final_no_vector
+ END TYPE no_t
+
+ ! Define operator= interface for non-intrinsic assignment check.
+ INTERFACE ASSIGNMENT(=)
+ MODULE PROCEDURE assign_yes
+ END INTERFACE ASSIGNMENT(=)
+
+CONTAINS
+
+ SUBROUTINE final_yes (el)
+ IMPLICIT NONE
+ TYPE(yes_t) :: el
+ cnt = cnt + 1
+ END SUBROUTINE final_yes
+
+ SUBROUTINE final_no_single (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el
+ CALL abort ()
+ END SUBROUTINE final_no_single
+
+ SUBROUTINE final_no_vector (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el(:)
+ CALL abort ()
+ END SUBROUTINE final_no_vector
+
+ ! Takes a pointer INTENT(OUT) arguments that should *not* be finalized.
+ ! ALLOCATABLE arguments should not, either, but those are auto-deallocated
+ ! and thus effectively finalized.
+ SUBROUTINE test_ptr_alloc (ptr)
+ IMPLICIT NONE
+ TYPE(no_t), POINTER, INTENT(OUT) :: ptr
+ TYPE(no_t), ALLOCATABLE :: alloc(:)
+ ! alloc is auto-deallocated here, but it should not be finalized as it is
+ ! not allocated and thus NULL.
+ END SUBROUTINE test_ptr_alloc
+
+ ! Assignment-routine for yes_t
+ SUBROUTINE assign_yes (dest, src)
+ IMPLICIT NONE
+ TYPE(yes_t), INTENT(OUT) :: dest
+ TYPE(yes_t), INTENT(IN) :: src
+ ! Do nothing.
+
+ ! var = something should finalize var once for giving to INTENT(OUT) here,
+ ! but not for being on the LHS of an assignment.
+ END SUBROUTINE assign_yes
+
+END MODULE final_mod
+
+! This SUBROUTINE does not have an explicit interface
+SUBROUTINE test_implicit_intf (arg)
+ USE final_mod, ONLY: no_t
+ IMPLICIT NONE
+ TYPE(no_t), INTENT(OUT) :: arg
+ ! Do nothing.
+
+ ! arg should not be finalized when this SUBROUTINE is called as it does not
+ ! have an explicit interface.
+END SUBROUTINE test_implicit_intf
+
+PROGRAM main
+ USE final_mod
+ IMPLICIT NONE
+
+ ! 1 finalization is expected from the INTENT(OUT) of assign_yes
+ INTEGER, PARAMETER :: expected = 1
+
+ TYPE(no_t), POINTER :: ptr
+ TYPE(no_t) :: local_no
+
+ TYPE(yes_t) :: local_yes
+
+ ! Perform some test-actions
+ CALL test_ptr_alloc (ptr)
+ CALL test_implicit_intf (local_no)
+ local_yes = local_yes
+
+ ! Check that the counters match the expectations
+ IF (cnt /= expected) THEN
+ WRITE (*,*) "Mismatch in yes_t finalization:", cnt, expected
+ CALL abort ()
+ END IF
+
+ ! local should not be finalized. Test this is true also for RETURN.
+ RETURN
+END PROGRAM main
+
+! { dg-final { cleanup-modules "final_mod" } }
Index: gcc/testsuite/gfortran.dg/finalize_exec_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_exec_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_exec_7.f03 (revision 0)
@@ -0,0 +1,186 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+
+! Execution of finalizer procedure definitions.
+! Check for correct finalization with automatic deallocation.
+
+MODULE final_mod
+ IMPLICIT NONE
+
+ ! Count how often yes_t is finalized
+ INTEGER :: cnt_scalar = 0
+ INTEGER :: cnt_vector = 0
+
+ ! This detects when it is finalized
+ TYPE :: yes_t
+ CONTAINS
+ FINAL :: final_yes_scalar, final_yes_vector
+ END TYPE yes_t
+
+ ! This should not be finalized
+ TYPE :: no_t
+ CONTAINS
+ FINAL :: final_no_scalar, final_no_vector
+ END TYPE no_t
+
+ ! This is a compound type with ALLOCATABLE components
+ TYPE :: comp_t
+ TYPE(yes_t) :: scalar
+ TYPE(yes_t), ALLOCATABLE :: vector(:)
+ END TYPE comp_t
+
+ ! That's a compound type with *only* ALLOCATABLE component
+ TYPE :: onlyalloc_t
+ TYPE(yes_t), ALLOCATABLE :: vector(:)
+ TYPE(no_t), ALLOCATABLE :: novect(:)
+ END TYPE onlyalloc_t
+
+ ! Nest ALLOCATABLE component of comp_t two levels deep
+ TYPE :: nested_comp_t
+ TYPE(comp_t) :: comp
+ END TYPE nested_comp_t
+
+CONTAINS
+
+ SUBROUTINE final_yes_scalar (el)
+ IMPLICIT NONE
+ TYPE(yes_t) :: el
+ cnt_scalar = cnt_scalar + 1
+ END SUBROUTINE final_yes_scalar
+
+ SUBROUTINE final_yes_vector (el)
+ IMPLICIT NONE
+ TYPE(yes_t) :: el(:)
+ cnt_vector = cnt_vector + 1
+ END SUBROUTINE final_yes_vector
+
+ SUBROUTINE final_no_scalar (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el
+ WRITE (*,*) "no_t scalar finalized"
+ CALL abort ()
+ END SUBROUTINE final_no_scalar
+
+ SUBROUTINE final_no_vector (el)
+ IMPLICIT NONE
+ TYPE(no_t) :: el(:)
+ WRITE (*,*) "no_t vector finalized"
+ CALL abort ()
+ END SUBROUTINE final_no_vector
+
+ ! Giving an ALLOCATABLE array to INTENT(OUT) deallocates it.
+ SUBROUTINE test_intent_out (arr)
+ IMPLICIT NONE
+ TYPE(yes_t), ALLOCATABLE, INTENT(OUT) :: arr(:)
+ ALLOCATE(arr(5))
+ ! arr should be deallocated and finalized once when given to INTENT(OUT)
+ END SUBROUTINE test_intent_out
+
+ ! Function returning a comp_t to check the intrinsic assignment thing.
+ TYPE(comp_t) FUNCTION get_compound ()
+ IMPLICIT NONE
+ ALLOCATE (get_compound%vector(42))
+ END FUNCTION get_compound
+
+END MODULE final_mod
+
+! Test for automatic deallocation on RETURN/scope exit.
+SUBROUTINE test (ret)
+ USE final_mod
+ IMPLICIT NONE
+
+ LOGICAL, INTENT(IN) :: ret
+
+ TYPE(yes_t), ALLOCATABLE :: yes_vect(:)
+ TYPE(comp_t), ALLOCATABLE :: comp_vector_1(:), comp_vector_2(:)
+ TYPE(onlyalloc_t), ALLOCATABLE :: onlyalloc(:)
+ TYPE(comp_t) :: comp_static
+ TYPE(nested_comp_t) :: nested
+
+ ! XXX: Should we also include a test with assumed size?
+
+ ALLOCATE (yes_vect(5))
+ ALLOCATE (comp_vector_2(2:3))
+ ALLOCATE (comp_vector_2(2)%vector(42))
+ ALLOCATE (onlyalloc(1))
+ ALLOCATE (onlyalloc(1)%vector(5))
+ ALLOCATE (comp_static%vector(42))
+ ALLOCATE (nested%comp%vector(42))
+
+ ! Don't allocate comp_vector_1, comp_vector_2(3)%vector and
+ ! onlyalloc(1)%novect.
+
+ ! comp_vector_2 is allocated not-one based, but a possible failure here is
+ ! probably only caught by valgrind.
+ ! XXX: Can I change it somehow so it fails surely if the finalizer indexes
+ ! 1:2?
+
+ ! Check that auto-deallocation happens both for RETURN and END.
+ IF (ret) RETURN
+
+ ! Automatic deallocation should happen and finalize:
+ ! * yes_vect => 1 vector
+ ! * comp_vector_2(1:2)%scalar => 2 scalar
+ ! * comp_vector_2(1)%vector => 1 vector
+ ! * onlyalloc(1)%vector => 1 vector
+ ! * comp_static%scalar => 1 scalar
+ ! * comp_static%vector => 1 vector
+ ! * nested%comp%scalar => 1 scalar
+ ! * nested%comp%vector => 1 vector
+ ! => in sum 4 scalar and 5 vector finalizations per call.
+END SUBROUTINE test
+
+PROGRAM main
+ USE final_mod
+ IMPLICIT NONE
+
+ ! Expected are:
+ ! * 2*4 scalar and 2*5 vector finalizations from the two test calls
+ ! * 1 vector finalization from test_intent_out
+ ! * 1 vector and 1 scalar from the comp_t assignment
+ ! * 1 vector and 1 scalar from the comp_t temporary result finalization
+ ! * 1 vector and 1 scalar from the comp_vect finalization
+ ! => 11 scalar, 14 vector
+ INTEGER, PARAMETER :: expected_scalar = 11
+ INTEGER, PARAMETER :: expected_vector = 14
+
+ ! Check this is auto-deallocated including finalization even in main program
+ TYPE(yes_t), ALLOCATABLE :: main_allocatable(:), main_allocatable2(:)
+
+ ! This will be the LHS of an intrinsic assignment
+ TYPE(comp_t) :: compound
+
+ ! Test auto-deallocation of components when deallocating
+ TYPE(comp_t), ALLOCATABLE :: comp_vect(:)
+
+ ALLOCATE (main_allocatable(5))
+ ALLOCATE (compound%vector(5))
+ ALLOCATE (comp_vect(1))
+ ALLOCATE (comp_vect(1)%vector(5))
+
+ ! Call the function twice
+ CALL test (.TRUE.)
+ CALL test (.FALSE.)
+ CALL test_intent_out (main_allocatable)
+
+ ! Execute intrinsic assignment
+ compound = get_compound ()
+
+ ! Manual deallocation
+ DEALLOCATE (comp_vect)
+
+ ! Check that the counters match the expectations
+ WRITE (*,*) "Vector finalization:", cnt_vector, expected_vector
+ WRITE (*,*) "Scalar finalization:", cnt_scalar, expected_scalar
+ IF (cnt_vector /= expected_vector .OR. cnt_scalar /= expected_scalar) THEN
+ CALL abort ()
+ END IF
+
+ ! The arrays in the main program should be deallocated and in consequence
+ ! finalized at the end of the program. This is checked via scanning the
+ ! tree-dump not the expect-values above.
+END PROGRAM main
+
+! { dg-final { cleanup-modules "final_mod" } }
+! { dg-final { scan-tree-dump "final_yes_vector \\\(&main_allocatable" "original" } }
+! { dg-final { scan-tree-dump "final_yes_vector \\\(&main_allocatable2" "original" } }
Index: gcc/testsuite/gfortran.dg/module_md5_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/module_md5_1.f90 (revision 136895)
+++ gcc/testsuite/gfortran.dg/module_md5_1.f90 (working copy)
@@ -10,5 +10,5 @@ program test
use foo
print *, pi
end program test
-! { dg-final { scan-module "foo" "MD5:2350094d1d87eb25ab22af5f8e96e011" } }
+! { dg-final { scan-module "foo" "MD5:596df8f39d3ddc0b847771cadcb26274" } }
! { dg-final { cleanup-modules "foo" } }
Index: gcc/testsuite/gfortran.dg/finalize_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_4.f03 (revision 136895)
+++ gcc/testsuite/gfortran.dg/finalize_4.f03 (working copy)
@@ -49,7 +49,4 @@ PROGRAM finalizer
END PROGRAM finalizer
-! TODO: Remove this once finalization is implemented.
-! { dg-excess-errors "not yet implemented" }
-
! { dg-final { cleanup-modules "final_type" } }