This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC 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: Tue, 27 May 2008 09:51:09 +0200
- Subject: Re: [PATCH, Fortran] Parse FINAL procedure declarations
Daniel Kraft wrote:
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.
I'm not sure about how reviewing is going on, but here's a revised
version of the patch/changelog.
What I did change:
* now only SUBROUTINEs can be declared FINAL, corrected tests and code
* -std=f95 now gives notify-std-errors for CONTAINS/FINAL in a derived
type declaration
* I rewrote gfc_resolve_finalizers so that erraneous finalizers are
removed from the list on the spot; I did this because it was not much
effort and I believe it is a cleaner approach, as this removes any risk
of having wrong nodes in the list later where it is already expected
that all are valid; even though an error is output anyway ;)
* -Wsurprising now warns about:
* non-scalar FINALizer other than assumed-shape
* FINAL procedures declared, but no scalar version
Other than this, nothing has been changed (including, what I believe,
the main critical parts like parser/integration of the new things into
existing code).
There was a suggestion to warn also about (non-ELEMENTAL) scalar
FINALizers where no array version is declared, but I believe this can
not be done satisfiably at this point; I believe so because we don't
know for which shapes array versions are needed (and hardcoding
something like "warn if no rank-1 FINALizer is there" is ugly), so what
I plan to do is warning when an actual array is to be finalized for
whose type finalizers exist but not for its rank. This will be done in
the second part of this patch, implementing the actual finalization process.
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
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,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. */
@@ -2906,6 +2937,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 */
@@ -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 135753)
+++ gcc/fortran/resolve.c (working copy)
@@ -7437,6 +7437,142 @@ 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;
+ 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;
+
+ /* 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'",
+ &list->where, 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",
+ &list->where);
+ goto error;
+ }
+ if (arg->attr.allocatable)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be"
+ " ALLOCATABLE", &list->where);
+ goto error;
+ }
+ if (arg->attr.optional)
+ {
+ gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL",
+ &list->where);
+ 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)", &list->where);
+ goto error;
+ }
+
+ /* It must not be a FUNCTION. */
+ if (list->procedure->result)
+ {
+ gfc_error ("Only SUBROUTINES can be FINAL at %L", &list->where);
+ 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", &list->where);
+
+ /* 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);
+ 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
@@ -7515,6 +7651,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,32 @@ 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;
@@ -1723,10 +1749,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 +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,16 @@ 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;
+
+ 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,114 @@
+! { 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_function ! { dg-error "Only SUBROUTINES can be FINAL" }
+ 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
+
+ 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)
+ 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_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 ! { dg-warning "assumed shape" }
+ FINAL :: fin1_shape_2 ! { dg-warning "assumed shape" }
+ 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)
+ IMPLICIT NONE
+ TYPE(type_1) :: v(*)
+ END SUBROUTINE fin1_shape_1
+
+ SUBROUTINE fin1_shape_2 (v)
+ 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_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,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,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
+ ! 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
+
+ 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" } }
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): 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-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.
* finalize_6.f90: New test.
* finalize_7.f03: New test.