+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 Franke <franke.daniel@gmail.com>
PR fortran/36375
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;
}
+/* 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;
+}
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,
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 */
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];
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 */
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;
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);
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;
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;
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
+ seen_contains = 0;
+ seen_contains_comp = 0;
compiling_type = 1;
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 "
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 "
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;
}
+/* 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
}
}
+ /* 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)
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;
gfc_free_formal_arglist (sym->formal);
+ gfc_free_namespace (sym->f2k_derived);
+
gfc_free (sym);
}
/* Clear the ptrs we may need. */
p->common_block = NULL;
+ p->f2k_derived = NULL;
return p;
}
}
+/* 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. */
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)
{
+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.
+
2008-06-01 Richard Sandiford <rdsandiford@googlemail.com>
* gcc.c-torture/execute/ieee/ieee.exp: Load c-torture.exp.
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
git://gcc.gnu.org / gcc.git / commitdiff