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: Mon, 02 Jun 2008 20:29:34 +0200
- Subject: Re: [PATCH, Fortran] Parse FINAL procedure declarations
- References: <483BBD6D.5000706@domob.eu> <483C131B.6060006@net-b.de> <484142E9.20708@domob.eu> <48442B9C.2050603@net-b.de>
Tobias Burnus wrote:
Daniel Kraft wrote:
attached is the updated patch addressing these comments and ChangeLog.
As usual tested on GNU/Linux-x86-32.
* Add the not-implemented-error when everything else is finished and
ready for check-in, up to then marked XXX.
This is crucial if you want to have this checked in.
Hi Tobias,
of course, I was just waiting for everything else to be finished ;)
* 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.
I believe the patch is OK - except for the missing not-implemented
error. Regarding the point above, I don't have strong feelings about it.
For me it is fine to delete the comment or leave it as it (including the
question mark) with s/XXX/TODO/.
I will check in your patch, when you provide an patch which gives a
not-implemented error. One could think of deferring some of the test
cases until the actual implementation is there, if it gets too
cumbersome to accommodate them for the not-implemented error.
Thanks, that would be great! Find attached the new patch, with the two
small corrections as above:
* Added the not-implemented error and adapted test-cases for now (I hope
I managed to get them right).
* Left the comment about making union in, changed to TODO. If you come
to a decision, I will change the code accordingly, maybe for part 2 of
the patch.
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-06-02 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-06-02 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,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 ());
+
+ 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);
+
+ 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. */
+ /* TODO: 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,146 @@ 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);
+
+ /* TODO: Remove this error when finalization is finished. */
+ gfc_error ("Finalization is not yet implemented.");
+
+ return result;
+}
+
+
/* Resolve the components of a derived type. */
static try
@@ -7517,6 +7657,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,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 :: 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
+
+! 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 0)
+++ gcc/testsuite/gfortran.dg/finalize_7.f03 (revision 0)
@@ -0,0 +1,59 @@
+! { 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
+
+! 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_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,35 @@
+! { 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
+
+! 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_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,55 @@
+! { 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
+
+! TODO: Remove this once finalization is implemented.
+! { dg-excess-errors "not yet implemented" }
+
+! { dg-final { cleanup-modules "final_type" } }