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

gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.

Browse source 
2008-08-31  Daniel Kraft  <d@domob.eu>

	* gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
	(struct gfc_tbp_generic): New type.
	(struct gfc_typebound_proc): Removed `target' and added union with
	`specific' and `generic' members; new members `overridden',
	`subroutine', `function' and `is_generic'.
	(struct gfc_expr): New members `derived' and `name' in compcall union
	member and changed type of `tbp' to gfc_typebound_proc.
	(gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
	* match.h (gfc_typebound_default_access): New global.
	(gfc_match_generic): New method.
	* decl.c (gfc_match_generic): New method.
	(match_binding_attributes): New argument `generic' and handle it.
	(match_procedure_in_type): Mark matched binding as non-generic.
	* interface.c (gfc_compare_interfaces): Made public.
	(gfc_compare_actual_formal): Ditto.
	(check_interface_1), (compare_parameter): Use new public names.
	(gfc_procedure_use), (gfc_search_interface): Ditto.
	* match.c (match_typebound_call): Set base-symbol referenced.
	* module.c (binding_generic): New global array.
	(current_f2k_derived): New global.
	(mio_typebound_proc): Handle IO of GENERIC bindings.
	(mio_f2k_derived): Record current f2k-namespace in current_f2k_derived.
	* parse.c (decode_statement): Handle GENERIC statement.
	(gfc_ascii_statement): Ditto.
	(typebound_default_access), (set_typebound_default_access): Removed.
	(gfc_typebound_default_access): New global.
	(parse_derived_contains): New default-access implementation and handle
	GENERIC statements encountered.
	* primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
	structure and removed check for SUBROUTINE/FUNCTION from here.
	* resolve.c (extract_compcall_passed_object): New method.
	(update_compcall_arglist): Use it.
	(resolve_typebound_static): Adapted to new gfc_typebound_proc structure.
	(resolve_typebound_generic_call): New method.
	(resolve_typebound_call): Check target is a SUBROUTINE and handle calls
	to GENERIC bindings.
	(resolve_compcall): Ditto (check for target being FUNCTION).
	(check_typebound_override): Handle GENERIC bindings.
	(check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods.
	(resolve_typebound_procedure): Handle GENERIC bindings and set new
	attributes subroutine, function and overridden in gfc_typebound_proc.
	(resolve_fl_derived): Ensure extended type is resolved before the
	extending one is.
	* st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
	* symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.

2008-08-31  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/typebound_generic_1.f03: New test.
	* gfortran.dg/typebound_generic_2.f03: New test.
	* gfortran.dg/typebound_generic_3.f03: New test.

From-SVN: r139822
This commit is contained in:
Daniel Kraft 2008-08-31 12:00:30 +02:00 • committed by Daniel Kraft
parent f40751dd34
commit e157f73660
16 changed files with 948 additions and 151 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
gcc/fortran/ChangeLog
View file

@ -1,3 +1,51 @@
2008-08-31 Daniel Kraft <d@domob.eu>
* gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
(struct gfc_tbp_generic): New type.
(struct gfc_typebound_proc): Removed `target' and added union with
`specific' and `generic' members; new members `overridden',
`subroutine', `function' and `is_generic'.
(struct gfc_expr): New members `derived' and `name' in compcall union
member and changed type of `tbp' to gfc_typebound_proc.
(gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
* match.h (gfc_typebound_default_access): New global.
(gfc_match_generic): New method.
* decl.c (gfc_match_generic): New method.
(match_binding_attributes): New argument `generic' and handle it.
(match_procedure_in_type): Mark matched binding as non-generic.
* interface.c (gfc_compare_interfaces): Made public.
(gfc_compare_actual_formal): Ditto.
(check_interface_1), (compare_parameter): Use new public names.
(gfc_procedure_use), (gfc_search_interface): Ditto.
* match.c (match_typebound_call): Set base-symbol referenced.
* module.c (binding_generic): New global array.
(current_f2k_derived): New global.
(mio_typebound_proc): Handle IO of GENERIC bindings.
(mio_f2k_derived): Record current f2k-namespace in current_f2k_derived.
* parse.c (decode_statement): Handle GENERIC statement.
(gfc_ascii_statement): Ditto.
(typebound_default_access), (set_typebound_default_access): Removed.
(gfc_typebound_default_access): New global.
(parse_derived_contains): New default-access implementation and handle
GENERIC statements encountered.
* primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
structure and removed check for SUBROUTINE/FUNCTION from here.
* resolve.c (extract_compcall_passed_object): New method.
(update_compcall_arglist): Use it.
(resolve_typebound_static): Adapted to new gfc_typebound_proc structure.
(resolve_typebound_generic_call): New method.
(resolve_typebound_call): Check target is a SUBROUTINE and handle calls
to GENERIC bindings.
(resolve_compcall): Ditto (check for target being FUNCTION).
(check_typebound_override): Handle GENERIC bindings.
(check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods.
(resolve_typebound_procedure): Handle GENERIC bindings and set new
attributes subroutine, function and overridden in gfc_typebound_proc.
(resolve_fl_derived): Ensure extended type is resolved before the
extending one is.
* st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
* symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.
2008-08-29 Jan Hubicka <jh@suse.cz>
* parse.c (parse_interface): Silence uninitialized var warning.

307
gcc/fortran/decl.c
View file

@ -6721,7 +6721,7 @@ cleanup:
/* Match binding attributes. */
static match
match_binding_attributes (gfc_typebound_proc* ba)
match_binding_attributes (gfc_typebound_proc* ba, bool generic)
{
bool found_passing = false;
match m;
@ -6736,82 +6736,13 @@ match_binding_attributes (gfc_typebound_proc* ba)
/* If we find a comma, we believe there are binding attributes. */
if (gfc_match_char (',') == MATCH_NO)
return MATCH_NO;
{
ba->access = gfc_typebound_default_access;
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");
@ -6844,12 +6775,96 @@ match_binding_attributes (gfc_typebound_proc* ba)
continue;
}
/* If inside GENERIC, the following is not allowed. */
if (!generic)
{
/* 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;
}
}
/* Nothing matching found. */
gfc_error ("Expected binding attribute at %C");
if (generic)
gfc_error ("Expected access-specifier at %C");
else
gfc_error ("Expected binding attribute at %C");
goto error;
}
while (gfc_match_char (',') == MATCH_YES);
if (ba->access == ACCESS_UNKNOWN)
ba->access = gfc_typebound_default_access;
return MATCH_YES;
error:
@ -6890,9 +6905,10 @@ match_procedure_in_type (void)
/* Construct the data structure. */
tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus;
tb->is_generic = 0;
/* Match binding attributes. */
m = match_binding_attributes (tb);
m = match_binding_attributes (tb, false);
if (m == MATCH_ERROR)
return m;
seen_attrs = (m == MATCH_YES);
@ -6962,9 +6978,10 @@ match_procedure_in_type (void)
gcc_assert (ns);
/* See if we already have a binding with this name in the symtree which would
be an error. */
be an error. If a GENERIC already targetted this binding, it may be
already there but then typebound is still NULL. */
stree = gfc_find_symtree (ns->sym_root, name);
if (stree)
if (stree && stree->typebound)
{
gfc_error ("There's already a procedure with binding name '%s' for the"
" derived type '%s' at %C", name, block->name);
@ -6974,14 +6991,146 @@ match_procedure_in_type (void)
/* 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))
if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific))
return MATCH_ERROR;
gfc_set_sym_referenced (tb->u.specific->n.sym);
stree->typebound = tb;
return MATCH_YES;
}
/* Match a GENERIC procedure binding inside a derived type. */
match
gfc_match_generic (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol* block;
gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
gfc_typebound_proc* tb;
gfc_symtree* st;
gfc_namespace* ns;
match m;
/* Check current state. */
if (gfc_current_state () == COMP_DERIVED)
{
gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
return MATCH_ERROR;
}
if (gfc_current_state () != COMP_DERIVED_CONTAINS)
return MATCH_NO;
block = gfc_state_stack->previous->sym;
ns = block->f2k_derived;
gcc_assert (block && ns);
/* See if we get an access-specifier. */
m = match_binding_attributes (&tbattr, true);
if (m == MATCH_ERROR)
goto error;
/* Now the colons, those are required. */
if (gfc_match (" ::") != MATCH_YES)
{
gfc_error ("Expected '::' at %C");
goto error;
}
/* The binding name and =>. */
m = gfc_match (" %n =>", name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
{
gfc_error ("Expected generic name at %C");
goto error;
}
/* If there's already something with this name, check that it is another
GENERIC and then extend that rather than build a new node. */
st = gfc_find_symtree (ns->sym_root, name);
if (st)
{
if (!st->typebound || !st->typebound->is_generic)
{
gfc_error ("There's already a non-generic procedure with binding name"
" '%s' for the derived type '%s' at %C",
name, block->name);
goto error;
}
tb = st->typebound;
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
" defined binding '%s'", name);
goto error;
}
}
else
{
if (gfc_get_sym_tree (name, ns, &st))
return MATCH_ERROR;
st->typebound = tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
tb->u.generic = NULL;
}
/* Now, match all following names as specific targets. */
do
{
gfc_symtree* target_st;
gfc_tbp_generic* target;
m = gfc_match_name (name);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
{
gfc_error ("Expected specific binding name at %C");
goto error;
}
if (gfc_get_sym_tree (name, ns, &target_st))
goto error;
/* See if this is a duplicate specification. */
for (target = tb->u.generic; target; target = target->next)
if (target_st == target->specific_st)
{
gfc_error ("'%s' already defined as specific binding for the"
" generic '%s' at %C", name, st->n.sym->name);
goto error;
}
gfc_set_sym_referenced (target_st->n.sym);
target = gfc_get_tbp_generic ();
target->specific_st = target_st;
target->specific = NULL;
target->next = tb->u.generic;
tb->u.generic = target;
}
while (gfc_match (" ,") == MATCH_YES);
/* Here should be the end. */
if (gfc_match_eos () != MATCH_YES)
{
gfc_error ("Junk after GENERIC binding at %C");
goto error;
}
return MATCH_YES;
error:
return MATCH_ERROR;
}
/* Match a FINAL declaration inside a derived type. */
match

44
gcc/fortran/gfortran.h
View file

@ -229,7 +229,7 @@ typedef enum
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
ST_OMP_TASKWAIT, ST_PROCEDURE,
ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC,
ST_GET_FCN_CHARACTERISTICS, ST_NONE
}
gfc_statement;
@ -992,15 +992,40 @@ typedef struct
gfc_user_op;
/* Data needed for type-bound procedures. */
typedef struct
/* A list of specific bindings that are associated with a generic spec. */
typedef struct gfc_tbp_generic
{
struct gfc_symtree* target;
locus where; /* Where the PROCEDURE definition was. */
/* The parser sets specific_st, upon resolution we look for the corresponding
gfc_typebound_proc and set specific for further use. */
struct gfc_symtree* specific_st;
struct gfc_typebound_proc* specific;
struct gfc_tbp_generic* next;
}
gfc_tbp_generic;
#define gfc_get_tbp_generic() XCNEW (gfc_tbp_generic)
/* Data needed for type-bound procedures. */
typedef struct gfc_typebound_proc
{
locus where; /* Where the PROCEDURE/GENERIC definition was. */
union
{
struct gfc_symtree* specific;
gfc_tbp_generic* generic;
}
u;
gfc_access access;
char* pass_arg; /* Argument-name for PASS. NULL if not specified. */
/* The overridden type-bound proc (or GENERIC with this name in the
parent-type) or NULL if non. */
struct gfc_typebound_proc* overridden;
/* 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 1 here, the second 2, and so on. */
@ -1008,6 +1033,8 @@ typedef struct
unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
unsigned non_overridable:1;
unsigned is_generic:1;
unsigned function:1, subroutine:1;
}
gfc_typebound_proc;
@ -1565,7 +1592,9 @@ typedef struct gfc_expr
struct
{
gfc_actual_arglist* actual;
gfc_symtree* tbp;
gfc_typebound_proc* tbp;
gfc_symbol* derived;
const char* name;
}
compcall;
@ -2472,6 +2501,7 @@ int gfc_is_compile_time_shape (gfc_array_spec *);
void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *);
int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
void gfc_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
@ -2483,6 +2513,8 @@ gfc_try gfc_add_interface (gfc_symbol *);
gfc_interface *gfc_current_interface_head (void);
void gfc_set_current_interface_head (gfc_interface *);
gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*,
int, int, locus*);
/* io.c */
extern gfc_st_label format_asterisk;

