+2008-08-24 Daniel Kraft <d@domob.eu>
+
+ * gfortran.h (gfc_typebound_proc): New struct.
+ (gfc_symtree): New member typebound.
+ (gfc_find_typebound_proc): Prototype for new method.
+ (gfc_get_derived_super_type): Prototype for new method.
+ * parse.h (gfc_compile_state): New state COMP_DERIVED_CONTAINS.
+ * decl.c (gfc_match_procedure): Handle PROCEDURE inside derived-type
+ CONTAINS section.
+ (gfc_match_end): Handle new context COMP_DERIVED_CONTAINS.
+ (gfc_match_private): Ditto.
+ (match_binding_attributes), (match_procedure_in_type): New methods.
+ (gfc_match_final_decl): Rewrote to make use of new
+ COMP_DERIVED_CONTAINS parser state.
+ * parse.c (typebound_default_access): New global helper variable.
+ (set_typebound_default_access): New callback method.
+ (parse_derived_contains): New method.
+ (parse_derived): Extracted handling of CONTAINS to new parser state
+ and parse_derived_contains.
+ * resolve.c (resolve_bindings_derived), (resolve_bindings_result): New.
+ (check_typebound_override), (resolve_typebound_procedure): New methods.
+ (resolve_typebound_procedures): New method.
+ (resolve_fl_derived): Call new resolving method for typebound procs.
+ * symbol.c (gfc_new_symtree): Initialize new member typebound to NULL.
+ (gfc_find_typebound_proc): New method.
+ (gfc_get_derived_super_type): New method.
+
2008-08-23 Janus Weil <janus@gcc.gnu.org>
* gfortran.h (gfc_component): Add field "symbol_attribute attr", remove
/* General matcher for PROCEDURE declarations. */
+static match match_procedure_in_type (void);
+
match
gfc_match_procedure (void)
{
m = match_procedure_in_interface ();
break;
case COMP_DERIVED:
- gfc_error ("Fortran 2003: Procedure components at %C are "
- "not yet implemented in gfortran");
+ gfc_error ("Fortran 2003: Procedure components at %C are not yet"
+ " implemented in gfortran");
return MATCH_ERROR;
+ case COMP_DERIVED_CONTAINS:
+ m = match_procedure_in_type ();
+ break;
default:
return MATCH_NO;
}
block_name = gfc_current_block () == NULL
? NULL : gfc_current_block ()->name;
- if (state == COMP_CONTAINS)
+ if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS)
{
state = gfc_state_stack->previous->state;
block_name = gfc_state_stack->previous->sym == NULL
break;
case COMP_DERIVED:
+ case COMP_DERIVED_CONTAINS:
*st = ST_END_TYPE;
target = " type";
eos_ok = 0;
return MATCH_NO;
if (gfc_current_state () != COMP_MODULE
- && (gfc_current_state () != COMP_DERIVED
- || !gfc_state_stack->previous
- || gfc_state_stack->previous->state != COMP_MODULE))
+ && !(gfc_current_state () == COMP_DERIVED
+ && gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_MODULE)
+ && !(gfc_current_state () == COMP_DERIVED_CONTAINS
+ && gfc_state_stack->previous && gfc_state_stack->previous->previous
+ && gfc_state_stack->previous->previous->state == COMP_MODULE))
{
gfc_error ("PRIVATE statement at %C is only allowed in the "
"specification part of a module");
}
+/* Match binding attributes. */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba)
+{
+ bool found_passing = false;
+ match m;
+
+ /* Intialize to defaults. Do so even before the MATCH_NO check so that in
+ this case the defaults are in there. */
+ ba->access = ACCESS_UNKNOWN;
+ ba->pass_arg = NULL;
+ ba->pass_arg_num = 0;
+ ba->nopass = 0;
+ ba->non_overridable = 0;
+
+ /* If we find a comma, we believe there are binding attributes. */
+ if (gfc_match_char (',') == MATCH_NO)
+ return MATCH_NO;
+
+ do
+ {
+ /* NOPASS flag. */
+ m = gfc_match (" nopass");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (found_passing)
+ {
+ gfc_error ("Binding attributes already specify passing, illegal"
+ " NOPASS at %C");
+ goto error;
+ }
+
+ found_passing = true;
+ ba->nopass = 1;
+ continue;
+ }
+
+ /* NON_OVERRIDABLE flag. */
+ m = gfc_match (" non_overridable");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->non_overridable)
+ {
+ gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+ goto error;
+ }
+
+ ba->non_overridable = 1;
+ continue;
+ }
+
+ /* DEFERRED flag. */
+ /* TODO: Handle really once implemented. */
+ m = gfc_match (" deferred");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ gfc_error ("DEFERRED not yet implemented at %C");
+ goto error;
+ }
+
+ /* PASS possibly including argument. */
+ m = gfc_match (" pass");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (found_passing)
+ {
+ gfc_error ("Binding attributes already specify passing, illegal"
+ " PASS at %C");
+ goto error;
+ }
+
+ m = gfc_match (" ( %n )", arg);
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ ba->pass_arg = xstrdup (arg);
+ gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+ found_passing = true;
+ ba->nopass = 0;
+ continue;
+ }
+
+ /* Access specifier. */
+
+ m = gfc_match (" public");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Duplicate access-specifier at %C");
+ goto error;
+ }
+
+ ba->access = ACCESS_PUBLIC;
+ continue;
+ }
+
+ m = gfc_match (" private");
+ if (m == MATCH_ERROR)
+ goto error;
+ if (m == MATCH_YES)
+ {
+ if (ba->access != ACCESS_UNKNOWN)
+ {
+ gfc_error ("Duplicate access-specifier at %C");
+ goto error;
+ }
+
+ ba->access = ACCESS_PRIVATE;
+ continue;
+ }
+
+ /* Nothing matching found. */
+ gfc_error ("Expected binding attribute at %C");
+ goto error;
+ }
+ while (gfc_match_char (',') == MATCH_YES);
+
+ return MATCH_YES;
+
+error:
+ gfc_free (ba->pass_arg);
+ return MATCH_ERROR;
+}
+
+
+/* Match a PROCEDURE specific binding inside a derived type. */
+
+static match
+match_procedure_in_type (void)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ char target_buf[GFC_MAX_SYMBOL_LEN + 1];
+ char* target;
+ gfc_typebound_proc* tb;
+ bool seen_colons;
+ bool seen_attrs;
+ match m;
+ gfc_symtree* stree;
+ gfc_namespace* ns;
+ gfc_symbol* block;
+
+ /* Check current state. */
+ gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+ block = gfc_state_stack->previous->sym;
+ gcc_assert (block);
+
+ /* TODO: Really implement PROCEDURE(interface). */
+ if (gfc_match (" (") == MATCH_YES)
+ {
+ gfc_error ("Procedure with interface only allowed in abstract types at"
+ " %C");
+ return MATCH_ERROR;
+ }
+
+ /* Construct the data structure. */
+ tb = XCNEW (gfc_typebound_proc);
+ tb->where = gfc_current_locus;
+
+ /* Match binding attributes. */
+ m = match_binding_attributes (tb);
+ if (m == MATCH_ERROR)
+ return m;
+ seen_attrs = (m == MATCH_YES);
+
+ /* Match the colons. */
+ m = gfc_match (" ::");
+ if (m == MATCH_ERROR)
+ return m;
+ seen_colons = (m == MATCH_YES);
+ if (seen_attrs && !seen_colons)
+ {
+ gfc_error ("Expected '::' after binding-attributes at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Match the binding name. */
+ m = gfc_match_name (name);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding name at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Try to match the '=> target', if it's there. */
+ target = NULL;
+ m = gfc_match (" =>");
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_YES)
+ {
+ if (!seen_colons)
+ {
+ gfc_error ("'::' needed in PROCEDURE binding with explicit target"
+ " at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Expected binding target after '=>' at %C");
+ return MATCH_ERROR;
+ }
+ target = target_buf;
+ }
+
+ /* Now we should have the end. */
+ m = gfc_match_eos ();
+ if (m == MATCH_ERROR)
+ return m;
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Junk after PROCEDURE declaration at %C");
+ return MATCH_ERROR;
+ }
+
+ /* If no target was found, it has the same name as the binding. */
+ if (!target)
+ target = name;
+
+ /* Get the namespace to insert the symbols into. */
+ ns = block->f2k_derived;
+ gcc_assert (ns);
+
+ /* See if we already have a binding with this name in the symtree which would
+ be an error. */
+ stree = gfc_find_symtree (ns->sym_root, name);
+ if (stree)
+ {
+ gfc_error ("There's already a procedure with binding name '%s' for the"
+ " derived type '%s' at %C", name, block->name);
+ return MATCH_ERROR;
+ }
+
+ /* Insert it and set attributes. */
+ if (gfc_get_sym_tree (name, ns, &stree))
+ return MATCH_ERROR;
+ if (gfc_get_sym_tree (target, gfc_current_ns, &tb->target))
+ return MATCH_ERROR;
+ stree->typebound = tb;
+
+ return MATCH_YES;
+}
+
+
/* Match a FINAL declaration inside a derived type. */
match
match m;
gfc_namespace* module_ns;
bool first, last;
+ gfc_symbol* block;
- if (gfc_state_stack->state != COMP_DERIVED)
+ if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
{
gfc_error ("FINAL declaration at %C must be inside a derived type "
- "definition!");
+ "CONTAINS section");
return MATCH_ERROR;
}
- gcc_assert (gfc_current_block ());
+ block = gfc_state_stack->previous->sym;
+ gcc_assert (block);
- if (!gfc_state_stack->previous
- || gfc_state_stack->previous->state != COMP_MODULE)
+ if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous
+ || gfc_state_stack->previous->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;
/* 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)
+ for (f = block->f2k_derived->finalizers; f; f = f->next)
if (f->proc_sym == sym)
{
gfc_error ("'%s' at %C is already defined as FINAL procedure!",
}
/* Add this symbol to the list of finalizers. */
- gcc_assert (gfc_current_block ()->f2k_derived);
+ gcc_assert (block->f2k_derived);
++sym->refs;
f = XCNEW (gfc_finalizer);
f->proc_sym = sym;
f->proc_tree = NULL;
f->where = gfc_current_locus;
- f->next = gfc_current_block ()->f2k_derived->finalizers;
- gfc_current_block ()->f2k_derived->finalizers = f;
+ f->next = block->f2k_derived->finalizers;
+ block->f2k_derived->finalizers = f;
first = false;
}
}
gfc_user_op;
+
+/* Data needed for type-bound procedures. */
+typedef struct
+{
+ struct gfc_symtree* target;
+ locus where; /* Where the PROCEDURE definition was. */
+
+ gfc_access access;
+ char* pass_arg; /* Argument-name for PASS. NULL if not specified. */
+
+ /* Once resolved, we use the position of pass_arg in the formal arglist of
+ the binding-target procedure to identify it. The first argument has
+ number 0 here, the second 1, and so on. */
+ unsigned pass_arg_num;
+
+ unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
+ unsigned non_overridable:1;
+}
+gfc_typebound_proc;
+
+
/* Symbol nodes. These are important things. They are what the
standard refers to as "entities". The possibly multiple names that
refer to the same entity are accomplished by a binary tree of
}
n;
+ /* Data for type-bound procedures; NULL if no type-bound procedure. */
+ gfc_typebound_proc* typebound;
}
gfc_symtree;
gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
+gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
+
void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
}
+/* Set the default access attribute for a typebound procedure; this is used
+ as callback for gfc_traverse_symtree. */
+
+static gfc_access typebound_default_access;
+
+static void
+set_typebound_default_access (gfc_symtree* stree)
+{
+ if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN)
+ stree->typebound->access = typebound_default_access;
+}
+
+
+/* Parse the CONTAINS section of a derived type definition. */
+
+static bool
+parse_derived_contains (void)
+{
+ gfc_state_data s;
+ bool seen_private = false;
+ bool seen_comps = false;
+ bool error_flag = false;
+ bool to_finish;
+
+ accept_statement (ST_CONTAINS);
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+ push_state (&s, COMP_DERIVED_CONTAINS, NULL);
+
+ to_finish = false;
+ while (!to_finish)
+ {
+ gfc_statement st;
+ st = next_statement ();
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
+
+ case ST_DATA_DECL:
+ gfc_error ("Components in TYPE at %C must precede CONTAINS");
+ error_flag = true;
+ break;
+
+ case ST_PROCEDURE:
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
+ " procedure at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_PROCEDURE);
+ seen_comps = true;
+ break;
+
+ case ST_FINAL:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: FINAL procedure declaration"
+ " at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_FINAL);
+ seen_comps = true;
+ break;
+
+ case ST_END_TYPE:
+ to_finish = true;
+
+ if (!seen_comps
+ && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+ "definition at %C with empty CONTAINS "
+ "section") == FAILURE))
+ error_flag = true;
+
+ /* ST_END_TYPE is accepted by parse_derived after return. */
+ break;
+
+ case ST_PRIVATE:
+ if (gfc_find_state (COMP_MODULE) == FAILURE)
+ {
+ gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+ "a MODULE");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_comps)
+ {
+ gfc_error ("PRIVATE statement at %C must precede procedure"
+ " bindings");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_private)
+ {
+ gfc_error ("Duplicate PRIVATE statement at %C");
+ error_flag = true;
+ }
+
+ accept_statement (ST_PRIVATE);
+ seen_private = true;
+ break;
+
+ case ST_SEQUENCE:
+ gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+ error_flag = true;
+ break;
+
+ case ST_CONTAINS:
+ gfc_error ("Already inside a CONTAINS block at %C");
+ error_flag = true;
+ break;
+
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+
+ pop_state ();
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+
+ /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
+ to PUBLIC or PRIVATE depending on seen_private. */
+ typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
+ gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
+ &set_typebound_default_access);
+
+ return error_flag;
+}
+
+
/* Parse a derived type. */
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;
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
- seen_contains = 0;
- seen_contains_comp = 0;
compiling_type = 1;
unexpected_eof ();
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;
+ case ST_PROCEDURE:
+ gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
+ error_flag = 1;
+ break;
- accept_statement (ST_FINAL);
- seen_contains_comp = 1;
+ case ST_FINAL:
+ gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+ error_flag = 1;
break;
case ST_END_TYPE:
+endType:
compiling_type = 0;
if (!seen_component
== 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 "
}
s.sym->component_access = ACCESS_PRIVATE;
+
accept_statement (ST_PRIVATE);
seen_private = 1;
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 "
" 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;
+ if (parse_derived_contains ())
+ error_flag = 1;
+ goto endType;
default:
unexpected_statement (st);
typedef enum
{
COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION,
- COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO,
- COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
+ COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF,
+ COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_OMP_STRUCTURED_BLOCK
}
gfc_compile_state;
}
+/* Check that it is ok for the typebound procedure proc to override the
+ procedure old. */
+
+static gfc_try
+check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
+{
+ locus where;
+ const gfc_symbol* proc_target;
+ const gfc_symbol* old_target;
+ unsigned proc_pass_arg, old_pass_arg, argpos;
+ gfc_formal_arglist* proc_formal;
+ gfc_formal_arglist* old_formal;
+
+ where = proc->typebound->where;
+ proc_target = proc->typebound->target->n.sym;
+ old_target = old->typebound->target->n.sym;
+
+ /* Check that overridden binding is not NON_OVERRIDABLE. */
+ if (old->typebound->non_overridable)
+ {
+ gfc_error ("'%s' at %L overrides a procedure binding declared"
+ " NON_OVERRIDABLE", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is PURE, the overriding must be, too. */
+ if (old_target->attr.pure && !proc_target->attr.pure)
+ {
+ gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+ proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
+ is not, the overriding must not be either. */
+ if (old_target->attr.elemental && !proc_target->attr.elemental)
+ {
+ gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+ " ELEMENTAL", proc->name, &where);
+ return FAILURE;
+ }
+ if (!old_target->attr.elemental && proc_target->attr.elemental)
+ {
+ gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+ " be ELEMENTAL, either", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is a SUBROUTINE, the overriding must also be a
+ SUBROUTINE. */
+ if (old_target->attr.subroutine && !proc_target->attr.subroutine)
+ {
+ gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+ " SUBROUTINE", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is a FUNCTION, the overriding must also be a
+ FUNCTION and have the same characteristics. */
+ if (old_target->attr.function)
+ {
+ if (!proc_target->attr.function)
+ {
+ gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+ " FUNCTION", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* FIXME: Do more comprehensive checking (including, for instance, the
+ rank and array-shape). */
+ gcc_assert (proc_target->result && old_target->result);
+ if (!gfc_compare_types (&proc_target->result->ts,
+ &old_target->result->ts))
+ {
+ gfc_error ("'%s' at %L and the overridden FUNCTION should have"
+ " matching result types", proc->name, &where);
+ return FAILURE;
+ }
+ }
+
+ /* If the overridden binding is PUBLIC, the overriding one must not be
+ PRIVATE. */
+ if (old->typebound->access == ACCESS_PUBLIC
+ && proc->typebound->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+ " PRIVATE", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* Compare the formal argument lists of both procedures. This is also abused
+ to find the position of the passed-object dummy arguments of both
+ bindings as at least the overridden one might not yet be resolved and we
+ need those positions in the check below. */
+ proc_pass_arg = old_pass_arg = 0;
+ if (!proc->typebound->nopass && !proc->typebound->pass_arg)
+ proc_pass_arg = 1;
+ if (!old->typebound->nopass && !old->typebound->pass_arg)
+ old_pass_arg = 1;
+ argpos = 1;
+ for (proc_formal = proc_target->formal, old_formal = old_target->formal;
+ proc_formal && old_formal;
+ proc_formal = proc_formal->next, old_formal = old_formal->next)
+ {
+ if (proc->typebound->pass_arg
+ && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
+ proc_pass_arg = argpos;
+ if (old->typebound->pass_arg
+ && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
+ old_pass_arg = argpos;
+
+ /* Check that the names correspond. */
+ if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+ {
+ gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+ " to match the corresponding argument of the overridden"
+ " procedure", proc_formal->sym->name, proc->name, &where,
+ old_formal->sym->name);
+ return FAILURE;
+ }
+
+ /* Check that the types correspond if neither is the passed-object
+ argument. */
+ /* FIXME: Do more comprehensive testing here. */
+ if (proc_pass_arg != argpos && old_pass_arg != argpos
+ && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
+ {
+ gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
+ " in respect to the overridden procedure",
+ proc_formal->sym->name, proc->name, &where);
+ return FAILURE;
+ }
+
+ ++argpos;
+ }
+ if (proc_formal || old_formal)
+ {
+ gfc_error ("'%s' at %L must have the same number of formal arguments as"
+ " the overridden procedure", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is NOPASS, the overriding one must also be
+ NOPASS. */
+ if (old->typebound->nopass && !proc->typebound->nopass)
+ {
+ gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+ " NOPASS", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is PASS(x), the overriding one must also be
+ PASS and the passed-object dummy arguments must correspond. */
+ if (!old->typebound->nopass)
+ {
+ if (proc->typebound->nopass)
+ {
+ gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+ " PASS", proc->name, &where);
+ return FAILURE;
+ }
+
+ if (proc_pass_arg != old_pass_arg)
+ {
+ gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+ " the same position as the passed-object dummy argument of"
+ " the overridden procedure", proc->name, &where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+/* Resolve the type-bound procedures for a derived type. */
+
+static gfc_symbol* resolve_bindings_derived;
+static gfc_try resolve_bindings_result;
+
+static void
+resolve_typebound_procedure (gfc_symtree* stree)
+{
+ gfc_symbol* proc;
+ locus where;
+ gfc_symbol* me_arg;
+ gfc_symbol* super_type;
+
+ /* If this is no type-bound procedure, just return. */
+ if (!stree->typebound)
+ return;
+
+ /* Get the target-procedure to check it. */
+ gcc_assert (stree->typebound->target);
+ proc = stree->typebound->target->n.sym;
+ where = stree->typebound->where;
+
+ /* Default access should already be resolved from the parser. */
+ gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
+
+ /* It should be a module procedure or an external procedure with explicit
+ interface. */
+ if ((!proc->attr.subroutine && !proc->attr.function)
+ || (proc->attr.proc != PROC_MODULE
+ && proc->attr.if_source != IFSRC_IFBODY)
+ || proc->attr.abstract)
+ {
+ gfc_error ("'%s' must be a module procedure or an external procedure with"
+ " an explicit interface at %L", proc->name, &where);
+ goto error;
+ }
+
+ /* Find the super-type of the current derived type. We could do this once and
+ store in a global if speed is needed, but as long as not I believe this is
+ more readable and clearer. */
+ super_type = gfc_get_derived_super_type (resolve_bindings_derived);
+
+ /* If PASS, resolve and check arguments. */
+ if (!stree->typebound->nopass)
+ {
+ if (stree->typebound->pass_arg)
+ {
+ gfc_formal_arglist* i;
+
+ /* If an explicit passing argument name is given, walk the arg-list
+ and look for it. */
+
+ me_arg = NULL;
+ stree->typebound->pass_arg_num = 0;
+ for (i = proc->formal; i; i = i->next)
+ {
+ if (!strcmp (i->sym->name, stree->typebound->pass_arg))
+ {
+ me_arg = i->sym;
+ break;
+ }
+ ++stree->typebound->pass_arg_num;
+ }
+
+ if (!me_arg)
+ {
+ gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
+ " argument '%s'",
+ proc->name, stree->typebound->pass_arg, &where,
+ stree->typebound->pass_arg);
+ goto error;
+ }
+ }
+ else
+ {
+ /* Otherwise, take the first one; there should in fact be at least
+ one. */
+ stree->typebound->pass_arg_num = 0;
+ if (!proc->formal)
+ {
+ gfc_error ("Procedure '%s' with PASS at %L must have at"
+ " least one argument", proc->name, &where);
+ goto error;
+ }
+ me_arg = proc->formal->sym;
+ }
+
+ /* Now check that the argument-type matches. */
+ gcc_assert (me_arg);
+ if (me_arg->ts.type != BT_DERIVED
+ || me_arg->ts.derived != resolve_bindings_derived)
+ {
+ gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+ " the derived-type '%s'", me_arg->name, proc->name,
+ me_arg->name, &where, resolve_bindings_derived->name);
+ goto error;
+ }
+ }
+
+ /* If we are extending some type, check that we don't override a procedure
+ flagged NON_OVERRIDABLE. */
+ if (super_type)
+ {
+ gfc_symtree* overridden;
+ overridden = gfc_find_typebound_proc (super_type, stree->name);
+
+ if (overridden && check_typebound_override (stree, overridden) == FAILURE)
+ goto error;
+ }
+
+ /* FIXME: Remove once typebound-procedures are fully implemented. */
+ {
+ /* Output the error only once so we can do reasonable testing. */
+ static bool tbp_error = false;
+ if (!tbp_error)
+ gfc_error ("Type-bound procedures are not yet implemented at %L", &where);
+ tbp_error = true;
+ }
+
+ return;
+
+error:
+ resolve_bindings_result = FAILURE;
+}
+
+static gfc_try
+resolve_typebound_procedures (gfc_symbol* derived)
+{
+ if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
+ return SUCCESS;
+
+ resolve_bindings_derived = derived;
+ resolve_bindings_result = SUCCESS;
+ gfc_traverse_symtree (derived->f2k_derived->sym_root,
+ &resolve_typebound_procedure);
+
+ return resolve_bindings_result;
+}
+
+
/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
to give all identical derived types the same backend_decl. */
static void
}
}
+ /* Resolve the type-bound procedures. */
+ if (resolve_typebound_procedures (sym) == FAILURE)
+ return FAILURE;
+
/* Resolve the finalizer procedures. */
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
+ st->typebound = NULL;
gfc_insert_bbt (root, st, compare_symtree);
return st;
/* Everything is ok. */
return SUCCESS;
}
+
+
+/* Get the super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ gcc_assert (derived->components);
+ gcc_assert (derived->components->ts.type == BT_DERIVED);
+ gcc_assert (derived->components->ts.derived);
+
+ return derived->components->ts.derived;
+}
+
+
+/* Find a type-bound procedure by name for a derived-type (looking recursively
+ through the super-types). */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
+{
+ gfc_symtree* res;
+
+ /* Try to find it in the current type's namespace. */
+ gcc_assert (derived->f2k_derived);
+ res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+ if (res)
+ return res->typebound ? res : NULL;
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = gfc_get_derived_super_type (derived);
+ gcc_assert (super_type);
+ return gfc_find_typebound_proc (super_type, name);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+2008-08-24 Daniel Kraft <d@domob.eu>
+
+ * gfortran.dg/finalize_5.f03: Adapted expected error message to changes
+ to handling of CONTAINS in derived-type declarations.
+ * gfortran.dg/typebound_proc_1.f08: New test.
+ * gfortran.dg/typebound_proc_2.f90: New test.
+ * gfortran.dg/typebound_proc_3.f03: New test.
+ * gfortran.dg/typebound_proc_4.f03: New test.
+ * gfortran.dg/typebound_proc_5.f03: New test.
+ * gfortran.dg/typebound_proc_6.f03: New test.
+
2008-08-23 Tobias Burnus <burnus@net-b.de>
PR fortran/37076
TYPE :: mytype
INTEGER, ALLOCATABLE :: fooarr(:)
REAL :: foobar
- FINAL :: finalize_matrix ! { dg-error "must be inside CONTAINS" }
+ FINAL :: finalize_matrix ! { dg-error "must be inside a derived type" }
CONTAINS
FINAL :: ! { dg-error "Empty FINAL" }
FINAL ! { dg-error "Empty FINAL" }
--- /dev/null
+! { dg-do compile }
+
+! Type-bound procedures
+! Test that the basic syntax for specific bindings is parsed and resolved.
+
+MODULE othermod
+ IMPLICIT NONE
+
+CONTAINS
+
+ SUBROUTINE othersub ()
+ IMPLICIT NONE
+ END SUBROUTINE othersub
+
+END MODULE othermod
+
+MODULE testmod
+ USE othermod
+ IMPLICIT NONE
+
+ TYPE t1
+ ! Might be empty
+ CONTAINS
+ PROCEDURE proc1
+ PROCEDURE, PASS(me) :: p2 => proc2 ! { dg-error "not yet implemented" }
+ END TYPE t1
+
+ TYPE t2
+ INTEGER :: x
+ CONTAINS
+ PRIVATE
+ PROCEDURE, NOPASS, PRIVATE :: othersub
+ PROCEDURE,NON_OVERRIDABLE,PUBLIC,PASS :: proc3
+ END TYPE t2
+
+ TYPE t3
+ CONTAINS
+ ! This might be empty for Fortran 2008
+ END TYPE t3
+
+ TYPE t4
+ CONTAINS
+ PRIVATE
+ ! Empty, too
+ END TYPE t4
+
+CONTAINS
+
+ SUBROUTINE proc1 (me)
+ IMPLICIT NONE
+ TYPE(t1) :: me
+ END SUBROUTINE proc1
+
+ REAL FUNCTION proc2 (x, me)
+ IMPLICIT NONE
+ REAL :: x
+ TYPE(t1) :: me
+ proc2 = x / 2
+ END FUNCTION proc2
+
+ INTEGER FUNCTION proc3 (me)
+ IMPLICIT NONE
+ TYPE(t2) :: me
+ proc3 = 42
+ END FUNCTION proc3
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! Type-bound procedures
+! Test that F95 does not allow type-bound procedures
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE t
+ INTEGER :: x
+ CONTAINS ! { dg-error "Fortran 2003" }
+ PROCEDURE proc1 ! { dg-error "Fortran 2003" }
+ PROCEDURE :: proc2 => p2 ! { dg-error "Fortran 2003" }
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc1 (me)
+ IMPLICIT NONE
+ TYPE(t1) :: me
+ END SUBROUTINE proc1
+
+ REAL FUNCTION proc2 (me, x)
+ IMPLICIT NONE
+ TYPE(t1) :: me
+ REAL :: x
+ proc2 = x / 2
+ END FUNCTION proc2
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
+! FIXME: Remove not-yet-implemented error when implemented.
+! { dg-excess-errors "no IMPLICIT type|not yet implemented" }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! Type-bound procedures
+! Test that F2003 does not allow empty CONTAINS sections.
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE t
+ INTEGER :: x
+ CONTAINS
+ END TYPE t ! { dg-error "Fortran 2008" }
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
--- /dev/null
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for errors in specific bindings, during parsing (not resolution).
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE t
+ REAL :: a
+ CONTAINS
+ PROCEDURE p0 ! { dg-error "no IMPLICIT|module procedure" }
+ PRIVATE ! { dg-error "must precede" }
+ PROCEDURE p1 => proc1 ! { dg-error "::" }
+ PROCEDURE :: ! { dg-error "Expected binding name" }
+ PROCEDURE ! { dg-error "Expected binding name" }
+ PROCEDURE ? ! { dg-error "Expected binding name" }
+ PROCEDURE :: p2 => ! { dg-error "Expected binding target" }
+ PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" }
+ PROCEDURE p4, ! { dg-error "Junk after" }
+ PROCEDURE :: p5 => proc2, ! { dg-error "Junk after" }
+ PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" }
+ PROCEDURE, PASS p6 ! { dg-error "::" }
+ PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" }
+ PROCEDURE PASS :: ! { dg-error "Junk after" }
+ PROCEDURE, PASS (x ! { dg-error "Expected" }
+ PROCEDURE, PASS () ! { dg-error "Expected" }
+ PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" }
+ PROCEDURE, PASS, NON_OVERRIDABLE, PASS(x) ! { dg-error "illegal PASS" }
+ PROCEDURE, PUBLIC, PRIVATE ! { dg-error "Duplicate" }
+ PROCEDURE, NON_OVERRIDABLE, NON_OVERRIDABLE ! { dg-error "Duplicate" }
+ PROCEDURE, NOPASS, NOPASS ! { dg-error "illegal NOPASS" }
+
+ ! TODO: Correct these when things get implemented.
+ PROCEDURE, DEFERRED :: x ! { dg-error "not yet implemented" }
+ PROCEDURE(abc) ! { dg-error "abstract type" }
+ END TYPE t
+
+CONTAINS
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
--- /dev/null
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for errors in specific bindings, during resolution.
+
+MODULE othermod
+ IMPLICIT NONE
+CONTAINS
+
+ REAL FUNCTION proc_noarg ()
+ IMPLICIT NONE
+ END FUNCTION proc_noarg
+
+END MODULE othermod
+
+MODULE testmod
+ USE othermod
+ IMPLICIT NONE
+
+ INTEGER :: noproc
+
+ PROCEDURE() :: proc_nointf
+
+ INTERFACE
+ SUBROUTINE proc_intf ()
+ END SUBROUTINE proc_intf
+ END INTERFACE
+
+ ABSTRACT INTERFACE
+ SUBROUTINE proc_abstract_intf ()
+ END SUBROUTINE proc_abstract_intf
+ END INTERFACE
+
+ TYPE supert
+ CONTAINS
+ PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg
+ PROCEDURE, NOPASS, NON_OVERRIDABLE :: super_nonoverrid => proc_sub_noarg
+ END TYPE supert
+
+ TYPE, EXTENDS(supert) :: t
+ CONTAINS
+
+ ! Bindings that should succeed
+ PROCEDURE, NOPASS :: p0 => proc_noarg
+ PROCEDURE, PASS :: p1 => proc_arg_first
+ PROCEDURE proc_arg_first
+ PROCEDURE, PASS(me) :: p2 => proc_arg_middle
+ PROCEDURE, PASS(me), NON_OVERRIDABLE :: p3 => proc_arg_last
+ PROCEDURE, NOPASS :: p4 => proc_nome
+ PROCEDURE, NOPASS :: p5 => proc_intf
+ PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg
+
+ ! Bindings that should not succeed
+ PROCEDURE :: e0 => undefined ! { dg-error "has no IMPLICIT|module procedure" }
+ PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" }
+ PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" }
+ PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" }
+ PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "of the derived" }
+ PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "of the derived" }
+ PROCEDURE :: e6 => noproc ! { dg-error "module procedure" }
+ PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" }
+ PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" }
+ PROCEDURE :: super_nonoverrid => proc_arg_first ! { dg-error "NON_OVERRIDABLE" }
+
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc_arg_first (me, x)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ REAL :: x
+ END SUBROUTINE proc_arg_first
+
+ INTEGER FUNCTION proc_arg_middle (x, me, y)
+ IMPLICIT NONE
+ REAL :: x, y
+ TYPE(t) :: me
+ END FUNCTION proc_arg_middle
+
+ SUBROUTINE proc_arg_last (x, me)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ REAL :: x
+ END SUBROUTINE proc_arg_last
+
+ SUBROUTINE proc_nome (arg, x, y)
+ IMPLICIT NONE
+ TYPE(t) :: arg
+ REAL :: x, y
+ END SUBROUTINE proc_nome
+
+ SUBROUTINE proc_mewrong (me, x)
+ IMPLICIT NONE
+ REAL :: x
+ INTEGER :: me
+ END SUBROUTINE proc_mewrong
+
+ SUBROUTINE proc_sub_noarg ()
+ END SUBROUTINE proc_sub_noarg
+
+END MODULE testmod
+
+PROGRAM main
+ IMPLICIT NONE
+
+ TYPE t
+ CONTAINS
+ PROCEDURE, NOPASS :: proc_no_module ! { dg-error "module procedure" }
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc_no_module ()
+ END SUBROUTINE proc_no_module
+
+END PROGRAM main
+
+! { dg-final { cleanup-modules "othermod testmod" } }
+! FIXME: Remove not-yet-implemented error when implemented.
+! { dg-excess-errors "not yet implemented" }
--- /dev/null
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for the check if overriding methods "match" the overridden ones by their
+! characteristics.
+
+MODULE testmod
+ IMPLICIT NONE
+
+ TYPE supert
+ CONTAINS
+
+ ! For checking the PURE/ELEMENTAL matching.
+ PROCEDURE, NOPASS :: pure1 => proc_pure
+ PROCEDURE, NOPASS :: pure2 => proc_pure
+ PROCEDURE, NOPASS :: nonpure => proc_sub
+ PROCEDURE, NOPASS :: elemental1 => proc_elemental
+ PROCEDURE, NOPASS :: elemental2 => proc_elemental
+ PROCEDURE, NOPASS :: nonelem1 => proc_nonelem
+ PROCEDURE, NOPASS :: nonelem2 => proc_nonelem
+
+ ! Same number of arguments!
+ PROCEDURE, NOPASS :: three_args_1 => proc_threearg
+ PROCEDURE, NOPASS :: three_args_2 => proc_threearg
+
+ ! For SUBROUTINE/FUNCTION/result checking.
+ PROCEDURE, NOPASS :: subroutine1 => proc_sub
+ PROCEDURE, NOPASS :: subroutine2 => proc_sub
+ PROCEDURE, NOPASS :: intfunction1 => proc_intfunc
+ PROCEDURE, NOPASS :: intfunction2 => proc_intfunc
+ PROCEDURE, NOPASS :: intfunction3 => proc_intfunc
+
+ ! For access-based checks.
+ PROCEDURE, NOPASS, PRIVATE :: priv => proc_sub
+ PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub
+ PROCEDURE, NOPASS, PUBLIC :: publ2 => proc_sub
+
+ ! For passed-object dummy argument checks.
+ PROCEDURE, NOPASS :: nopass1 => proc_stme1
+ PROCEDURE, NOPASS :: nopass2 => proc_stme1
+ PROCEDURE, PASS :: pass1 => proc_stme1
+ PROCEDURE, PASS(me) :: pass2 => proc_stme1
+ PROCEDURE, PASS(me1) :: pass3 => proc_stmeme
+
+ ! For corresponding dummy arguments.
+ PROCEDURE, PASS :: corresp1 => proc_stmeint
+ PROCEDURE, PASS :: corresp2 => proc_stmeint
+ PROCEDURE, PASS :: corresp3 => proc_stmeint
+
+ END TYPE supert
+
+ ! Checking for NON_OVERRIDABLE is in typebound_proc_5.f03.
+
+ TYPE, EXTENDS(supert) :: t
+ CONTAINS
+
+ ! For checking the PURE/ELEMENTAL matching.
+ PROCEDURE, NOPASS :: pure1 => proc_pure ! Ok, both pure.
+ PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" }
+ PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure.
+ PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental.
+ PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be ELEMENTAL" }
+ PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental.
+ PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" }
+
+ ! Same number of arguments!
+ PROCEDURE, NOPASS :: three_args_1 => proc_threearg ! Ok.
+ PROCEDURE, NOPASS :: three_args_2 => proc_twoarg ! { dg-error "same number of formal arguments" }
+
+ ! For SUBROUTINE/FUNCTION/result checking.
+ PROCEDURE, NOPASS :: subroutine1 => proc_sub ! Ok, both subroutines.
+ PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" }
+ PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions.
+ PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" }
+ PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "matching result types" }
+
+ ! For access-based checks.
+ PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility.
+ PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub ! Ok, both PUBLIC.
+ PROCEDURE, NOPASS, PRIVATE :: publ2 => proc_sub ! { dg-error "must not be PRIVATE" }
+
+ ! For passed-object dummy argument checks.
+ PROCEDURE, NOPASS :: nopass1 => proc_stme1 ! Ok, both NOPASS.
+ PROCEDURE, PASS :: nopass2 => proc_tme1 ! { dg-error "must also be NOPASS" }
+ PROCEDURE, PASS :: pass1 => proc_tme1 ! Ok.
+ PROCEDURE, NOPASS :: pass2 => proc_stme1 ! { dg-error "must also be PASS" }
+ PROCEDURE, PASS(me2) :: pass3 => proc_tmeme ! { dg-error "same position" }
+
+ ! For corresponding dummy arguments.
+ PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok.
+ PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" }
+ PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Types mismatch for dummy argument 'a'" }
+
+ END TYPE t
+
+CONTAINS
+
+ PURE SUBROUTINE proc_pure ()
+ END SUBROUTINE proc_pure
+
+ ELEMENTAL SUBROUTINE proc_elemental (arg)
+ IMPLICIT NONE
+ INTEGER, INTENT(INOUT) :: arg
+ END SUBROUTINE proc_elemental
+
+ SUBROUTINE proc_nonelem (arg)
+ IMPLICIT NONE
+ INTEGER, INTENT(INOUT) :: arg
+ END SUBROUTINE proc_nonelem
+
+ SUBROUTINE proc_threearg (a, b, c)
+ IMPLICIT NONE
+ INTEGER :: a, b, c
+ END SUBROUTINE proc_threearg
+
+ SUBROUTINE proc_twoarg (a, b)
+ IMPLICIT NONE
+ INTEGER :: a, b
+ END SUBROUTINE proc_twoarg
+
+ SUBROUTINE proc_sub ()
+ END SUBROUTINE proc_sub
+
+ INTEGER FUNCTION proc_intfunc ()
+ proc_intfunc = 42
+ END FUNCTION proc_intfunc
+
+ REAL FUNCTION proc_realfunc ()
+ proc_realfunc = 42.0
+ END FUNCTION proc_realfunc
+
+ SUBROUTINE proc_stme1 (me, a)
+ IMPLICIT NONE
+ TYPE(supert) :: me
+ INTEGER :: a
+ END SUBROUTINE proc_stme1
+
+ SUBROUTINE proc_tme1 (me, a)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ INTEGER :: a
+ END SUBROUTINE proc_tme1
+
+ SUBROUTINE proc_stmeme (me1, me2)
+ IMPLICIT NONE
+ TYPE(supert) :: me1, me2
+ END SUBROUTINE proc_stmeme
+
+ SUBROUTINE proc_tmeme (me1, me2)
+ IMPLICIT NONE
+ TYPE(t) :: me1, me2
+ END SUBROUTINE proc_tmeme
+
+ SUBROUTINE proc_stmeint (me, a)
+ IMPLICIT NONE
+ TYPE(supert) :: me
+ INTEGER :: a
+ END SUBROUTINE proc_stmeint
+
+ SUBROUTINE proc_tmeint (me, a)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ INTEGER :: a
+ END SUBROUTINE proc_tmeint
+
+ SUBROUTINE proc_tmeintx (me, x)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ INTEGER :: x
+ END SUBROUTINE proc_tmeintx
+
+ SUBROUTINE proc_tmereal (me, a)
+ IMPLICIT NONE
+ TYPE(t) :: me
+ REAL :: a
+ END SUBROUTINE proc_tmereal
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
+! FIXME: Remove not-yet-implemented error when implemented.
+! { dg-excess-errors "not yet implemented" }
projects / gcc.git / commitdiff