This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [PATCH, Fortran] Parse FINAL procedure declarations
- 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: Sat, 31 May 2008 14:22:01 +0200
- Subject: Re: [PATCH, Fortran] Parse FINAL procedure declarations
- References: <483BBD6D.5000706@domob.eu> <483C131B.6060006@net-b.de>
Hi,
attached is the updated patch addressing these comments and ChangeLog.
As usual tested on GNU/Linux-x86-32.
Still todo/open are two more points:
* Add the not-implemented-error when everything else is finished and
ready for check-in, up to then marked XXX.
* I'm still waiting for the answer to whether I should make f2k_derived
a union with formal in gfc_symbol. My opinion is that this probably
does not save that much space and makes things a bit "uglier", but there
are already some unions like that in gfortran and it should work
perfectly fine. So I'm waiting for your comments, also for now marked XXX.
Other than this, I believe all of Tobias' comments below are done and
integrated into the test-suite where applicable.
For now, I'm waiting on final input to get this finished and will start
working on part 2 (with the test-cases) based on Paul's initial patch;
hopefully there will not be many changes to part 1 so not much to merge
later ;)
Cheers,
Daniel
Tobias Burnus wrote:
Hi Daniel,
Daniel Kraft wrote:
I'm not sure about how reviewing is going on
Slowly - as real life interferes.
Regarding the patch: I think it is mostly OK, but I still have some
remarks.
a) You should add towards the end of "gfc_match_final_decl" a
gfc_error with a not-imlemented-in-gfortran error message.
b) You should check whether the module procedure exists. Currently one
gets for:
final :: final2
1
Error: FINAL procedure at (1) must have exactly one argument
Which is misleading if the procedure does not exist. How about using
simply at the very top of gfc_resolve_finalizers:
if (!list->procedure->attr.subroutine)
gfc_error ("FINAL procedure '%s' at %L is not a subroutine",
list->procedure->name, &list->where);
(This is how it is in the spririt of "[module] procedure" in generic
interfaces. The function check at the very bottom can then be removed.)
For the argument checking such as OPTIONAL, INTENT etc. one should use
&arg->declared_at rather than &list->where --- this gives a better error
location.
c)
+ /* Construct the f2k_derived namespace if it is not yet there. */
+ /* XXX: Set NULL as parent namespace? */
+ if (!sym->f2k_derived)
+ sym->f2k_derived = gfc_get_namespace (NULL, 0);
I think that is OK
d)
+ module_ns = gfc_current_ns;
+ for (; module_ns; module_ns = module_ns->parent)
+ if (module_ns->proc_name->attr.flavor == FL_MODULE)
+ break;
+
+ if (module_ns == NULL)
+ {
+ /* XXX: What's about this? */
+ gfc_error ("Derived type declaration with FINAL must be inside a
MODULE");
That looks wrong. I think the derived type-declaration with FINAL
attribute need to be in the *specification part* of a module. For
instance the following example is wrong. (It is rejected, but much later
with a suboptimal error message.)
[Reasoning from the standard: finalization subroutine needs to be a
module procedure (and thus not an internal procedure) and as the derived
type needs to be passed, it has to be declared before.]
Invalid test case:
module m
contains
subroutine bar
type t
contains ! << OK
final :: final2 ! << FINAL is INVALID in this context
end type t
contains
subroutine final2(x)
type(t) :: x
end subroutine final2
end subroutine bar
end module m
How about something similar to:
if (!gfc_state_stack->previous | | gfc_state_stack->previous->state !=
COMP_MODULE)
gfc_error ("Derived type declaration with FINAL must be in the
specification part of a module");
(Completely untested, I might miss another layer because of contains.)
e)
+ /* The namespace containing type-associated procedure symbols. */
+ /* XXX: Make this union with formal. */
+ struct gfc_namespace *f2k_derived;
Will you do this for the follow up patch? In any case if you intent to
commit the patch before you fixed it, please change XXX to TODO.
f)
+ been defined and we now know their defined arguments, check that
they fulfill
+ the requirements by the standard to procedures used as finalizers. */
"requirements of the standard", "for procedures"
g)
+ /* XXX: Kind parameters once they are implemented. */
Better use either TODO (or FIXME); we currently have 14 FIXMEs and 107
TODOs. One can easily grep for those, but if one adds other items such
as XXX it gets more and more difficult. And please add a verb at the
beginning of the sentence.
h) The following is invalid but not detected:
type t
contains
contains ! << INVALID
end type t
Tobias
--
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-05-31 Daniel Kraft <d@domob.eu>
* gfortran.h: New statement-type ST_FINAL for FINAL declarations.
(struct gfc_symbol): New member f2k_derived.
(struct gfc_namespace): New member finalizers, for use in the above
mentioned f2k_derived namespace.
(struct gfc_finalizer): New type defined for finalizers linked list.
* match.h (gfc_match_final_decl): New function header.
* decl.c (gfc_match_derived_decl): Create f2k_derived namespace on
constructed symbol node.
(gfc_match_final_decl): New function to match a FINAL declaration line.
* parse.c (decode_statement): match-call for keyword FINAL.
(parse_derived): Parse CONTAINS section and accept FINAL statements.
* resolve.c (gfc_resolve_finalizers): New function to resolve (that is
in this case, check) a list of finalizer procedures.
(resolve_fl_derived): Call gfc_resolve_finalizers here.
* symbol.c (gfc_get_namespace): Initialize new finalizers to NULL.
(gfc_free_namespace): Free finalizers list.
(gfc_new_symbol): Initialize new f2k_derived to NULL.
(gfc_free_symbol): Free f2k_derived namespace.
(gfc_free_finalizer): New function to free a single gfc_finalizer node.
(gfc_free_finalizer_list): New function to free a linked list of
gfc_finalizer nodes.
2008-05-31 Daniel Kraft <d@domob.eu>
* finalize_1.f08: New test.
* finalize_2.f03: New test.
* finalize_3.f03: New test.
* finalize_4.f03: New test.
* finalize_5.f03: New test.
* finalize_6.f90: New test.
* finalize_7.f03: New test.
* finalize_8.f03: New test.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 136234)
+++ gcc/fortran/symbol.c (working copy)
@@ -2096,6 +2096,7 @@ gfc_get_namespace (gfc_namespace *parent
ns = gfc_getmem (sizeof (gfc_namespace));
ns->sym_root = NULL;
ns->uop_root = NULL;
+ ns->finalizers = NULL;
ns->default_access = ACCESS_UNKNOWN;
ns->parent = parent;
@@ -2284,6 +2285,8 @@ gfc_free_symbol (gfc_symbol *sym)
gfc_free_formal_arglist (sym->formal);
+ gfc_free_namespace (sym->f2k_derived);
+
gfc_free (sym);
}
@@ -2316,6 +2319,7 @@ gfc_new_symbol (const char *name, gfc_na
/* Clear the ptrs we may need. */
p->common_block = NULL;
+ p->f2k_derived = NULL;
return p;
}
@@ -2884,6 +2888,33 @@ gfc_free_equiv_lists (gfc_equiv_list *l)
}
+/* Free a finalizer procedure list. */
+
+void
+gfc_free_finalizer (gfc_finalizer* el)
+{
+ if (el)
+ {
+ --el->procedure->refs;
+ if (!el->procedure->refs)
+ gfc_free_symbol (el->procedure);
+
+ gfc_free (el);
+ }
+}
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* list)
+{
+ while (list)
+ {
+ gfc_finalizer* current = list;
+ list = list->next;
+ gfc_free_finalizer (current);
+ }
+}
+
+
/* Free a namespace structure and everything below it. Interface
lists associated with intrinsic operators are not freed. These are
taken care of when a specific name is freed. */
@@ -2908,6 +2939,7 @@ gfc_free_namespace (gfc_namespace *ns)
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ gfc_free_finalizer_list (ns->finalizers);
for (cl = ns->cl_list; cl; cl = cl2)
{
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 136234)
+++ gcc/fortran/decl.c (working copy)
@@ -6270,6 +6270,10 @@ gfc_match_derived_decl (void)
if (attr.is_bind_c != 0)
sym->attr.is_bind_c = attr.is_bind_c;
+ /* Construct the f2k_derived namespace if it is not yet there. */
+ if (!sym->f2k_derived)
+ sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
gfc_new_block = sym;
return MATCH_YES;
@@ -6480,3 +6484,107 @@ cleanup:
}
+/* Match a FINAL declaration inside a derived type. */
+
+match
+gfc_match_final_decl (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol* sym;
+ match m;
+ gfc_namespace* module_ns;
+ bool first, last;
+
+ if (gfc_state_stack->state != COMP_DERIVED)
+ {
+ gfc_error ("FINAL declaration at %C must be inside a derived type "
+ "definition!");
+ return MATCH_ERROR;
+ }
+
+ gcc_assert (gfc_current_block ());
+
+ if (!gfc_state_stack->previous
+ || gfc_state_stack->previous->state != COMP_MODULE)
+ {
+ gfc_error ("Derived type declaration with FINAL at %C must be in the"
+ " specification part of a MODULE");
+ return MATCH_ERROR;
+ }
+
+ module_ns = gfc_current_ns;
+ gcc_assert (module_ns);
+ gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
+
+ /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
+ if (gfc_match (" ::") == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ /* Match the sequence of procedure names. */
+ first = true;
+ last = false;
+ do
+ {
+ gfc_finalizer* f;
+
+ if (first && gfc_match_eos () == MATCH_YES)
+ {
+ gfc_error ("Empty FINAL at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (name);
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected module procedure name at %C");
+ return MATCH_ERROR;
+ }
+ else if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () == MATCH_YES)
+ last = true;
+ if (!last && gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Expected ',' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_symbol (name, module_ns, &sym))
+ {
+ gfc_error ("Unknown procedure name \"%s\" at %C", name);
+ return MATCH_ERROR;
+ }
+
+ /* Mark the symbol as module procedure. */
+ if (sym->attr.proc != PROC_MODULE
+ && gfc_add_procedure (&sym->attr, PROC_MODULE,
+ sym->name, NULL) == FAILURE)
+ return MATCH_ERROR;
+
+ /* 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)
+ {
+ gfc_error ("'%s' at %C is already defined as FINAL procedure!",
+ name);
+ return MATCH_ERROR;
+ }
+
+ /* Add this symbol to the list of finalizers. */
+ gcc_assert (gfc_current_block ()->f2k_derived);
+ ++sym->refs;
+ f = gfc_getmem (sizeof (gfc_finalizer));
+ f->procedure = sym;
+ f->where = gfc_current_locus;
+ f->next = gfc_current_block ()->f2k_derived->finalizers;
+ gfc_current_block ()->f2k_derived->finalizers = f;
+
+ first = false;
+ }
+ while (!last);
+
+ /* XXX: Add not-implemented error here. */
+
+ return MATCH_YES;
+}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 136234)
+++ gcc/fortran/gfortran.h (working copy)
@@ -210,7 +210,7 @@ typedef enum
ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO,
- ST_END_FILE, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
+ ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO,
@@ -1014,6 +1014,10 @@ typedef struct gfc_symbol
gfc_formal_arglist *formal;
struct gfc_namespace *formal_ns;
+ /* The namespace containing type-associated procedure symbols. */
+ /* XXX: Make this union with formal? */
+ struct gfc_namespace *f2k_derived;
+
struct gfc_expr *value; /* Parameter/Initializer value */
gfc_array_spec *as;
struct gfc_symbol *result; /* function result symbol */
@@ -1151,6 +1155,8 @@ typedef struct gfc_namespace
gfc_symtree *uop_root;
/* Tree containing all the common blocks. */
gfc_symtree *common_root;
+ /* Linked list of finalizer procedures. */
+ struct gfc_finalizer *finalizers;
/* If set_flag[letter] is set, an implicit type has been set for letter. */
int set_flag[GFC_LETTERS];
@@ -1942,6 +1948,17 @@ 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. */
+}
+gfc_finalizer;
+
/************************ Function prototypes *************************/
/* decl.c */
@@ -2210,6 +2227,8 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymb
void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
+void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
+
/* intrinsic.c */
extern int gfc_init_expr;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 136234)
+++ gcc/fortran/resolve.c (working copy)
@@ -7439,6 +7439,143 @@ resolve_fl_procedure (gfc_symbol *sym, i
}
+/* Resolve a list of finalizer procedures. That is, after they have hopefully
+ been defined and we now know their defined arguments, check that they fulfill
+ the requirements of the standard for procedures used as finalizers. */
+
+static try
+gfc_resolve_finalizers (gfc_symbol* derived)
+{
+ gfc_finalizer* list;
+ gfc_finalizer** prev_link; /* For removing wrong entries from the list. */
+ try result = SUCCESS;
+ bool seen_scalar = false;
+
+ if (!derived->f2k_derived || !derived->f2k_derived->finalizers)
+ return SUCCESS;
+
+ /* Walk over the list of finalizer-procedures, check them, and if any one
+ does not fit in with the standard's definition, print an error and remove
+ it from the list. */
+ prev_link = &derived->f2k_derived->finalizers;
+ for (list = derived->f2k_derived->finalizers; list; list = *prev_link)
+ {
+ gfc_symbol* arg;
+ gfc_finalizer* i;
+ int my_rank;
+
+ /* Check this exists and is a SUBROUTINE. */
+ if (!list->procedure->attr.subroutine)
+ {
+ gfc_error ("FINAL procedure '%s' at %L is not a SUBROUTINE",
+ list->procedure->name, &list->where);
+ goto error;
+ }
+
+ /* We should have exactly one argument. */
+ if (!list->procedure->formal || list->procedure->formal->next)
+ {
+ gfc_error ("FINAL procedure at %L must have exactly one argument",
+ &list->where);
+ goto error;
+ }
+ arg = list->procedure->formal->sym;
+
+ /* This argument must be of our type. */
+ if (arg->ts.type != BT_DERIVED || arg->ts.derived != derived)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must be of type '%s'",
+ &arg->declared_at, derived->name);
+ goto error;
+ }
+
+ /* It must neither be a pointer nor allocatable nor optional. */
+ if (arg->attr.pointer)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be a POINTER",
+ &arg->declared_at);
+ goto error;
+ }
+ if (arg->attr.allocatable)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " ALLOCATABLE", &arg->declared_at);
+ goto error;
+ }
+ if (arg->attr.optional)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+ &arg->declared_at);
+ goto error;
+ }
+
+ /* It must not be INTENT(OUT). */
+ if (arg->attr.intent == INTENT_OUT)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " INTENT(OUT)", &arg->declared_at);
+ goto error;
+ }
+
+ /* Warn if the procedure is non-scalar and not assumed shape. */
+ if (gfc_option.warn_surprising && arg->as && arg->as->rank > 0
+ && arg->as->type != AS_ASSUMED_SHAPE)
+ gfc_warning ("Non-scalar FINAL procedure at %L should have assumed"
+ " shape argument", &arg->declared_at);
+
+ /* Check that it does not match in kind and rank with a FINAL procedure
+ defined earlier. To really loop over the *earlier* declarations,
+ we need to walk the tail of the list as new ones were pushed at the
+ front. */
+ /* TODO: Handle kind parameters once they are implemented. */
+ my_rank = (arg->as ? arg->as->rank : 0);
+ for (i = list->next; i; i = i->next)
+ {
+ /* Argument list might be empty; that is an error signalled earlier,
+ but we nevertheless continued resolving. */
+ if (i->procedure->formal)
+ {
+ gfc_symbol* i_arg = i->procedure->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);
+ goto error;
+ }
+ }
+ }
+
+ /* Is this the/a scalar finalizer procedure? */
+ if (!arg->as || arg->as->rank == 0)
+ seen_scalar = true;
+
+ prev_link = &list->next;
+ continue;
+
+ /* Remove wrong nodes immediatelly from the list so we don't risk any
+ troubles in the future when they might fail later expectations. */
+error:
+ result = FAILURE;
+ i = list;
+ *prev_link = list->next;
+ gfc_free_finalizer (i);
+ }
+
+ /* Warn if we haven't seen a scalar finalizer procedure (but we know there
+ were nodes in the list, must have been for arrays. It is surely a good
+ idea to have a scalar version there if there's something to finalize. */
+ if (gfc_option.warn_surprising && result == SUCCESS && !seen_scalar)
+ gfc_warning ("Only array FINAL procedures declared for derived type '%s'"
+ " defined at %L, suggest also scalar one",
+ derived->name, &derived->declared_at);
+
+ return result;
+}
+
+
/* Resolve the components of a derived type. */
static try
@@ -7517,6 +7654,10 @@ resolve_fl_derived (gfc_symbol *sym)
}
}
+ /* Resolve the finalizer procedures. */
+ if (gfc_resolve_finalizers (sym) == FAILURE)
+ return FAILURE;
+
/* Add derived type to the derived type list. */
for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
if (sym == dt_list->derived)
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 136234)
+++ gcc/fortran/match.h (working copy)
@@ -140,6 +140,7 @@ match gfc_match_function_decl (void);
match gfc_match_entry (void);
match gfc_match_subroutine (void);
match gfc_match_derived_decl (void);
+match gfc_match_final_decl (void);
match gfc_match_implicit_none (void);
match gfc_match_implicit (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 136234)
+++ gcc/fortran/parse.c (working copy)
@@ -366,6 +366,7 @@ decode_statement (void)
break;
case 'f':
+ match ("final", gfc_match_final_decl, ST_FINAL);
match ("flush", gfc_match_flush, ST_FLUSH);
match ("format", gfc_match_format, ST_FORMAT);
break;
@@ -1682,6 +1683,7 @@ static void
parse_derived (void)
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
+ int seen_contains, seen_contains_comp;
gfc_statement st;
gfc_state_data s;
gfc_symbol *derived_sym = NULL;
@@ -1697,6 +1699,8 @@ parse_derived (void)
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
+ seen_contains = 0;
+ seen_contains_comp = 0;
compiling_type = 1;
@@ -1710,23 +1714,57 @@ parse_derived (void)
case ST_DATA_DECL:
case ST_PROCEDURE:
+ if (seen_contains)
+ {
+ gfc_error ("Components in TYPE at %C must precede CONTAINS");
+ error_flag = 1;
+ }
+
accept_statement (st);
seen_component = 1;
break;
+ case ST_FINAL:
+ if (!seen_contains)
+ {
+ gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+ error_flag = 1;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: FINAL procedure declaration"
+ " at %C") == FAILURE)
+ error_flag = 1;
+
+ accept_statement (ST_FINAL);
+ seen_contains_comp = 1;
+ break;
+
case ST_END_TYPE:
compiling_type = 0;
if (!seen_component
&& (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
- "definition at %C without components")
+ "definition at %C without components")
== FAILURE))
error_flag = 1;
+ if (seen_contains && !seen_contains_comp
+ && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+ "definition at %C with empty CONTAINS "
+ "section") == FAILURE))
+ error_flag = 1;
+
accept_statement (ST_END_TYPE);
break;
case ST_PRIVATE:
+ if (seen_contains)
+ {
+ gfc_error ("PRIVATE statement at %C must precede CONTAINS");
+ error_flag = 1;
+ }
+
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
@@ -1755,6 +1793,12 @@ parse_derived (void)
break;
case ST_SEQUENCE:
+ if (seen_contains)
+ {
+ gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+ error_flag = 1;
+ }
+
if (seen_component)
{
gfc_error ("SEQUENCE statement at %C must precede "
@@ -1778,6 +1822,22 @@ parse_derived (void)
gfc_current_block ()->name, NULL);
break;
+ case ST_CONTAINS:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: CONTAINS block in derived type"
+ " definition at %C") == FAILURE)
+ error_flag = 1;
+
+ if (seen_contains)
+ {
+ gfc_error ("Already inside a CONTAINS block at %C");
+ error_flag = 1;
+ }
+
+ seen_contains = 1;
+ accept_statement (ST_CONTAINS);
+ break;
+
default:
unexpected_statement (st);
break;
Index: gcc/testsuite/gfortran.dg/finalize_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_5.f03 (revision 0)
@@ -0,0 +1,111 @@
+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check for appropriate errors on invalid final procedures.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ FINAL :: finalize_matrix ! { dg-error "must be inside CONTAINS" }
+ CONTAINS
+ FINAL :: ! { dg-error "Empty FINAL" }
+ FINAL ! { dg-error "Empty FINAL" }
+ FINAL :: + ! { dg-error "Expected module procedure name" }
+ FINAL :: iamnot ! { dg-error "is not a SUBROUTINE" }
+ FINAL :: finalize_single finalize_vector ! { dg-error "Expected ','" }
+ FINAL :: finalize_single, finalize_vector
+ FINAL :: finalize_single ! { dg-error "is already defined" }
+ FINAL :: finalize_vector_2 ! { dg-error "has the same rank" }
+ FINAL :: finalize_single_2 ! { dg-error "has the same rank" }
+ FINAL :: bad_function ! { dg-error "is not a SUBROUTINE" }
+ FINAL bad_num_args_1 ! { dg-error "must have exactly one argument" }
+ FINAL bad_num_args_2 ! { dg-error "must have exactly one argument" }
+ FINAL bad_arg_type
+ FINAL :: bad_pointer
+ FINAL :: bad_alloc
+ FINAL :: bad_optional
+ FINAL :: bad_intent_out
+
+ ! TODO: Test for polymorphism, kind parameters once those are implemented.
+ END TYPE mytype
+
+CONTAINS
+
+ SUBROUTINE finalize_single (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el
+ END SUBROUTINE finalize_single
+
+ ELEMENTAL SUBROUTINE finalize_single_2 (el)
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(IN) :: el
+ END SUBROUTINE finalize_single_2
+
+ SUBROUTINE finalize_vector (el)
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(INOUT) :: el(:)
+ END SUBROUTINE finalize_vector
+
+ SUBROUTINE finalize_vector_2 (el)
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(IN) :: el(:)
+ END SUBROUTINE finalize_vector_2
+
+ SUBROUTINE finalize_matrix (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el(:, :)
+ END SUBROUTINE finalize_matrix
+
+ INTEGER FUNCTION bad_function (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el
+
+ bad_function = 42
+ END FUNCTION bad_function
+
+ SUBROUTINE bad_num_args_1 ()
+ IMPLICIT NONE
+ END SUBROUTINE bad_num_args_1
+
+ SUBROUTINE bad_num_args_2 (el, x)
+ IMPLICIT NONE
+ TYPE(mytype) :: el
+ COMPLEX :: x
+ END SUBROUTINE bad_num_args_2
+
+ SUBROUTINE bad_arg_type (el) ! { dg-error "must be of type 'mytype'" }
+ IMPLICIT NONE
+ REAL :: el
+ END SUBROUTINE bad_arg_type
+
+ SUBROUTINE bad_pointer (el) ! { dg-error "must not be a POINTER" }
+ IMPLICIT NONE
+ TYPE(mytype), POINTER :: el
+ END SUBROUTINE bad_pointer
+
+ SUBROUTINE bad_alloc (el) ! { dg-error "must not be ALLOCATABLE" }
+ IMPLICIT NONE
+ TYPE(mytype), ALLOCATABLE :: el(:)
+ END SUBROUTINE bad_alloc
+
+ SUBROUTINE bad_optional (el) ! { dg-error "must not be OPTIONAL" }
+ IMPLICIT NONE
+ TYPE(mytype), OPTIONAL :: el
+ END SUBROUTINE bad_optional
+
+ SUBROUTINE bad_intent_out (el) ! { dg-error "must not be INTENT\\(OUT\\)" }
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(OUT) :: el
+ END SUBROUTINE bad_intent_out
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Nothing here, errors above
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_7.f03 (revision 0)
@@ -0,0 +1,56 @@
+! { dg-do compile }
+! { dg-options "-Wsurprising" }
+
+! Implementation of finalizer procedures.
+! Check for expected warnings on dubious FINAL constructs.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: type_1
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ ! Non-scalar procedures should be assumed shape
+ FINAL :: fin1_scalar
+ FINAL :: fin1_shape_1
+ FINAL :: fin1_shape_2
+ END TYPE type_1
+
+ TYPE :: type_2 ! { dg-warning "Only array FINAL procedures" }
+ REAL :: x
+ CONTAINS
+ ! No scalar finalizer, only array ones
+ FINAL :: fin2_vector
+ END TYPE type_2
+
+CONTAINS
+
+ SUBROUTINE fin1_scalar (el)
+ IMPLICIT NONE
+ TYPE(type_1) :: el
+ END SUBROUTINE fin1_scalar
+
+ SUBROUTINE fin1_shape_1 (v) ! { dg-warning "assumed shape" }
+ IMPLICIT NONE
+ TYPE(type_1) :: v(*)
+ END SUBROUTINE fin1_shape_1
+
+ SUBROUTINE fin1_shape_2 (v) ! { dg-warning "assumed shape" }
+ IMPLICIT NONE
+ TYPE(type_1) :: v(42, 5)
+ END SUBROUTINE fin1_shape_2
+
+ SUBROUTINE fin2_vector (v)
+ IMPLICIT NONE
+ TYPE(type_2) :: v(:)
+ END SUBROUTINE fin2_vector
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_8.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_8.f03 (revision 0)
@@ -0,0 +1,37 @@
+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that FINAL-declarations are only allowed on types defined in the
+! specification part of a module.
+
+MODULE final_type
+ IMPLICIT NONE
+
+CONTAINS
+
+ SUBROUTINE bar
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ FINAL :: myfinal ! { dg-error "in the specification part of a MODULE" }
+ END TYPE mytype
+
+ CONTAINS
+
+ SUBROUTINE myfinal (el)
+ TYPE(mytype) :: el
+ END SUBROUTINE myfinal
+
+ END SUBROUTINE bar
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_6.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_6.f90 (revision 0)
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS/FINAL in derived types is rejected for F95.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER :: fooarr(42)
+ REAL :: foobar
+ CONTAINS ! { dg-error "Fortran 2003" }
+ FINAL :: finalize_single ! { dg-error "Fortran 2003" }
+ END TYPE mytype
+
+CONTAINS
+
+ SUBROUTINE finalize_single (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el
+ ! Do nothing in this test
+ END SUBROUTINE finalize_single
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Do nothing
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_1.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_1.f08 (revision 0)
@@ -0,0 +1,31 @@
+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS is allowed in TYPE definition; but empty only for F2008
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ END TYPE mytype
+
+CONTAINS
+
+ SUBROUTINE bar
+ TYPE :: t
+ CONTAINS ! This is ok
+ END TYPE t
+ ! Nothing
+ END SUBROUTINE bar
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_2.f03 (revision 0)
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! Parsing of finalizer procedure definitions.
+! Check empty CONTAINS errors out for F2003.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ END TYPE mytype ! { dg-error "Fortran 2008" }
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_3.f03 (revision 0)
@@ -0,0 +1,25 @@
+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS disallows further components and no double CONTAINS
+! is allowed.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ CONTAINS ! { dg-error "Already inside a CONTAINS block" }
+ INTEGER :: x ! { dg-error "must precede CONTAINS" }
+ END TYPE mytype
+
+END MODULE final_type
+
+PROGRAM finalizer
+ IMPLICIT NONE
+ ! Do nothing here
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }
Index: gcc/testsuite/gfortran.dg/finalize_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_4.f03 (revision 0)
@@ -0,0 +1,52 @@
+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check parsing of valid finalizer definitions.
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ FINAL :: finalize_single
+ FINAL finalize_vector, finalize_matrix
+ ! TODO: Test with different kind type parameters once they are implemented.
+ END TYPE mytype
+
+CONTAINS
+
+ ELEMENTAL SUBROUTINE finalize_single (el)
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(IN) :: el
+ ! Do nothing in this test
+ END SUBROUTINE finalize_single
+
+ SUBROUTINE finalize_vector (el)
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(INOUT) :: el(:)
+ ! Do nothing in this test
+ END SUBROUTINE finalize_vector
+
+ SUBROUTINE finalize_matrix (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el(:, :)
+ ! Do nothing in this test
+ END SUBROUTINE finalize_matrix
+
+END MODULE final_type
+
+PROGRAM finalizer
+ USE final_type, ONLY: mytype
+ IMPLICIT NONE
+
+ TYPE(mytype) :: el, vec(42)
+ TYPE(mytype), ALLOCATABLE :: mat(:, :)
+
+ ALLOCATE(mat(2, 3))
+ DEALLOCATE(mat)
+
+END PROGRAM finalizer
+
+! { dg-final { cleanup-modules "final_type" } }