This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Fortran, Patch] Proposed type-bound procedures patch, part 1
- From: Daniel Kraft <d at domob dot eu>
- To: Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>
- Cc: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 24 Aug 2008 15:50:21 +0200
- Subject: Re: [Fortran, Patch] Proposed type-bound procedures patch, part 1
- References: <20080822205832.GA27749@physik.fu-berlin.de>
Hi Tobias et al.,
here's an updated version of my patch, incorporating your comments below
and new logic to check if overriding is allowed based on the procedures'
attributes and formal arglists.
Except the minor changes for the comments, new is
check_typebound_override in resolve.c and the corresponding
typebound_proc_6.f03 test; the other parts were untouched.
This patch does no full checking for correct function result type and
argument type characteristics, see the two FIXME's in the code. I will
open a PR for this issue when committing and will work on this when I
find time.
Regression test on GNU/Linux-x86-32 running. Ok to commit when no
regressions?
My comments:
+ /* XXX: Below is quite a lot of ugly code duplication... I couldrewrite this
+ using macros, but that might be even uglier... What do you think? Any
+ completely other suggestions maybe? */
I don't have any good idea. For procedure pointer components, one has
the same problem. (Actually, match_binding_attributes can be used for
both, (NO)PASS and PUBLIC/PRIVATE are the same; proc. pointers need POINTER
while type-bounds procedures have DEFERRED and NON_OVERRIDABLE.)
I've removed the comment, we can think about clean-up and refactoring later.
You could add DEFERRED to match_binding_attributes (or add a TODO).
[I would go for the latter.]
I added code to match DEFERRED and print an unsupported error.
+ /* XXX: Here's nothing about the need to be inside the specification part of
+ a module! */
True. There is only something about module procedures or external
procedures.
Fixed the check in resolve_typebound_proc to handle this correctly.
+ /* TODO: Implement PROCEDURE(interface). */
Aha, that explains why PROCEDURE(foo) gives strange error messages.
Maybe one should add an if(match(" (")) gfc_error
with: Procedure with interface only allowed in abstract types"
That gives a nice error message, which is valid as long as abstract
types are not supported.
Done.
+ /* XXX: Should we use static array of GFC_MAX_SYMBOL_LENGTH+1 characters?
+ This makes life easier to avoid leaking but may cost a lot of memory if
+ there are lots of these structs around. */
I think either is OK - I don't have strong preferences for either.
I stayed with the pointer as I like this slightly better.
+/* XXX: Which file to put this best in? */
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
Spontaneously I would say: symbol.c, but resolve.c is also OK.
Moved together with the find-supertype method to symbol.c.
+ if (!proc->attr.subroutine && !proc->attr.function)
+ {
+ gfc_error ("Binding-target '%s' must be a procedure at %L",
+ proc->name, &where);
+ goto error;
+ }
The error message is misleading for:
procedure() :: foo
[...]
type t
contains
procedure,nopass :: foo
Here, foo is a procedure - but without an explicit interface and
without knowing whether it is a subroutine or a function. How about:
Additionally, I find "binding-target" not that easy to understand. How
about:
"Error: Procedure must be a module procedure or an external
procedure with an explicit interface"
Changed to this one.
+ gfc_error ("Binding-target '%s' with PASS(%s) at %L has no"
+ gfc_error ("Binding-target '%s' with PASS at %L must have at"
+ gfc_error ("Argument '%s' of the binding target '%s' with PASS(%s)"
Ditto: I still do not like "Binding-target" - how about "Procedure" ?
Changed.
+! XXX: Do overriding bindings have to have the same or some "matching" signature
+! as their overridden binding?
Yes, see long list in "4.5.6.2 Type-bound procedure overriding".
See resolve.c:check_typebound_override for my implementation of this
section.
+ ! XXX: How to do a PRIVATE subroutine for access checking?
You don't mean something like the following, do you? Without parsing the
CALL statement, it is a bit difficult to test.
No, I meant something like
MODULE somemod
CONTAINS
PRIVATE SUBROUTINE foo () ! If something like this is possible
END SUBROUTINE foo
END MODULE somemod
...
TYPE t
CONTAINS
PROCEDURE, NOPASS :: foo ! Error, foo is not accessible
END TYPE t
Is this possible and if so, how? Then I'll add a check for this case.
+ /* Find the super-type of the current derived type. */
+ /* XXX: Should we do this one time and make super_type a global, too?
*/
+ super_type = get_derived_super_type (resolve_bindings_derived);
I don't have a strong opinion on this. It is a question of speed vs.
complexity/readability. I'm not convinced that it will help much with
the calculation speed. (And I have to admit I'm not too concerned about
the compilation speed - unless something becomes really a hot spot.)
Left it as it was, I think this is clearer.
Can you add additional checks for
(a) procedures which are abstract interfaces [like "three"]
(b) neither module nor external procedures [like "bar"]
see my previous email with the example at
http://gcc.gnu.org/ml/fortran/2008-08/msg00150.html
Done, those should work.
Otherwise OK if you add a not-yet-implemented error.
Thanks for the patch.
Added the error.
Thanks for the review!
Daniel
--
Done: Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go: Hea-Kni-Mon-Pri-Ran-Rog-Tou
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-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.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 139491)
+++ gcc/fortran/symbol.c (working copy)
@@ -2251,6 +2251,7 @@ gfc_new_symtree (gfc_symtree **root, con
st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
+ st->typebound = NULL;
gfc_insert_bbt (root, st, compare_symtree);
return st;
@@ -4264,3 +4265,47 @@ gfc_check_symbol_typed (gfc_symbol* sym,
/* 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;
+}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 139491)
+++ gcc/fortran/decl.c (working copy)
@@ -4320,6 +4320,8 @@ syntax:
/* General matcher for PROCEDURE declarations. */
+static match match_procedure_in_type (void);
+
match
gfc_match_procedure (void)
{
@@ -4338,9 +4340,12 @@ 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;
}
@@ -5099,7 +5104,7 @@ gfc_match_end (gfc_statement *st)
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
@@ -5146,6 +5151,7 @@ gfc_match_end (gfc_statement *st)
break;
case COMP_DERIVED:
+ case COMP_DERIVED_CONTAINS:
*st = ST_END_TYPE;
target = " type";
eos_ok = 0;
@@ -5823,9 +5829,12 @@ gfc_match_private (gfc_statement *st)
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");
@@ -6704,6 +6713,270 @@ cleanup:
}
+/* 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
@@ -6714,18 +6987,20 @@ gfc_match_final_decl (void)
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");
@@ -6783,7 +7058,7 @@ gfc_match_final_decl (void)
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!",
@@ -6792,14 +7067,14 @@ gfc_match_final_decl (void)
}
/* 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;
}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 139491)
+++ gcc/fortran/gfortran.h (working copy)
@@ -992,6 +992,27 @@ typedef struct
}
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
@@ -1128,6 +1149,8 @@ typedef struct gfc_symtree
}
n;
+ /* Data for type-bound procedures; NULL if no type-bound procedure. */
+ gfc_typebound_proc* typebound;
}
gfc_symtree;
@@ -2241,6 +2264,9 @@ void gfc_symbol_state (void);
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 */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 139491)
+++ gcc/fortran/resolve.c (working copy)
@@ -7613,6 +7613,321 @@ error:
}
+/* 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
@@ -7722,6 +8037,10 @@ resolve_fl_derived (gfc_symbol *sym)
}
}
+ /* 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;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 139491)
+++ gcc/fortran/parse.c (working copy)
@@ -1691,13 +1691,143 @@ unexpected_eof (void)
}
+/* 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;
@@ -1713,8 +1843,6 @@ parse_derived (void)
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
- seen_contains = 0;
- seen_contains_comp = 0;
compiling_type = 1;
@@ -1727,34 +1855,22 @@ parse_derived (void)
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
@@ -1763,22 +1879,10 @@ parse_derived (void)
== FAILURE))
error_flag = 1;
- if (seen_contains && !seen_contains_comp
- && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
- "definition at %C with empty CONTAINS "
- "section") == FAILURE))
- error_flag = 1;
-
accept_statement (ST_END_TYPE);
break;
case ST_PRIVATE:
- if (seen_contains)
- {
- gfc_error ("PRIVATE statement at %C must precede CONTAINS");
- error_flag = 1;
- }
-
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
@@ -1802,17 +1906,12 @@ parse_derived (void)
}
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 "
@@ -1842,15 +1941,10 @@ parse_derived (void)
" 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);
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h (revision 139491)
+++ gcc/fortran/parse.h (working copy)
@@ -29,8 +29,8 @@ along with GCC; see the file COPYING3.
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;
Index: gcc/testsuite/gfortran.dg/finalize_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/finalize_5.f03 (revision 139491)
+++ gcc/testsuite/gfortran.dg/finalize_5.f03 (working copy)
@@ -9,7 +9,7 @@ MODULE final_type
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" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 0)
@@ -0,0 +1,69 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_3.f03 (revision 0)
@@ -0,0 +1,17 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_4.f03 (revision 0)
@@ -0,0 +1,43 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_2.f90 (revision 0)
@@ -0,0 +1,35 @@
+! { 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" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (revision 0)
@@ -0,0 +1,121 @@
+! { 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" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 0)
@@ -0,0 +1,182 @@
+! { 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" }