From 223f0f576a9c3164a833214037e8841661d0aa1a Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 2 Jun 2008 20:03:03 +0000 Subject: [PATCH] 2008-06-02 Daniel Kraft * 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 * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@136293 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 24 ++++++ gcc/fortran/decl.c | 106 +++++++++++++++++++++++ gcc/fortran/gfortran.h | 21 ++++- gcc/fortran/match.h | 1 + gcc/fortran/parse.c | 62 ++++++++++++- gcc/fortran/resolve.c | 144 +++++++++++++++++++++++++++++++ gcc/fortran/symbol.c | 32 +++++++ gcc/testsuite/ChangeLog | 11 +++ gcc/testsuite/gfortran.dg/finalize_1.f08 | 31 +++++++ gcc/testsuite/gfortran.dg/finalize_2.f03 | 23 +++++ gcc/testsuite/gfortran.dg/finalize_3.f03 | 25 ++++++ gcc/testsuite/gfortran.dg/finalize_4.f03 | 55 ++++++++++++ gcc/testsuite/gfortran.dg/finalize_5.f03 | 114 ++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/finalize_6.f90 | 35 ++++++++ gcc/testsuite/gfortran.dg/finalize_7.f03 | 59 +++++++++++++ gcc/testsuite/gfortran.dg/finalize_8.f03 | 37 ++++++++ 16 files changed, 778 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/finalize_1.f08 create mode 100644 gcc/testsuite/gfortran.dg/finalize_2.f03 create mode 100644 gcc/testsuite/gfortran.dg/finalize_3.f03 create mode 100644 gcc/testsuite/gfortran.dg/finalize_4.f03 create mode 100644 gcc/testsuite/gfortran.dg/finalize_5.f03 create mode 100644 gcc/testsuite/gfortran.dg/finalize_6.f90 create mode 100644 gcc/testsuite/gfortran.dg/finalize_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/finalize_8.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 06fc54c..1a3d2da 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,27 @@ +2008-06-02 Daniel Kraft + + * 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 Franke PR fortran/36375 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 79044eb..f6884f2 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e3a9446..d4f9771 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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_gsymbol *, const char *); 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; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index d46e163..3f8d310 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index b7e6391..dc1a62b 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8044990..c980935 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7439,6 +7439,146 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) } +/* 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 at %L is not yet implemented", &derived->declared_at); + + 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) diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index e98a19c..78561aa 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2096,6 +2096,7 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types) 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_namespace *ns) /* 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) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4cf3f8e..6cacd32 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2008-06-02 Daniel Kraft + + * 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. + 2008-06-01 Richard Sandiford * gcc.c-torture/execute/ieee/ieee.exp: Load c-torture.exp. diff --git a/gcc/testsuite/gfortran.dg/finalize_1.f08 b/gcc/testsuite/gfortran.dg/finalize_1.f08 new file mode 100644 index 0000000..e1501ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_1.f08 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_2.f03 b/gcc/testsuite/gfortran.dg/finalize_2.f03 new file mode 100644 index 0000000..b91bedf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_2.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_3.f03 b/gcc/testsuite/gfortran.dg/finalize_3.f03 new file mode 100644 index 0000000..edc493b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_3.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_4.f03 b/gcc/testsuite/gfortran.dg/finalize_4.f03 new file mode 100644 index 0000000..6e99256 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_4.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_5.f03 b/gcc/testsuite/gfortran.dg/finalize_5.f03 new file mode 100644 index 0000000..9f5dc17 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_5.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_6.f90 b/gcc/testsuite/gfortran.dg/finalize_6.f90 new file mode 100644 index 0000000..e790f4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_6.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_7.f03 b/gcc/testsuite/gfortran.dg/finalize_7.f03 new file mode 100644 index 0000000..db6b4be --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_7.f03 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_8.f03 b/gcc/testsuite/gfortran.dg/finalize_8.f03 new file mode 100644 index 0000000..6a4a135 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_8.f03 @@ -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" } } -- 2.7.4