procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

gfortran.h (gfc_typebound_proc): New struct.

Browse source 
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.

From-SVN: r139534
This commit is contained in:
Daniel Kraft 2008-08-24 18:15:27 +02:00 • committed by Daniel Kraft
parent 6c3385c1dd
commit 30b608eb7c
15 changed files with 1331 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
gcc/fortran/ChangeLog
View file

@ -1,3 +1,30 @@
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

305
gcc/fortran/decl.c
View file

@ -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;
}

26
gcc/fortran/gfortran.h
View file

@ -991,6 +991,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
@ -1127,6 +1148,8 @@ typedef struct gfc_symtree
}
n;
/* Data for type-bound procedures; NULL if no type-bound procedure. */
gfc_typebound_proc* typebound;
}
gfc_symtree;
@ -2237,6 +2260,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 */

192
gcc/fortran/parse.c
View file

@ -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_PROCEDURE:
gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
error_flag = 1;
break;
case ST_FINAL:
if (!seen_contains)
{
gfc_error ("FINAL declaration at %C must be inside CONTAINS");
error_flag = 1;
}
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: FINAL procedure declaration"
" at %C") == FAILURE)
error_flag = 1;
accept_statement (ST_FINAL);
seen_contains_comp = 1;
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);

4
gcc/fortran/parse.h
View file

@ -29,8 +29,8 @@ along with GCC; see the file COPYING3. If not see
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;

319
gcc/fortran/resolve.c
View file

@ -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;

45
gcc/fortran/symbol.c
View file

@ -2225,6 +2225,7 @@ gfc_new_symtree (gfc_symtree **root, const char *name)
st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
st->typebound = NULL;
gfc_insert_bbt (root, st, compare_symtree);
return st;
@ -4238,3 +4239,47 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
/* 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;
}

11
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,14 @@
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

2
gcc/testsuite/gfortran.dg/finalize_5.f03
View file

@ -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" }

69
gcc/testsuite/gfortran.dg/typebound_proc_1.f08 Normal file
View file

@ -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" } }

35
gcc/testsuite/gfortran.dg/typebound_proc_2.f90 Normal file
View file

@ -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" }

17
gcc/testsuite/gfortran.dg/typebound_proc_3.f03 Normal file
View file

@ -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" } }

43
gcc/testsuite/gfortran.dg/typebound_proc_4.f03 Normal file
View file

@ -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" } }

121
gcc/testsuite/gfortran.dg/typebound_proc_5.f03 Normal file
View file

@ -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" }

182
gcc/testsuite/gfortran.dg/typebound_proc_6.f03 Normal file
View file

@ -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" }