21
gcc/fortran/interface.c
View file

@ -479,7 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
}
static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
/* Given two symbols that are formal arguments, compare their types
@ -954,8 +953,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
We return nonzero if there exists an actual argument list that
would be ambiguous between the two interfaces, zero otherwise. */
static int
compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
int
gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
{
gfc_formal_arglist *f1, *f2;
@ -1173,7 +1172,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
if (compare_interfaces (p->sym, q->sym, generic_flag))
if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
{
if (referenced)
{
@ -1460,7 +1459,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
goto proc_fail;
}
else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
goto proc_fail;
return 1;
@ -1819,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
errors when things don't match instead of just returning the status
code. */
static int
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental, locus *where)
int
gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental, locus *where)
{
gfc_actual_arglist **new_arg, *a, *actual, temp;
gfc_formal_arglist *f;
@ -2449,8 +2448,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
return;
}
if (!compare_actual_formal (ap, sym->formal, 0,
sym->attr.elemental, where))
if (!gfc_compare_actual_formal (ap, sym->formal, 0,
sym->attr.elemental, where))
return;
check_intents (sym->formal, *ap);
@ -2479,7 +2478,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
r = !intr->sym->attr.elemental;
if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
{
check_intents (intr->sym->formal, *ap);
if (gfc_option.warn_aliasing)

1
gcc/fortran/match.c
View file

@ -2525,6 +2525,7 @@ match_typebound_call (gfc_symtree* varst)
base->expr_type = EXPR_VARIABLE;
base->symtree = varst;
base->where = gfc_current_locus;
gfc_set_sym_referenced (varst->n.sym);
m = gfc_match_varspec (base, 0, true);
if (m == MATCH_NO)

4
gcc/fortran/match.h
View file

@ -36,6 +36,9 @@ extern gfc_st_label *gfc_statement_label;
extern int gfc_matching_procptr_assignment;
extern bool gfc_matching_prefix;
/* Default access specifier while matching procedure bindings. */
extern gfc_access gfc_typebound_default_access;
/****************** All gfc_match* routines *****************/
/* match.c. */
@ -141,6 +144,7 @@ match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void);
match gfc_match_formal_arglist (gfc_symbol *, int, int);
match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void);
match gfc_match_entry (void);
match gfc_match_subroutine (void);

44
gcc/fortran/module.c
View file

@ -1698,6 +1698,12 @@ static const mstring binding_overriding[] =
minit ("NON_OVERRIDABLE", 1),
minit (NULL, -1)
};
static const mstring binding_generic[] =
{
minit ("SPECIFIC", 0),
minit ("GENERIC", 1),
minit (NULL, -1)
};
/* Specialization of mio_name. */
@ -3189,6 +3195,8 @@ mio_namespace_ref (gfc_namespace **nsp)
/* Save/restore the f2k_derived namespace of a derived-type symbol. */
static gfc_namespace* current_f2k_derived;
static void
mio_typebound_proc (gfc_typebound_proc** proc)
{
@ -3202,13 +3210,13 @@ mio_typebound_proc (gfc_typebound_proc** proc)
gcc_assert (*proc);
mio_lparen ();
mio_symtree_ref (&(*proc)->target);
(*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
(*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
(*proc)->non_overridable = mio_name ((*proc)->non_overridable,
binding_overriding);
(*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
if (iomode == IO_INPUT)
(*proc)->pass_arg = NULL;
@ -3217,6 +3225,38 @@ mio_typebound_proc (gfc_typebound_proc** proc)
mio_integer (&flag);
(*proc)->pass_arg_num = (unsigned) flag;
if ((*proc)->is_generic)
{
gfc_tbp_generic* g;
mio_lparen ();
if (iomode == IO_OUTPUT)
for (g = (*proc)->u.generic; g; g = g->next)
mio_allocated_string (g->specific_st->name);
else
{
(*proc)->u.generic = NULL;
while (peek_atom () != ATOM_RPAREN)
{
g = gfc_get_tbp_generic ();
g->specific = NULL;
require_atom (ATOM_STRING);
gfc_get_sym_tree (atom_string, current_f2k_derived,
&g->specific_st);
gfc_free (atom_string);
g->next = (*proc)->u.generic;
(*proc)->u.generic = g;
}
}
mio_rparen ();
}
else
mio_symtree_ref (&(*proc)->u.specific);
mio_rparen ();
}
@ -3260,6 +3300,8 @@ mio_finalizer (gfc_finalizer **f)
static void
mio_f2k_derived (gfc_namespace *f2k)
{
current_f2k_derived = f2k;
/* Handle the list of finalizer procedures. */
mio_lparen ();
if (iomode == IO_OUTPUT)

37
gcc/fortran/parse.c
View file

@ -372,6 +372,7 @@ decode_statement (void)
break;
case 'g':
match ("generic", gfc_match_generic, ST_GENERIC);
match ("go to", gfc_match_goto, ST_GOTO);
break;
@ -1195,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_FUNCTION:
p = "FUNCTION";
break;
case ST_GENERIC:
p = "GENERIC";
break;
case ST_GOTO:
p = "GOTO";
break;
@ -1691,21 +1695,10 @@ 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. */
gfc_access gfc_typebound_default_access;
static bool
parse_derived_contains (void)
{
@ -1730,6 +1723,8 @@ parse_derived_contains (void)
accept_statement (ST_CONTAINS);
push_state (&s, COMP_DERIVED_CONTAINS, NULL);
gfc_typebound_default_access = ACCESS_PUBLIC;
to_finish = false;
while (!to_finish)
{
@ -1755,6 +1750,15 @@ parse_derived_contains (void)
seen_comps = true;
break;
case ST_GENERIC:
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding"
" at %C") == FAILURE)
error_flag = true;
accept_statement (ST_GENERIC);
seen_comps = true;
break;
case ST_FINAL:
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: FINAL procedure declaration"
@ -1801,6 +1805,7 @@ parse_derived_contains (void)
}
accept_statement (ST_PRIVATE);
gfc_typebound_default_access = ACCESS_PRIVATE;
seen_private = true;
break;
@ -1823,12 +1828,6 @@ parse_derived_contains (void)
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;
}

28
gcc/fortran/primary.c
View file

@ -1709,7 +1709,6 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
gfc_ref *substring, *tail;
gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym;
gfc_symtree *tbp;
match m;
bool unknown;
@ -1754,6 +1753,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
for (;;)
{
gfc_try t;
gfc_symtree *tbp;
m = gfc_match_name (name);
if (m == MATCH_NO)
@ -1772,13 +1772,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
gcc_assert (!tail || !tail->next);
gcc_assert (primary->expr_type == EXPR_VARIABLE);
tbp_sym = tbp->typebound->target->n.sym;
if (tbp->typebound->is_generic)
tbp_sym = NULL;
else
tbp_sym = tbp->typebound->u.specific->n.sym;
primary->expr_type = EXPR_COMPCALL;
primary->value.compcall.tbp = tbp;
primary->ts = tbp_sym->ts;
primary->value.compcall.tbp = tbp->typebound;
primary->value.compcall.derived = sym;
primary->value.compcall.name = tbp->name;
gcc_assert (primary->symtree->n.sym->attr.referenced);
if (tbp_sym)
primary->ts = tbp_sym->ts;
m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
m = gfc_match_actual_arglist (tbp->typebound->subroutine,
&primary->value.compcall.actual);
if (m == MATCH_ERROR)
return MATCH_ERROR;
@ -1793,16 +1800,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
}
}
if (sub_flag && !tbp_sym->attr.subroutine)
{
gfc_error ("'%s' at %C should be a SUBROUTINE", name);
return MATCH_ERROR;
}
if (!sub_flag && !tbp_sym->attr.function)
{
gfc_error ("'%s' at %C should be a FUNCTION", name);
return MATCH_ERROR;
}
gfc_set_sym_referenced (tbp->n.sym);
break;
}

329
gcc/fortran/resolve.c
View file

@ -4306,6 +4306,27 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
}
/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
static gfc_expr*
extract_compcall_passed_object (gfc_expr* e)
{
gfc_expr* po;
gcc_assert (e->expr_type == EXPR_COMPCALL);
po = gfc_get_expr ();
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
if (gfc_resolve_expr (po) == FAILURE)
return NULL;
return po;
}
/* Update the arglist of an EXPR_COMPCALL expression to include the
passed-object. */
@ -4315,15 +4336,12 @@ update_compcall_arglist (gfc_expr* e)
gfc_expr* po;
gfc_typebound_proc* tbp;
tbp = e->value.compcall.tbp->typebound;
tbp = e->value.compcall.tbp;
po = gfc_get_expr ();
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
if (gfc_resolve_expr (po) == FAILURE)
po = extract_compcall_passed_object (e);
if (!po)
return FAILURE;
if (po->rank > 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
@ -4353,13 +4371,14 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
gfc_actual_arglist** actual)
{
gcc_assert (e->expr_type == EXPR_COMPCALL);
gcc_assert (!e->value.compcall.tbp->is_generic);
/* Update the actual arglist for PASS. */
if (update_compcall_arglist (e) == FAILURE)
return FAILURE;
*actual = e->value.compcall.actual;
*target = e->value.compcall.tbp->typebound->target;
*target = e->value.compcall.tbp->u.specific;
gfc_free_ref_list (e->ref);
e->ref = NULL;
@ -4369,6 +4388,74 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
}
/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
which of the specific bindings (if any) matches the arglist and transform
the expression into a call of that binding. */
static gfc_try
resolve_typebound_generic_call (gfc_expr* e)
{
gfc_typebound_proc* genproc;
const char* genname;
gcc_assert (e->expr_type == EXPR_COMPCALL);
genname = e->value.compcall.name;
genproc = e->value.compcall.tbp;
if (!genproc->is_generic)
return SUCCESS;
/* Try the bindings on this type and in the inheritance hierarchy. */
for (; genproc; genproc = genproc->overridden)
{
gfc_tbp_generic* g;
gcc_assert (genproc->is_generic);
for (g = genproc->u.generic; g; g = g->next)
{
gfc_symbol* target;
gfc_actual_arglist* args;
bool matches;
gcc_assert (g->specific);
target = g->specific->u.specific->n.sym;
/* Get the right arglist by handling PASS/NOPASS. */
args = gfc_copy_actual_arglist (e->value.compcall.actual);
if (!g->specific->nopass)
{
gfc_expr* po;
po = extract_compcall_passed_object (e);
if (!po)
return FAILURE;
args = update_arglist_pass (args, po, g->specific->pass_arg_num);
}
/* Check if this arglist matches the formal. */
matches = gfc_compare_actual_formal (&args, target->formal, 1,
target->attr.elemental, NULL);
/* Clean up and break out of the loop if we've found it. */
gfc_free_actual_arglist (args);
if (matches)
{
e->value.compcall.tbp = g->specific;
goto success;
}
}
}
/* Nothing matching found! */
gfc_error ("Found no matching specific binding for the call to the GENERIC"
" '%s' at %L", genname, &e->where);
return FAILURE;
success:
return SUCCESS;
}
/* Resolve a call to a type-bound subroutine. */
static gfc_try
@ -4377,6 +4464,17 @@ resolve_typebound_call (gfc_code* c)
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* Check that's really a SUBROUTINE. */
if (!c->expr->value.compcall.tbp->subroutine)
{
gfc_error ("'%s' at %L should be a SUBROUTINE",
c->expr->value.compcall.name, &c->loc);
return FAILURE;
}
if (resolve_typebound_generic_call (c->expr) == FAILURE)
return FAILURE;
/* Transform into an ordinary EXEC_CALL for now. */
if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
@ -4402,13 +4500,27 @@ resolve_compcall (gfc_expr* e)
gfc_actual_arglist* newactual;
gfc_symtree* target;
/* For now, we simply transform it into a EXPR_FUNCTION call with the same
/* Check that's really a FUNCTION. */
if (!e->value.compcall.tbp->function)
{
gfc_error ("'%s' at %L should be a FUNCTION",
e->value.compcall.name, &e->where);
return FAILURE;
}
if (resolve_typebound_generic_call (e) == FAILURE)
return FAILURE;
/* For now, we simply transform it into an EXPR_FUNCTION call with the same
arglist to the TBP's binding target. */
if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
return FAILURE;
e->value.function.actual = newactual;
e->value.function.name = e->value.compcall.name;
e->value.function.isym = NULL;
e->value.function.esym = NULL;
e->symtree = target;
e->expr_type = EXPR_FUNCTION;
@ -7771,9 +7883,20 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
gfc_formal_arglist* proc_formal;
gfc_formal_arglist* old_formal;
/* This procedure should only be called for non-GENERIC proc. */
gcc_assert (!proc->typebound->is_generic);
/* If the overwritten procedure is GENERIC, this is an error. */
if (old->typebound->is_generic)
{
gfc_error ("Can't overwrite GENERIC '%s' at %L",
old->name, &proc->typebound->where);
return FAILURE;
}
where = proc->typebound->where;
proc_target = proc->typebound->target->n.sym;
old_target = old->typebound->target->n.sym;
proc_target = proc->typebound->u.specific->n.sym;
old_target = old->typebound->u.specific->n.sym;
/* Check that overridden binding is not NON_OVERRIDABLE. */
if (old->typebound->non_overridable)
@ -7933,6 +8056,161 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
}
/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
static gfc_try
check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
const char* generic_name, locus where)
{
gfc_symbol* sym1;
gfc_symbol* sym2;
gcc_assert (t1->specific && t2->specific);
gcc_assert (!t1->specific->is_generic);
gcc_assert (!t2->specific->is_generic);
sym1 = t1->specific->u.specific->n.sym;
sym2 = t2->specific->u.specific->n.sym;
/* Both must be SUBROUTINEs or both must be FUNCTIONs. */
if (sym1->attr.subroutine != sym2->attr.subroutine
|| sym1->attr.function != sym2->attr.function)
{
gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
" GENERIC '%s' at %L",
sym1->name, sym2->name, generic_name, &where);
return FAILURE;
}
/* Compare the interfaces. */
if (gfc_compare_interfaces (sym1, sym2, 1))
{
gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
sym1->name, sym2->name, generic_name, &where);
return FAILURE;
}
return SUCCESS;
}
/* Resolve a GENERIC procedure binding for a derived type. */
static gfc_try
resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
{
gfc_tbp_generic* target;
gfc_symtree* first_target;
gfc_symbol* super_type;
gfc_symtree* inherited;
locus where;
gcc_assert (st->typebound);
gcc_assert (st->typebound->is_generic);
where = st->typebound->where;
super_type = gfc_get_derived_super_type (derived);
/* Find the overridden binding if any. */
st->typebound->overridden = NULL;
if (super_type)
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
if (overridden && overridden->typebound)
st->typebound->overridden = overridden->typebound;
}
/* Try to find the specific bindings for the symtrees in our target-list. */
gcc_assert (st->typebound->u.generic);
for (target = st->typebound->u.generic; target; target = target->next)
if (!target->specific)
{
gfc_typebound_proc* overridden_tbp;
gfc_tbp_generic* g;
const char* target_name;
target_name = target->specific_st->name;
/* Defined for this type directly. */
if (target->specific_st->typebound)
{
target->specific = target->specific_st->typebound;
goto specific_found;
}
/* Look for an inherited specific binding. */
if (super_type)
{
inherited = gfc_find_typebound_proc (super_type, NULL,
target_name, true);
if (inherited)
{
gcc_assert (inherited->typebound);
target->specific = inherited->typebound;
goto specific_found;
}
}
gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
" at %L", target_name, st->name, &where);
return FAILURE;
/* Once we've found the specific binding, check it is not ambiguous with
other specifics already found or inherited for the same GENERIC. */
specific_found:
gcc_assert (target->specific);
/* This must really be a specific binding! */
if (target->specific->is_generic)
{
gfc_error ("GENERIC '%s' at %L must target a specific binding,"
" '%s' is GENERIC, too", st->name, &where, target_name);
return FAILURE;
}
/* Check those already resolved on this type directly. */
for (g = st->typebound->u.generic; g; g = g->next)
if (g != target && g->specific
&& check_generic_tbp_ambiguity (target, g, st->name, where)
== FAILURE)
return FAILURE;
/* Check for ambiguity with inherited specific targets. */
for (overridden_tbp = st->typebound->overridden; overridden_tbp;
overridden_tbp = overridden_tbp->overridden)
if (overridden_tbp->is_generic)
{
for (g = overridden_tbp->u.generic; g; g = g->next)
{
gcc_assert (g->specific);
if (check_generic_tbp_ambiguity (target, g,
st->name, where) == FAILURE)
return FAILURE;
}
}
}
/* If we attempt to "overwrite" a specific binding, this is an error. */
if (st->typebound->overridden && !st->typebound->overridden->is_generic)
{
gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
" the same name", st->name, &where);
return FAILURE;
}
/* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
all must have the same attributes here. */
first_target = st->typebound->u.generic->specific->u.specific;
st->typebound->subroutine = first_target->n.sym->attr.subroutine;
st->typebound->function = first_target->n.sym->attr.function;
return SUCCESS;
}
/* Resolve the type-bound procedures for a derived type. */
static gfc_symbol* resolve_bindings_derived;
@ -7951,9 +8229,19 @@ resolve_typebound_procedure (gfc_symtree* stree)
if (!stree->typebound)
return;
/* If this is a GENERIC binding, use that routine. */
if (stree->typebound->is_generic)
{
if (resolve_typebound_generic (resolve_bindings_derived, stree)
== FAILURE)
goto error;
return;
}
/* Get the target-procedure to check it. */
gcc_assert (stree->typebound->target);
proc = stree->typebound->target->n.sym;
gcc_assert (!stree->typebound->is_generic);
gcc_assert (stree->typebound->u.specific);
proc = stree->typebound->u.specific->n.sym;
where = stree->typebound->where;
/* Default access should already be resolved from the parser. */
@ -7970,14 +8258,17 @@ resolve_typebound_procedure (gfc_symtree* stree)
" an explicit interface at %L", proc->name, &where);
goto error;
}
stree->typebound->subroutine = proc->attr.subroutine;
stree->typebound->function = proc->attr.function;
/* 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 PASS, resolve and check arguments if not already resolved / loaded
from a .mod file. */
if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
{
if (stree->typebound->pass_arg)
{
@ -8039,12 +8330,16 @@ resolve_typebound_procedure (gfc_symtree* stree)
/* If we are extending some type, check that we don't override a procedure
flagged NON_OVERRIDABLE. */
stree->typebound->overridden = NULL;
if (super_type)
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_proc (super_type, NULL,
stree->name, true);
if (overridden && overridden->typebound)
stree->typebound->overridden = overridden->typebound;
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
goto error;
}
@ -8121,6 +8416,10 @@ resolve_fl_derived (gfc_symbol *sym)
super_type = gfc_get_derived_super_type (sym);
/* Ensure the extended type gets resolved before we do. */
if (super_type && resolve_fl_derived (super_type) == FAILURE)
return FAILURE;
for (c = sym->components; c != NULL; c = c->next)
{
/* If this type is an extension, see if this component has the same name

1
gcc/fortran/st.c
View file

@ -109,7 +109,6 @@ gfc_free_statement (gfc_code *p)
break;
case EXEC_COMPCALL:
gfc_free_expr (p->expr);
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);

5
gcc/fortran/symbol.c
View file

@ -4279,11 +4279,8 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
/* 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)
if (res && res->typebound)
{
if (!res->typebound)
return NULL;
/* We found one. */
if (t)
*t = SUCCESS;

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2008-08-31 Daniel Kraft <d@domob.eu>
* gfortran.dg/typebound_generic_1.f03: New test.
* gfortran.dg/typebound_generic_2.f03: New test.
* gfortran.dg/typebound_generic_3.f03: New test.
2008-08-30 Andrew Pinski <andrew_pinski@playstation.sony.com>
PR middle-end/36444

95
gcc/testsuite/gfortran.dg/typebound_generic_1.f03 Normal file
View file

@ -0,0 +1,95 @@
! { dg-do compile }
! Type-bound procedures
! Compiling and errors with GENERIC binding declarations.
! Bindings with NOPASS.
MODULE m
IMPLICIT NONE
TYPE somet
CONTAINS
PROCEDURE, NOPASS :: p1 => intf1
PROCEDURE, NOPASS :: p1a => intf1a
PROCEDURE, NOPASS :: p2 => intf2
PROCEDURE, NOPASS :: p3 => intf3
PROCEDURE, NOPASS :: subr
GENERIC :: gen1 => p1a ! { dg-error "are ambiguous" }
GENERIC, PUBLIC :: gen1 => p1, p2
GENERIC :: gen1 => p3 ! Implicitelly PUBLIC.
GENERIC, PRIVATE :: gen2 => p1
GENERIC :: gen2 => p2 ! { dg-error "same access" }
GENERIC :: gen1 => p1 ! { dg-error "already defined as specific binding" }
GENERIC, PASS :: gen3 => p1 ! { dg-error "Expected access-specifier" }
GENERIC :: p1 => p1 ! { dg-error "already a non-generic procedure" }
PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "already a procedure" }
GENERIC :: gen3 => ! { dg-error "specific binding" }
GENERIC :: gen4 => p1 x ! { dg-error "Junk after" }
GENERIC :: gen4 => p_notthere ! { dg-error "Undefined specific binding" }
GENERIC :: gen5 => gen1 ! { dg-error "must target a specific binding" }
GENERIC :: gensubr => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
GENERIC :: gensubr => subr
END TYPE somet
TYPE supert
CONTAINS
PROCEDURE, NOPASS :: p1 => intf1
PROCEDURE, NOPASS :: p1a => intf1a
PROCEDURE, NOPASS :: p2 => intf2
PROCEDURE, NOPASS :: p3 => intf3
PROCEDURE, NOPASS :: sub1 => subr
GENERIC :: gen1 => p1, p2
GENERIC :: gen1 => p3
GENERIC :: gen2 => p1
GENERIC :: gensub => sub1
END TYPE supert
TYPE, EXTENDS(supert) :: t
CONTAINS
GENERIC :: gen2 => p1a ! { dg-error "are ambiguous" }
GENERIC :: gen2 => p3
GENERIC :: p1 => p2 ! { dg-error "can't overwrite specific" }
GENERIC :: gensub => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "Can't overwrite GENERIC" }
END TYPE t
CONTAINS
INTEGER FUNCTION intf1 (a, b)
IMPLICIT NONE
INTEGER :: a, b
intf1 = 42
END FUNCTION intf1
INTEGER FUNCTION intf1a (a, b)
IMPLICIT NONE
INTEGER :: a, b
intf1a = 42
END FUNCTION intf1a
INTEGER FUNCTION intf2 (a, b)
IMPLICIT NONE
REAL :: a, b
intf2 = 42.0
END FUNCTION intf2
LOGICAL FUNCTION intf3 ()
IMPLICIT NONE
intf3 = .TRUE.
END FUNCTION intf3
SUBROUTINE subr (x)
IMPLICIT NONE
INTEGER :: x
END SUBROUTINE subr
END MODULE m
! { dg-final { cleanup-modules "m" } }

64
gcc/testsuite/gfortran.dg/typebound_generic_2.f03 Normal file
View file

@ -0,0 +1,64 @@
! { dg-do compile }
! Type-bound procedures
! Check for errors with calls to GENERIC bindings and their module IO.
! Calls with NOPASS.
MODULE m
IMPLICIT NONE
TYPE supert
CONTAINS
PROCEDURE, NOPASS :: func_int
PROCEDURE, NOPASS :: sub_int
GENERIC :: func => func_int
GENERIC :: sub => sub_int
END TYPE supert
TYPE, EXTENDS(supert) :: t
CONTAINS
PROCEDURE, NOPASS :: func_real
GENERIC :: func => func_real
END TYPE t
CONTAINS
INTEGER FUNCTION func_int (x)
IMPLICIT NONE
INTEGER :: x
func_int = x
END FUNCTION func_int
INTEGER FUNCTION func_real (x)
IMPLICIT NONE
REAL :: x
func_real = INT(x * 4.2)
END FUNCTION func_real
SUBROUTINE sub_int (x)
IMPLICIT NONE
INTEGER :: x
END SUBROUTINE sub_int
END MODULE m
PROGRAM main
USE m
IMPLICIT NONE
TYPE(t) :: myobj
! These are ok.
CALL myobj%sub (1)
WRITE (*,*) myobj%func (1)
WRITE (*,*) myobj%func (2.5)
! These are not.
CALL myobj%sub (2.5) ! { dg-error "no matching specific binding" }
WRITE (*,*) myobj%func ("hello") ! { dg-error "no matching specific binding" }
CALL myobj%func (2.5) ! { dg-error "SUBROUTINE" }
WRITE (*,*) myobj%sub (1) ! { dg-error "FUNCTION" }
END PROGRAM main
! { dg-final { cleanup-modules "m" } }

65
gcc/testsuite/gfortran.dg/typebound_generic_3.f03 Normal file
View file

@ -0,0 +1,65 @@
! { dg-do run }
! FIXME: Remove -w once switched to polymorphic passed-object dummy arguments.
! { dg-options "-w" }
! Type-bound procedures
! Check calls with GENERIC bindings.
MODULE m
IMPLICIT NONE
TYPE t
CONTAINS
PROCEDURE, NOPASS :: plain_int
PROCEDURE, NOPASS :: plain_real
PROCEDURE, PASS(me) :: passed_intint
PROCEDURE, PASS(me) :: passed_realreal
GENERIC :: gensub => plain_int, plain_real, passed_intint, passed_realreal
END TYPE t
CONTAINS
SUBROUTINE plain_int (x)
IMPLICIT NONE
INTEGER :: x
WRITE (*,*) "Plain Integer"
END SUBROUTINE plain_int
SUBROUTINE plain_real (x)
IMPLICIT NONE
REAL :: x
WRITE (*,*) "Plain Real"
END SUBROUTINE plain_real
SUBROUTINE passed_intint (me, x, y)
IMPLICIT NONE
TYPE(t) :: me
INTEGER :: x, y
WRITE (*,*) "Passed Integer"
END SUBROUTINE passed_intint
SUBROUTINE passed_realreal (x, me, y)
IMPLICIT NONE
REAL :: x, y
TYPE(t) :: me
WRITE (*,*) "Passed Real"
END SUBROUTINE passed_realreal
END MODULE m
PROGRAM main
USE m
IMPLICIT NONE
TYPE(t) :: myobj
CALL myobj%gensub (5)
CALL myobj%gensub (2.5)
CALL myobj%gensub (5, 5)
CALL myobj%gensub (2.5, 2.5)
END PROGRAM main
! { dg-output "Plain Integer(\n|\r\n|\r).*Plain Real(\n|\r\n|\r).*Passed Integer(\n|\r\n|\r).*Passed Real" }
! { dg-final { cleanup-modules "m" } }