Commit e157f736 by Daniel Kraft Committed by Daniel Kraft

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

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
parent f40751dd
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> 2008-08-29 Jan Hubicka <jh@suse.cz>
* parse.c (parse_interface): Silence uninitialized var warning. * parse.c (parse_interface): Silence uninitialized var warning.
......
...@@ -6721,7 +6721,7 @@ cleanup: ...@@ -6721,7 +6721,7 @@ cleanup:
/* Match binding attributes. */ /* Match binding attributes. */
static match static match
match_binding_attributes (gfc_typebound_proc* ba) match_binding_attributes (gfc_typebound_proc* ba, bool generic)
{ {
bool found_passing = false; bool found_passing = false;
match m; match m;
...@@ -6736,120 +6736,135 @@ match_binding_attributes (gfc_typebound_proc* ba) ...@@ -6736,120 +6736,135 @@ match_binding_attributes (gfc_typebound_proc* ba)
/* If we find a comma, we believe there are binding attributes. */ /* If we find a comma, we believe there are binding attributes. */
if (gfc_match_char (',') == MATCH_NO) if (gfc_match_char (',') == MATCH_NO)
return MATCH_NO; {
ba->access = gfc_typebound_default_access;
return MATCH_NO;
}
do do
{ {
/* NOPASS flag. */ /* Access specifier. */
m = gfc_match (" nopass");
m = gfc_match (" public");
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
goto error; goto error;
if (m == MATCH_YES) if (m == MATCH_YES)
{ {
if (found_passing) if (ba->access != ACCESS_UNKNOWN)
{ {
gfc_error ("Binding attributes already specify passing, illegal" gfc_error ("Duplicate access-specifier at %C");
" NOPASS at %C");
goto error; goto error;
} }
found_passing = true; ba->access = ACCESS_PUBLIC;
ba->nopass = 1;
continue; continue;
} }
/* NON_OVERRIDABLE flag. */ m = gfc_match (" private");
m = gfc_match (" non_overridable");
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
goto error; goto error;
if (m == MATCH_YES) if (m == MATCH_YES)
{ {
if (ba->non_overridable) if (ba->access != ACCESS_UNKNOWN)
{ {
gfc_error ("Duplicate NON_OVERRIDABLE at %C"); gfc_error ("Duplicate access-specifier at %C");
goto error; goto error;
} }
ba->non_overridable = 1; ba->access = ACCESS_PRIVATE;
continue; continue;
} }
/* DEFERRED flag. */ /* If inside GENERIC, the following is not allowed. */
/* TODO: Handle really once implemented. */ if (!generic)
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) /* NOPASS flag. */
m = gfc_match (" nopass");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{ {
gfc_error ("Binding attributes already specify passing, illegal" if (found_passing)
" PASS at %C"); {
goto error; gfc_error ("Binding attributes already specify passing,"
" illegal NOPASS at %C");
goto error;
}
found_passing = true;
ba->nopass = 1;
continue;
} }
m = gfc_match (" ( %n )", arg); /* NON_OVERRIDABLE flag. */
m = gfc_match (" non_overridable");
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
goto error; goto error;
if (m == MATCH_YES) if (m == MATCH_YES)
ba->pass_arg = xstrdup (arg); {
gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); if (ba->non_overridable)
{
found_passing = true; gfc_error ("Duplicate NON_OVERRIDABLE at %C");
ba->nopass = 0; goto error;
continue; }
}
/* Access specifier. */ ba->non_overridable = 1;
continue;
}
m = gfc_match (" public"); /* DEFERRED flag. */
if (m == MATCH_ERROR) /* TODO: Handle really once implemented. */
goto error; m = gfc_match (" deferred");
if (m == MATCH_YES) if (m == MATCH_ERROR)
{ goto error;
if (ba->access != ACCESS_UNKNOWN) if (m == MATCH_YES)
{ {
gfc_error ("Duplicate access-specifier at %C"); gfc_error ("DEFERRED not yet implemented at %C");
goto error; goto error;
} }
ba->access = ACCESS_PUBLIC; /* PASS possibly including argument. */
continue; m = gfc_match (" pass");
} if (m == MATCH_ERROR)
goto error;
m = gfc_match (" private"); if (m == MATCH_YES)
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
if (ba->access != ACCESS_UNKNOWN)
{ {
gfc_error ("Duplicate access-specifier at %C"); char arg[GFC_MAX_SYMBOL_LEN + 1];
goto error;
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;
} }
ba->access = ACCESS_PRIVATE;
continue;
} }
/* Nothing matching found. */ /* 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; goto error;
} }
while (gfc_match_char (',') == MATCH_YES); while (gfc_match_char (',') == MATCH_YES);
if (ba->access == ACCESS_UNKNOWN)
ba->access = gfc_typebound_default_access;
return MATCH_YES; return MATCH_YES;
error: error:
...@@ -6890,9 +6905,10 @@ match_procedure_in_type (void) ...@@ -6890,9 +6905,10 @@ match_procedure_in_type (void)
/* Construct the data structure. */ /* Construct the data structure. */
tb = gfc_get_typebound_proc (); tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus; tb->where = gfc_current_locus;
tb->is_generic = 0;
/* Match binding attributes. */ /* Match binding attributes. */
m = match_binding_attributes (tb); m = match_binding_attributes (tb, false);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return m; return m;
seen_attrs = (m == MATCH_YES); seen_attrs = (m == MATCH_YES);
...@@ -6962,9 +6978,10 @@ match_procedure_in_type (void) ...@@ -6962,9 +6978,10 @@ match_procedure_in_type (void)
gcc_assert (ns); gcc_assert (ns);
/* See if we already have a binding with this name in the symtree which would /* 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); 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" gfc_error ("There's already a procedure with binding name '%s' for the"
" derived type '%s' at %C", name, block->name); " derived type '%s' at %C", name, block->name);
...@@ -6974,14 +6991,146 @@ match_procedure_in_type (void) ...@@ -6974,14 +6991,146 @@ match_procedure_in_type (void)
/* Insert it and set attributes. */ /* Insert it and set attributes. */
if (gfc_get_sym_tree (name, ns, &stree)) if (gfc_get_sym_tree (name, ns, &stree))
return MATCH_ERROR; 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; return MATCH_ERROR;
gfc_set_sym_referenced (tb->u.specific->n.sym);
stree->typebound = tb; stree->typebound = tb;
return MATCH_YES; 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 a FINAL declaration inside a derived type. */
match match
......
...@@ -229,7 +229,7 @@ typedef enum ...@@ -229,7 +229,7 @@ typedef enum
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS, 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_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_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 ST_GET_FCN_CHARACTERISTICS, ST_NONE
} }
gfc_statement; gfc_statement;
...@@ -992,15 +992,40 @@ typedef struct ...@@ -992,15 +992,40 @@ typedef struct
gfc_user_op; gfc_user_op;
/* A list of specific bindings that are associated with a generic spec. */
typedef struct gfc_tbp_generic
{
/* 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. */ /* Data needed for type-bound procedures. */
typedef struct typedef struct gfc_typebound_proc
{ {
struct gfc_symtree* target; locus where; /* Where the PROCEDURE/GENERIC definition was. */
locus where; /* Where the PROCEDURE definition was. */
union
{
struct gfc_symtree* specific;
gfc_tbp_generic* generic;
}
u;
gfc_access access; gfc_access access;
char* pass_arg; /* Argument-name for PASS. NULL if not specified. */ 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 /* 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 the binding-target procedure to identify it. The first argument has
number 1 here, the second 2, and so on. */ number 1 here, the second 2, and so on. */
...@@ -1008,6 +1033,8 @@ typedef struct ...@@ -1008,6 +1033,8 @@ typedef struct
unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */ unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
unsigned non_overridable:1; unsigned non_overridable:1;
unsigned is_generic:1;
unsigned function:1, subroutine:1;
} }
gfc_typebound_proc; gfc_typebound_proc;
...@@ -1565,7 +1592,9 @@ typedef struct gfc_expr ...@@ -1565,7 +1592,9 @@ typedef struct gfc_expr
struct struct
{ {
gfc_actual_arglist* actual; gfc_actual_arglist* actual;
gfc_symtree* tbp; gfc_typebound_proc* tbp;
gfc_symbol* derived;
const char* name;
} }
compcall; compcall;
...@@ -2472,6 +2501,7 @@ int gfc_is_compile_time_shape (gfc_array_spec *); ...@@ -2472,6 +2501,7 @@ int gfc_is_compile_time_shape (gfc_array_spec *);
void gfc_free_interface (gfc_interface *); void gfc_free_interface (gfc_interface *);
int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *); int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
int gfc_compare_types (gfc_typespec *, gfc_typespec *); 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_check_interfaces (gfc_namespace *);
void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int, gfc_symbol *gfc_search_interface (gfc_interface *, int,
...@@ -2483,6 +2513,8 @@ gfc_try gfc_add_interface (gfc_symbol *); ...@@ -2483,6 +2513,8 @@ gfc_try gfc_add_interface (gfc_symbol *);
gfc_interface *gfc_current_interface_head (void); gfc_interface *gfc_current_interface_head (void);
void gfc_set_current_interface_head (gfc_interface *); void gfc_set_current_interface_head (gfc_interface *);
gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); 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 */ /* io.c */
extern gfc_st_label format_asterisk; extern gfc_st_label format_asterisk;
......
...@@ -479,7 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2) ...@@ -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 *); static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
/* Given two symbols that are formal arguments, compare their types /* Given two symbols that are formal arguments, compare their types
...@@ -954,8 +953,8 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2) ...@@ -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 We return nonzero if there exists an actual argument list that
would be ambiguous between the two interfaces, zero otherwise. */ would be ambiguous between the two interfaces, zero otherwise. */
static int int
compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag) gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
{ {
gfc_formal_arglist *f1, *f2; gfc_formal_arglist *f1, *f2;
...@@ -1173,7 +1172,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, ...@@ -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) if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue; continue;
if (compare_interfaces (p->sym, q->sym, generic_flag)) if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
{ {
if (referenced) if (referenced)
{ {
...@@ -1460,7 +1459,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, ...@@ -1460,7 +1459,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
if (!compare_intr_interfaces (formal, actual->symtree->n.sym)) if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
goto proc_fail; 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; goto proc_fail;
return 1; return 1;
...@@ -1819,9 +1818,9 @@ has_vector_subscript (gfc_expr *e) ...@@ -1819,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
errors when things don't match instead of just returning the status errors when things don't match instead of just returning the status
code. */ code. */
static int int
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental, locus *where) int ranks_must_agree, int is_elemental, locus *where)
{ {
gfc_actual_arglist **new_arg, *a, *actual, temp; gfc_actual_arglist **new_arg, *a, *actual, temp;
gfc_formal_arglist *f; gfc_formal_arglist *f;
...@@ -2449,8 +2448,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where) ...@@ -2449,8 +2448,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
return; return;
} }
if (!compare_actual_formal (ap, sym->formal, 0, if (!gfc_compare_actual_formal (ap, sym->formal, 0,
sym->attr.elemental, where)) sym->attr.elemental, where))
return; return;
check_intents (sym->formal, *ap); check_intents (sym->formal, *ap);
...@@ -2479,7 +2478,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, ...@@ -2479,7 +2478,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
r = !intr->sym->attr.elemental; 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); check_intents (intr->sym->formal, *ap);
if (gfc_option.warn_aliasing) if (gfc_option.warn_aliasing)
......
...@@ -2525,6 +2525,7 @@ match_typebound_call (gfc_symtree* varst) ...@@ -2525,6 +2525,7 @@ match_typebound_call (gfc_symtree* varst)
base->expr_type = EXPR_VARIABLE; base->expr_type = EXPR_VARIABLE;
base->symtree = varst; base->symtree = varst;
base->where = gfc_current_locus; base->where = gfc_current_locus;
gfc_set_sym_referenced (varst->n.sym);
m = gfc_match_varspec (base, 0, true); m = gfc_match_varspec (base, 0, true);
if (m == MATCH_NO) if (m == MATCH_NO)
......
...@@ -36,6 +36,9 @@ extern gfc_st_label *gfc_statement_label; ...@@ -36,6 +36,9 @@ extern gfc_st_label *gfc_statement_label;
extern int gfc_matching_procptr_assignment; extern int gfc_matching_procptr_assignment;
extern bool gfc_matching_prefix; extern bool gfc_matching_prefix;
/* Default access specifier while matching procedure bindings. */
extern gfc_access gfc_typebound_default_access;
/****************** All gfc_match* routines *****************/ /****************** All gfc_match* routines *****************/
/* match.c. */ /* match.c. */
...@@ -141,6 +144,7 @@ match gfc_match_end (gfc_statement *); ...@@ -141,6 +144,7 @@ match gfc_match_end (gfc_statement *);
match gfc_match_data_decl (void); match gfc_match_data_decl (void);
match gfc_match_formal_arglist (gfc_symbol *, int, int); match gfc_match_formal_arglist (gfc_symbol *, int, int);
match gfc_match_procedure (void); match gfc_match_procedure (void);
match gfc_match_generic (void);
match gfc_match_function_decl (void); match gfc_match_function_decl (void);
match gfc_match_entry (void); match gfc_match_entry (void);
match gfc_match_subroutine (void); match gfc_match_subroutine (void);
......
...@@ -1698,6 +1698,12 @@ static const mstring binding_overriding[] = ...@@ -1698,6 +1698,12 @@ static const mstring binding_overriding[] =
minit ("NON_OVERRIDABLE", 1), minit ("NON_OVERRIDABLE", 1),
minit (NULL, -1) minit (NULL, -1)
}; };
static const mstring binding_generic[] =
{
minit ("SPECIFIC", 0),
minit ("GENERIC", 1),
minit (NULL, -1)
};
/* Specialization of mio_name. */ /* Specialization of mio_name. */
...@@ -3189,6 +3195,8 @@ mio_namespace_ref (gfc_namespace **nsp) ...@@ -3189,6 +3195,8 @@ mio_namespace_ref (gfc_namespace **nsp)
/* Save/restore the f2k_derived namespace of a derived-type symbol. */ /* Save/restore the f2k_derived namespace of a derived-type symbol. */
static gfc_namespace* current_f2k_derived;
static void static void
mio_typebound_proc (gfc_typebound_proc** proc) mio_typebound_proc (gfc_typebound_proc** proc)
{ {
...@@ -3202,13 +3210,13 @@ mio_typebound_proc (gfc_typebound_proc** proc) ...@@ -3202,13 +3210,13 @@ mio_typebound_proc (gfc_typebound_proc** proc)
gcc_assert (*proc); gcc_assert (*proc);
mio_lparen (); mio_lparen ();
mio_symtree_ref (&(*proc)->target);
(*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types); (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
(*proc)->nopass = mio_name ((*proc)->nopass, binding_passing); (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
(*proc)->non_overridable = mio_name ((*proc)->non_overridable, (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
binding_overriding); binding_overriding);
(*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
if (iomode == IO_INPUT) if (iomode == IO_INPUT)
(*proc)->pass_arg = NULL; (*proc)->pass_arg = NULL;
...@@ -3217,6 +3225,38 @@ mio_typebound_proc (gfc_typebound_proc** proc) ...@@ -3217,6 +3225,38 @@ mio_typebound_proc (gfc_typebound_proc** proc)
mio_integer (&flag); mio_integer (&flag);
(*proc)->pass_arg_num = (unsigned) 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 (); mio_rparen ();
} }
...@@ -3260,6 +3300,8 @@ mio_finalizer (gfc_finalizer **f) ...@@ -3260,6 +3300,8 @@ mio_finalizer (gfc_finalizer **f)
static void static void
mio_f2k_derived (gfc_namespace *f2k) mio_f2k_derived (gfc_namespace *f2k)
{ {
current_f2k_derived = f2k;
/* Handle the list of finalizer procedures. */ /* Handle the list of finalizer procedures. */
mio_lparen (); mio_lparen ();
if (iomode == IO_OUTPUT) if (iomode == IO_OUTPUT)
......
...@@ -372,6 +372,7 @@ decode_statement (void) ...@@ -372,6 +372,7 @@ decode_statement (void)
break; break;
case 'g': case 'g':
match ("generic", gfc_match_generic, ST_GENERIC);
match ("go to", gfc_match_goto, ST_GOTO); match ("go to", gfc_match_goto, ST_GOTO);
break; break;
...@@ -1195,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st) ...@@ -1195,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_FUNCTION: case ST_FUNCTION:
p = "FUNCTION"; p = "FUNCTION";
break; break;
case ST_GENERIC:
p = "GENERIC";
break;
case ST_GOTO: case ST_GOTO:
p = "GOTO"; p = "GOTO";
break; break;
...@@ -1691,21 +1695,10 @@ unexpected_eof (void) ...@@ -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. */ /* Parse the CONTAINS section of a derived type definition. */
gfc_access gfc_typebound_default_access;
static bool static bool
parse_derived_contains (void) parse_derived_contains (void)
{ {
...@@ -1730,6 +1723,8 @@ parse_derived_contains (void) ...@@ -1730,6 +1723,8 @@ parse_derived_contains (void)
accept_statement (ST_CONTAINS); accept_statement (ST_CONTAINS);
push_state (&s, COMP_DERIVED_CONTAINS, NULL); push_state (&s, COMP_DERIVED_CONTAINS, NULL);
gfc_typebound_default_access = ACCESS_PUBLIC;
to_finish = false; to_finish = false;
while (!to_finish) while (!to_finish)
{ {
...@@ -1755,6 +1750,15 @@ parse_derived_contains (void) ...@@ -1755,6 +1750,15 @@ parse_derived_contains (void)
seen_comps = true; seen_comps = true;
break; 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: case ST_FINAL:
if (gfc_notify_std (GFC_STD_F2003, if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: FINAL procedure declaration" "Fortran 2003: FINAL procedure declaration"
...@@ -1801,6 +1805,7 @@ parse_derived_contains (void) ...@@ -1801,6 +1805,7 @@ parse_derived_contains (void)
} }
accept_statement (ST_PRIVATE); accept_statement (ST_PRIVATE);
gfc_typebound_default_access = ACCESS_PRIVATE;
seen_private = true; seen_private = true;
break; break;
...@@ -1823,12 +1828,6 @@ parse_derived_contains (void) ...@@ -1823,12 +1828,6 @@ parse_derived_contains (void)
pop_state (); pop_state ();
gcc_assert (gfc_current_state () == COMP_DERIVED); 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; return error_flag;
} }
......
...@@ -1709,7 +1709,6 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag) ...@@ -1709,7 +1709,6 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
gfc_ref *substring, *tail; gfc_ref *substring, *tail;
gfc_component *component; gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym; gfc_symbol *sym = primary->symtree->n.sym;
gfc_symtree *tbp;
match m; match m;
bool unknown; bool unknown;
...@@ -1754,6 +1753,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag) ...@@ -1754,6 +1753,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
for (;;) for (;;)
{ {
gfc_try t; gfc_try t;
gfc_symtree *tbp;
m = gfc_match_name (name); m = gfc_match_name (name);
if (m == MATCH_NO) if (m == MATCH_NO)
...@@ -1772,13 +1772,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag) ...@@ -1772,13 +1772,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
gcc_assert (!tail || !tail->next); gcc_assert (!tail || !tail->next);
gcc_assert (primary->expr_type == EXPR_VARIABLE); 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->expr_type = EXPR_COMPCALL;
primary->value.compcall.tbp = tbp; primary->value.compcall.tbp = tbp->typebound;
primary->ts = tbp_sym->ts; primary->value.compcall.derived = sym;
primary->value.compcall.name = tbp->name;
m = gfc_match_actual_arglist (tbp_sym->attr.subroutine, gcc_assert (primary->symtree->n.sym->attr.referenced);
if (tbp_sym)
primary->ts = tbp_sym->ts;
m = gfc_match_actual_arglist (tbp->typebound->subroutine,
&primary->value.compcall.actual); &primary->value.compcall.actual);
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return MATCH_ERROR; return MATCH_ERROR;
...@@ -1793,16 +1800,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag) ...@@ -1793,16 +1800,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
} }
} }
if (sub_flag && !tbp_sym->attr.subroutine) gfc_set_sym_referenced (tbp->n.sym);
{
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;
}
break; break;
} }
......
...@@ -109,7 +109,6 @@ gfc_free_statement (gfc_code *p) ...@@ -109,7 +109,6 @@ gfc_free_statement (gfc_code *p)
break; break;
case EXEC_COMPCALL: case EXEC_COMPCALL:
gfc_free_expr (p->expr);
case EXEC_CALL: case EXEC_CALL:
case EXEC_ASSIGN_CALL: case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual); gfc_free_actual_arglist (p->ext.actual);
......
...@@ -4279,11 +4279,8 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, ...@@ -4279,11 +4279,8 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
/* Try to find it in the current type's namespace. */ /* Try to find it in the current type's namespace. */
gcc_assert (derived->f2k_derived); gcc_assert (derived->f2k_derived);
res = gfc_find_symtree (derived->f2k_derived->sym_root, name); res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
if (res) if (res && res->typebound)
{ {
if (!res->typebound)
return NULL;
/* We found one. */ /* We found one. */
if (t) if (t)
*t = SUCCESS; *t = SUCCESS;
......
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> 2008-08-30 Andrew Pinski <andrew_pinski@playstation.sony.com>
PR middle-end/36444 PR middle-end/36444
......
! { 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" } }
! { 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" } }
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment