This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH, Fortran] Parse FINAL procedure declarations
- From: Daniel Kraft <d at domob dot eu>
- To: gcc-patches at gcc dot gnu dot org, Fortran List <fortran at gcc dot gnu dot org>
- Date: Thu, 22 May 2008 21:44:15 +0000
- Subject: [PATCH, Fortran] Parse FINAL procedure declarations
Hi,
this is a first patch including ChangeLog for implementing parsing and
resolution of Fortran 2003 FINAL procedures; when this is completed,
I'll work on actually finalizing expressions.
The patch enables CONTAINS-sections inside derived type definitions,
possibly containing FINAL statements; it also adds the f2k_derived
namespace to gfc_symbols of derived types as Paul Thomas suggested for
F2003 OOP features. Inside this namespace, the FINAL procedures are
stored in a linked list.
Later in the resolution phase, this list is walked and checked that the
procedures there fulfill the requirements of the F2003 standard for
FINAL procedures. So far these statements don't have any further effect.
While there are still some open issues, I believe this patch is already
close to completion, so I post it here for comments (tomorrow I'll
probably have few to no time, this is why I post it now). The patch
succeeds both my new tests included and the existing test-suite for me
on GNU/Linux-x86-32 without any failures.
Things to note:
* I'm not completely sure about what the test-suite should/should
not/must not (because it may be invalid?) check. Comments on my tests
are very welcome ;)
* There are some XXX-marks in the patch, but IIRC only/mostly for the
point below.
* AFAIK, kind and length type parameters (in fact, type parameters at
all) are not yet implemented in gfortran, so the according checks are
missing from the test-suite and code. I hope this is ok like this,
we'll have to add the code later when these features get implemented.
* FX, I got an answer on comp.lang.fortran about the assumed shape /
length type parameter thing (see point above); but I still believe (and
this was also the opinion of the poster there who answered) it makes
sense to define finalizer procedures for assumed shape so they can
finalize arrays of all concrete shapes. Maybe I could replace the
commented out block in the patch (has XXX) to emit a warning rather than
an error if a finalizer has something apart from assumed shape? What do
you think?
* Indentation-style in the patch is surely wrong in some places, need to
replace eight spaces by a tab for the final version.
So far, I welcome your comments. Though this is surely not my final
patch for this, its probably close modulo removing some XXX-comments,
the format-fixing and possibly minor adaptions as result of comments.
Cheers,
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-05-22 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_list): New function to free a linked list of
gfc_finalizer nodes.
2008-05-22 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.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 135753)
+++ gcc/fortran/symbol.c (working copy)
@@ -2094,6 +2094,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;
@@ -2282,6 +2283,8 @@ gfc_free_symbol (gfc_symbol *sym)
gfc_free_formal_arglist (sym->formal);
+ gfc_free_namespace (sym->f2k_derived);
+
gfc_free (sym);
}
@@ -2314,6 +2317,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;
}
@@ -2882,6 +2886,25 @@ gfc_free_equiv_lists (gfc_equiv_list *l)
}
+/* Free a finalizer procedure list. */
+
+static void
+gfc_free_finalizer_list (gfc_finalizer* l)
+{
+ while (l)
+ {
+ gfc_finalizer* current = l;
+ l = l->next;
+
+ --current->procedure->refs;
+ if (!current->procedure->refs)
+ gfc_free_symbol (current->procedure);
+
+ gfc_free (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. */
@@ -2906,6 +2929,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 135753)
+++ gcc/fortran/decl.c (working copy)
@@ -6270,6 +6270,11 @@ 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. */
+ /* XXX: Set NULL as parent namespace? */
+ if (!sym->f2k_derived)
+ sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
gfc_new_block = sym;
return MATCH_YES;
@@ -6480,3 +6485,105 @@ 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 ());
+
+ 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");
+ return MATCH_ERROR;
+ }
+
+ /* 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);
+
+ return MATCH_YES;
+}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 135753)
+++ 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 */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 135753)
+++ gcc/fortran/resolve.c (working copy)
@@ -7437,6 +7437,120 @@ 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 by the standard to procedures used as finalizers. */
+
+static try
+gfc_resolve_finalizers (gfc_symbol* derived)
+{
+ gfc_finalizer* list;
+ try result = SUCCESS;
+
+ if (!derived->f2k_derived)
+ return SUCCESS;
+
+ for (list = derived->f2k_derived->finalizers; list; list = list->next)
+ {
+ gfc_symbol* arg;
+ gfc_finalizer* i;
+ int my_rank;
+
+ /* 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);
+ result = FAILURE;
+ continue;
+ }
+ 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'",
+ &list->where, derived->name);
+ result = FAILURE;
+ continue;
+ }
+
+ /* 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",
+ &list->where);
+ result = FAILURE;
+ continue;
+ }
+ if (arg->attr.allocatable)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " ALLOCATABLE", &list->where);
+ result = FAILURE;
+ continue;
+ }
+ if (arg->attr.optional)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+ &list->where);
+ result = FAILURE;
+ continue;
+ }
+
+ /* 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)", &list->where);
+ result = FAILURE;
+ continue;
+ }
+
+ /* It must be of assumed size. */
+ /* XXX
+ if (arg->as && arg->as->rank > 0 && arg->as->type != AS_ASSUMED_SIZE)
+ {
+ gfc_error ("Array-argument of FINAL procedure at %L must be of"
+ " assumed size %d", &list->where, arg->as->type);
+ result = FAILURE;
+ continue;
+ }
+ */
+
+ /* 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. */
+ /* XXX: 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);
+ result = FAILURE;
+ goto continue_outer;
+ }
+ }
+ }
+
+continue_outer:;
+ }
+
+ return result;
+}
+
+
/* Resolve the components of a derived type. */
static try
@@ -7515,6 +7629,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 135753)
+++ 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 135753)
+++ 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,10 +1714,27 @@ 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;
+ }
+
+ accept_statement (ST_FINAL);
+ seen_contains_comp = 1;
+ break;
+
case ST_END_TYPE:
compiling_type = 0;
@@ -1723,10 +1744,22 @@ parse_derived (void)
== 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 +1788,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 +1817,11 @@ parse_derived (void)
gfc_current_block ()->name, NULL);
break;
+ case ST_CONTAINS:
+ 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,106 @@
+! { 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 :: 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_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 ! { dg-error "must be of type 'mytype'" }
+ FINAL :: bad_pointer ! { dg-error "must not be a POINTER" }
+ FINAL :: bad_alloc ! { dg-error "must not be ALLOCATABLE" }
+ FINAL :: bad_optional ! { dg-error "must not be OPTIONAL" }
+ FINAL :: bad_intent_out ! { dg-error "must not be INTENT\\(OUT\\)" }
+
+ ! Not defined procedures are treated like empty arguments
+ FINAL :: iamnot ! { dg-error "must have exactly one argument" }
+
+ ! XXX: Polymorphism (?) and kind type parameters not yet implemented
+ ! XXX: The assumed thing
+ 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
+
+ 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)
+ IMPLICIT NONE
+ REAL :: el
+ END SUBROUTINE bad_arg_type
+
+ SUBROUTINE bad_pointer (el)
+ IMPLICIT NONE
+ TYPE(mytype), POINTER :: el
+ END SUBROUTINE bad_pointer
+
+ SUBROUTINE bad_alloc (el)
+ IMPLICIT NONE
+ TYPE(mytype), ALLOCATABLE :: el(:)
+ END SUBROUTINE bad_alloc
+
+ SUBROUTINE bad_optional (el)
+ IMPLICIT NONE
+ TYPE(mytype), OPTIONAL :: el
+ END SUBROUTINE bad_optional
+
+ SUBROUTINE bad_intent_out (el)
+ 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_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_1.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/finalize_1.f08 (revision 0)
@@ -0,0 +1,22 @@
+! { 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
+
+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,23 @@
+! { dg-do compile }
+
+! Parsing of finalizer procedure definitions.
+! Check that CONTAINS disallows further components
+
+MODULE final_type
+ IMPLICIT NONE
+
+ TYPE :: mytype
+ INTEGER, ALLOCATABLE :: fooarr(:)
+ REAL :: foobar
+ CONTAINS
+ 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,57 @@
+! { 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
+ ! XXX: Different kind type parameters not yet 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
+
+ LOGICAL FUNCTION finalize_vector (el)
+ IMPLICIT NONE
+ TYPE(mytype), INTENT(INOUT) :: el(:)
+
+ ! Do nothing in this test
+ finalize_vector = .FALSE.
+ END FUNCTION finalize_vector
+
+ FUNCTION finalize_matrix (el)
+ IMPLICIT NONE
+ TYPE(mytype) :: el(:, :)
+ REAL :: finalize_matrix
+
+ ! Do nothing in this test
+ finalize_matrix = 1.5
+ END FUNCTION 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" } }