This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [PATCH, Fortran] Derived type finalization: Already somewhat useable...
- From: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>
- To: "Daniel Kraft" <d at domob dot eu>
- Cc: "Fortran List" <fortran at gcc dot gnu dot org>, gcc-patches at gcc dot gnu dot org
- Date: Tue, 24 Jun 2008 23:52:49 +0200
- Subject: Re: [PATCH, Fortran] Derived type finalization: Already somewhat useable...
- Dkim-signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=domainkey-signature:received:received:message-id:date:from:to :subject:cc:in-reply-to:mime-version:content-type :content-transfer-encoding:content-disposition:references; bh=S7HEof/MM4E7KksZMra9Rj50ulU9ioNEPn0k2ooGY3s=; b=whvu06i8MusUFRgyJCJlG35562CAHzAfKlo2KaftK3vnBJsn+LeEfMO59EPmZwo5rt lyG8wUFSE/fx8mlhZPtWW3CvnADciYBkeA7vRljQzQ5W6wn1UJfySICkqvpgmgEfXS+P AJAOFE/V/cTo6HL+F0yxu/9Nf1S72a6fa+5m8=
- Domainkey-signature: a=rsa-sha1; c=nofws; d=gmail.com; s=gamma; h=message-id:date:from:to:subject:cc:in-reply-to:mime-version :content-type:content-transfer-encoding:content-disposition :references; b=Tmr/5K7fttj0MXV44nDKQ6QnDrTyNDDUB5NqTQhGrZKl5mQBrisCHrA7A6FM56zkUX xvqE4sDbJ+ZZMClQl7/kSgQnvmQnm1EVYYLcVJessoPdgnzm328Xd/SrvzvCQA6YR7mH xW7zACKlxHSsgKPz5D/pC/VyQrlYZuUbCYo6w=
- References: <485E2BA8.4020003@domob.eu> <485F5F13.5040209@domob.eu>
Daniel,
I am once more on the road. To give your patch the time that it
deserves, I will have to wait until Thursday. If anybody else can
give it a good look over before then, great! Otherwise, watch this
space.
Cheers
Paul
On Mon, Jun 23, 2008 at 10:30 AM, Daniel Kraft <d@domob.eu> wrote:
> 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" } }
>
>
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy