+2009-04-24 Daniel Kraft <d@domob.eu>
+
+ * gfortran.h (gfc_get_typebound_proc): Removed as macro, now a function.
+ (struct gfc_symtree): Moved `typebound' member inside union.
+ (struct gfc_namespace): Add `tb_sym_root' as new symtree to sort out
+ type-bound procedures there.
+ (gfc_get_tbp_symtree): New procedure.
+ * symbol.c (tentative_tbp_list): New global.
+ (gfc_get_namespace): NULL new `tb_sym_root' member.
+ (gfc_new_symtree): Removed initialization of `typebound' member.
+ (gfc_undo_symbols): Process list of tentative tbp's.
+ (gfc_commit_symbols): Ditto.
+ (free_tb_tree): New method.
+ (gfc_free_namespace): Call it.
+ (gfc_get_typebound_proc): New method.
+ (gfc_get_tbp_symtree): New method.
+ (gfc_find_typebound_proc): Adapt to structural changes of gfc_symtree
+ and gfc_namespace with regards to tbp's.
+ * dump-parse-tree.c (show_typebound): Ditto.
+ * primary.c (gfc_match_varspec): Ditto. Don't reference tbp-symbol
+ as it isn't a symbol any longer.
+ * module.c (mio_typebound_symtree): Adapt to changes.
+ (mio_typebound_proc): Ditto, create symtrees using `gfc_get_tbp_symtree'
+ rather than `gfc_get_sym_tree'.
+ (mio_f2k_derived): Ditto.
+ * decl.c (match_procedure_in_type): Ditto.
+ (gfc_match_generic): Ditto. Don't reference tbp-symbol.
+ * resolve.c (check_typebound_override): Adapt to changes.
+ (resolve_typebound_generic): Ditto.
+ (resolve_typebound_procedures): Ditto.
+ (ensure_not_abstract_walker): Ditto.
+ (ensure_not_abstract): Ditto.
+ (resolve_typebound_procedure): Ditto, ignore erraneous symbols (for
+ instance, through removed tentative ones).
+ * gfc-internals.texi (Type-bound procedures): Document changes.
+
2009-04-24 Janus Weil <janus@gcc.gnu.org>
PR fortran/39861
/* See if we already have a binding with this name in the symtree which would
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 && stree->typebound)
+ stree = gfc_find_symtree (ns->tb_sym_root, name);
+ if (stree && stree->n.tb)
{
gfc_error ("There's already a procedure with binding name '%s' for the"
" derived type '%s' at %C", name, block->name);
}
/* Insert it and set attributes. */
- if (gfc_get_sym_tree (name, ns, &stree))
- return MATCH_ERROR;
+
+ if (!stree)
+ {
+ stree = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (stree);
+ }
+ stree->n.tb = tb;
+
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;
}
/* 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);
+ st = gfc_find_symtree (ns->tb_sym_root, name);
if (st)
{
- if (!st->typebound || !st->typebound->is_generic)
+ gcc_assert (st->n.tb);
+ tb = st->n.tb;
+
+ if (!tb->is_generic)
{
gfc_error ("There's already a non-generic procedure with binding name"
" '%s' for the derived type '%s' at %C",
goto error;
}
- tb = st->typebound;
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
}
else
{
- if (gfc_get_sym_tree (name, ns, &st))
- return MATCH_ERROR;
+ st = gfc_new_symtree (&ns->tb_sym_root, name);
+ gcc_assert (st);
- st->typebound = tb = gfc_get_typebound_proc ();
+ st->n.tb = tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
goto error;
}
- if (gfc_get_sym_tree (name, ns, &target_st))
- goto error;
+ target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
/* 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);
+ " generic '%s' at %C", name, st->name);
goto error;
}
- gfc_set_sym_referenced (target_st->n.sym);
-
target = gfc_get_tbp_generic ();
target->specific_st = target_st;
target->specific = NULL;
static void
show_typebound (gfc_symtree* st)
{
- if (!st->typebound)
+ if (!st->n.tb)
return;
show_indent ();
- if (st->typebound->is_generic)
+ if (st->n.tb->is_generic)
fputs ("GENERIC", dumpfile);
else
{
fputs ("PROCEDURE, ", dumpfile);
- if (st->typebound->nopass)
+ if (st->n.tb->nopass)
fputs ("NOPASS", dumpfile);
else
{
- if (st->typebound->pass_arg)
- fprintf (dumpfile, "PASS(%s)", st->typebound->pass_arg);
+ if (st->n.tb->pass_arg)
+ fprintf (dumpfile, "PASS(%s)", st->n.tb->pass_arg);
else
fputs ("PASS", dumpfile);
}
- if (st->typebound->non_overridable)
+ if (st->n.tb->non_overridable)
fputs (", NON_OVERRIDABLE", dumpfile);
}
- if (st->typebound->access == ACCESS_PUBLIC)
+ if (st->n.tb->access == ACCESS_PUBLIC)
fputs (", PUBLIC", dumpfile);
else
fputs (", PRIVATE", dumpfile);
fprintf (dumpfile, " :: %s => ", st->n.sym->name);
- if (st->typebound->is_generic)
+ if (st->n.tb->is_generic)
{
gfc_tbp_generic* g;
- for (g = st->typebound->u.generic; g; g = g->next)
+ for (g = st->n.tb->u.generic; g; g = g->next)
{
fputs (g->specific_st->name, dumpfile);
if (g->next)
}
}
else
- fputs (st->typebound->u.specific->n.sym->name, dumpfile);
+ fputs (st->n.tb->u.specific->n.sym->name, dumpfile);
}
static void
@node Type-bound Procedures
@section Type-bound Procedures
-Type-bound procedures are stored in the @code{sym_root} of the namespace
+Type-bound procedures are stored in the @code{tb_sym_root} of the namespace
@code{f2k_derived} associated with the derived-type symbol as @code{gfc_symtree}
nodes. The name and symbol of these symtrees corresponds to the binding-name
of the procedure, i.e. the name that is used to call it from the context of an
object of the derived-type.
-In addition, those and only those symtrees representing a type-bound procedure
-have their @code{typebound} member set; @code{typebound} points to a struct of
-type @code{gfc_typebound_proc} containing the additional data needed: The
+In addition, this type of symtrees stores in @code{n.tb} a struct of type
+@code{gfc_typebound_proc} containing the additional data needed: The
binding attributes (like @code{PASS} and @code{NOPASS}, @code{NON_OVERRIDABLE}
or the access-specifier), the binding's target(s) and, if the current binding
overrides or extends an inherited binding of the same name, @code{overridden}
}
gfc_typebound_proc;
-#define gfc_get_typebound_proc() XCNEW (gfc_typebound_proc)
-
/* Symbol nodes. These are important things. They are what the
standard refers to as "entities". The possibly multiple names that
gfc_symbol *sym; /* Symbol associated with this node */
gfc_user_op *uop;
gfc_common_head *common;
+ gfc_typebound_proc *tb;
}
n;
-
- /* Data for type-bound procedures; NULL if no type-bound procedure. */
- gfc_typebound_proc* typebound;
}
gfc_symtree;
gfc_symtree *uop_root;
/* Tree containing all the common blocks. */
gfc_symtree *common_root;
+
+ /* Tree containing type-bound procedures. */
+ gfc_symtree *tb_sym_root;
/* Linked list of finalizer procedures. */
struct gfc_finalizer *finalizers;
gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
+gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
+gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
(*proc)->u.generic = NULL;
while (peek_atom () != ATOM_RPAREN)
{
+ gfc_symtree** sym_root;
+
g = gfc_get_tbp_generic ();
g->specific = NULL;
require_atom (ATOM_STRING);
- gfc_get_sym_tree (atom_string, current_f2k_derived,
- &g->specific_st);
+ sym_root = ¤t_f2k_derived->tb_sym_root;
+ g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
gfc_free (atom_string);
g->next = (*proc)->u.generic;
static void
mio_typebound_symtree (gfc_symtree* st)
{
- if (iomode == IO_OUTPUT && !st->typebound)
+ if (iomode == IO_OUTPUT && !st->n.tb)
return;
if (iomode == IO_OUTPUT)
}
/* For IO_INPUT, the above is done in mio_f2k_derived. */
- mio_typebound_proc (&st->typebound);
+ mio_typebound_proc (&st->n.tb);
mio_rparen ();
}
/* Handle type-bound procedures. */
mio_lparen ();
if (iomode == IO_OUTPUT)
- gfc_traverse_symtree (f2k->sym_root, &mio_typebound_symtree);
+ gfc_traverse_symtree (f2k->tb_sym_root, &mio_typebound_symtree);
else
{
while (peek_atom () == ATOM_LPAREN)
mio_lparen ();
require_atom (ATOM_STRING);
- gfc_get_sym_tree (atom_string, f2k, &st);
+ st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string);
gfc_free (atom_string);
mio_typebound_symtree (st);
gcc_assert (!tail || !tail->next);
gcc_assert (primary->expr_type == EXPR_VARIABLE);
- if (tbp->typebound->is_generic)
+ if (tbp->n.tb->is_generic)
tbp_sym = NULL;
else
- tbp_sym = tbp->typebound->u.specific->n.sym;
+ tbp_sym = tbp->n.tb->u.specific->n.sym;
primary->expr_type = EXPR_COMPCALL;
- primary->value.compcall.tbp = tbp->typebound;
+ primary->value.compcall.tbp = tbp->n.tb;
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->typebound->subroutine,
+ m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
&primary->value.compcall.actual);
if (m == MATCH_ERROR)
return MATCH_ERROR;
}
}
- gfc_set_sym_referenced (tbp->n.sym);
-
break;
}
gfc_formal_arglist* old_formal;
/* This procedure should only be called for non-GENERIC proc. */
- gcc_assert (!proc->typebound->is_generic);
+ gcc_assert (!proc->n.tb->is_generic);
/* If the overwritten procedure is GENERIC, this is an error. */
- if (old->typebound->is_generic)
+ if (old->n.tb->is_generic)
{
gfc_error ("Can't overwrite GENERIC '%s' at %L",
- old->name, &proc->typebound->where);
+ old->name, &proc->n.tb->where);
return FAILURE;
}
- where = proc->typebound->where;
- proc_target = proc->typebound->u.specific->n.sym;
- old_target = old->typebound->u.specific->n.sym;
+ where = proc->n.tb->where;
+ proc_target = proc->n.tb->u.specific->n.sym;
+ old_target = old->n.tb->u.specific->n.sym;
/* Check that overridden binding is not NON_OVERRIDABLE. */
- if (old->typebound->non_overridable)
+ if (old->n.tb->non_overridable)
{
gfc_error ("'%s' at %L overrides a procedure binding declared"
" NON_OVERRIDABLE", proc->name, &where);
}
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
- if (!old->typebound->deferred && proc->typebound->deferred)
+ if (!old->n.tb->deferred && proc->n.tb->deferred)
{
gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
" non-DEFERRED binding", proc->name, &where);
/* If the overridden binding is PUBLIC, the overriding one must not be
PRIVATE. */
- if (old->typebound->access == ACCESS_PUBLIC
- && proc->typebound->access == ACCESS_PRIVATE)
+ if (old->n.tb->access == ACCESS_PUBLIC
+ && proc->n.tb->access == ACCESS_PRIVATE)
{
gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
" PRIVATE", proc->name, &where);
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)
+ if (!proc->n.tb->nopass && !proc->n.tb->pass_arg)
proc_pass_arg = 1;
- if (!old->typebound->nopass && !old->typebound->pass_arg)
+ if (!old->n.tb->nopass && !old->n.tb->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))
+ if (proc->n.tb->pass_arg
+ && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
proc_pass_arg = argpos;
- if (old->typebound->pass_arg
- && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
+ if (old->n.tb->pass_arg
+ && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
old_pass_arg = argpos;
/* Check that the names correspond. */
/* If the overridden binding is NOPASS, the overriding one must also be
NOPASS. */
- if (old->typebound->nopass && !proc->typebound->nopass)
+ if (old->n.tb->nopass && !proc->n.tb->nopass)
{
gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
" NOPASS", proc->name, &where);
/* 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 (!old->n.tb->nopass)
{
- if (proc->typebound->nopass)
+ if (proc->n.tb->nopass)
{
gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
" PASS", proc->name, &where);
gfc_symtree* inherited;
locus where;
- gcc_assert (st->typebound);
- gcc_assert (st->typebound->is_generic);
+ gcc_assert (st->n.tb);
+ gcc_assert (st->n.tb->is_generic);
- where = st->typebound->where;
+ where = st->n.tb->where;
super_type = gfc_get_derived_super_type (derived);
/* Find the overridden binding if any. */
- st->typebound->overridden = NULL;
+ st->n.tb->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;
+ if (overridden && overridden->n.tb)
+ st->n.tb->overridden = overridden->n.tb;
}
/* 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)
+ gcc_assert (st->n.tb->u.generic);
+ for (target = st->n.tb->u.generic; target; target = target->next)
if (!target->specific)
{
gfc_typebound_proc* overridden_tbp;
target_name = target->specific_st->name;
/* Defined for this type directly. */
- if (target->specific_st->typebound)
+ if (target->specific_st->n.tb)
{
- target->specific = target->specific_st->typebound;
+ target->specific = target->specific_st->n.tb;
goto specific_found;
}
if (inherited)
{
- gcc_assert (inherited->typebound);
- target->specific = inherited->typebound;
+ gcc_assert (inherited->n.tb);
+ target->specific = inherited->n.tb;
goto specific_found;
}
}
}
/* Check those already resolved on this type directly. */
- for (g = st->typebound->u.generic; g; g = g->next)
+ for (g = st->n.tb->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;
+ for (overridden_tbp = st->n.tb->overridden; overridden_tbp;
overridden_tbp = overridden_tbp->overridden)
if (overridden_tbp->is_generic)
{
}
/* If we attempt to "overwrite" a specific binding, this is an error. */
- if (st->typebound->overridden && !st->typebound->overridden->is_generic)
+ if (st->n.tb->overridden && !st->n.tb->overridden->is_generic)
{
gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
" the same name", st->name, &where);
/* 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;
+ first_target = st->n.tb->u.generic->specific->u.specific;
+ gcc_assert (first_target);
+ st->n.tb->subroutine = first_target->n.sym->attr.subroutine;
+ st->n.tb->function = first_target->n.sym->attr.function;
return SUCCESS;
}
gfc_symbol* super_type;
gfc_component* comp;
- /* If this is no type-bound procedure, just return. */
- if (!stree->typebound)
+ gcc_assert (stree);
+
+ /* Undefined specific symbol from GENERIC target definition. */
+ if (!stree->n.tb)
+ return;
+
+ if (stree->n.tb->error)
return;
/* If this is a GENERIC binding, use that routine. */
- if (stree->typebound->is_generic)
+ if (stree->n.tb->is_generic)
{
if (resolve_typebound_generic (resolve_bindings_derived, stree)
== FAILURE)
}
/* Get the target-procedure to check it. */
- gcc_assert (!stree->typebound->is_generic);
- gcc_assert (stree->typebound->u.specific);
- proc = stree->typebound->u.specific->n.sym;
- where = stree->typebound->where;
+ gcc_assert (!stree->n.tb->is_generic);
+ gcc_assert (stree->n.tb->u.specific);
+ proc = stree->n.tb->u.specific->n.sym;
+ where = stree->n.tb->where;
/* Default access should already be resolved from the parser. */
- gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
+ gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN);
/* It should be a module procedure or an external procedure with explicit
interface. For DEFERRED bindings, abstract interfaces are ok as well. */
if ((!proc->attr.subroutine && !proc->attr.function)
|| (proc->attr.proc != PROC_MODULE
&& proc->attr.if_source != IFSRC_IFBODY)
- || (proc->attr.abstract && !stree->typebound->deferred))
+ || (proc->attr.abstract && !stree->n.tb->deferred))
{
gfc_error ("'%s' must be a module procedure or an external procedure with"
" an explicit interface at %L", proc->name, &where);
goto error;
}
- stree->typebound->subroutine = proc->attr.subroutine;
- stree->typebound->function = proc->attr.function;
+ stree->n.tb->subroutine = proc->attr.subroutine;
+ stree->n.tb->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
/* 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->n.tb->nopass && stree->n.tb->pass_arg_num == 0)
{
- if (stree->typebound->pass_arg)
+ if (stree->n.tb->pass_arg)
{
gfc_formal_arglist* i;
and look for it. */
me_arg = NULL;
- stree->typebound->pass_arg_num = 1;
+ stree->n.tb->pass_arg_num = 1;
for (i = proc->formal; i; i = i->next)
{
- if (!strcmp (i->sym->name, stree->typebound->pass_arg))
+ if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
{
me_arg = i->sym;
break;
}
- ++stree->typebound->pass_arg_num;
+ ++stree->n.tb->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);
+ proc->name, stree->n.tb->pass_arg, &where,
+ stree->n.tb->pass_arg);
goto error;
}
}
{
/* Otherwise, take the first one; there should in fact be at least
one. */
- stree->typebound->pass_arg_num = 1;
+ stree->n.tb->pass_arg_num = 1;
if (!proc->formal)
{
gfc_error ("Procedure '%s' with PASS at %L must have at"
/* If we are extending some type, check that we don't override a procedure
flagged NON_OVERRIDABLE. */
- stree->typebound->overridden = NULL;
+ stree->n.tb->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 && overridden->n.tb)
+ stree->n.tb->overridden = overridden->n.tb;
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
goto error;
goto error;
}
- stree->typebound->error = 0;
+ stree->n.tb->error = 0;
return;
error:
resolve_bindings_result = FAILURE;
- stree->typebound->error = 1;
+ stree->n.tb->error = 1;
}
static gfc_try
resolve_typebound_procedures (gfc_symbol* derived)
{
- if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
+ if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
- gfc_traverse_symtree (derived->f2k_derived->sym_root,
+ gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
&resolve_typebound_procedure);
return resolve_bindings_result;
if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
return FAILURE;
- if (st->typebound && st->typebound->deferred)
+ if (st->n.tb && st->n.tb->deferred)
{
gfc_symtree* overriding;
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
- gcc_assert (overriding && overriding->typebound);
- if (overriding->typebound->deferred)
+ gcc_assert (overriding && overriding->n.tb);
+ if (overriding->n.tb->deferred)
{
gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
" '%s' is DEFERRED and not overridden",
if (ancestor->f2k_derived)
{
gfc_try t;
- t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->sym_root);
+ t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root);
if (t == FAILURE)
return FAILURE;
}
gfc_dt_list *gfc_derived_types;
+/* List of tentative typebound-procedures. */
+
+typedef struct tentative_tbp
+{
+ gfc_typebound_proc *proc;
+ struct tentative_tbp *next;
+}
+tentative_tbp;
+
+static tentative_tbp *tentative_tbp_list = NULL;
+
+
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
/* The following static variable indicates whether a particular element has
ns = XCNEW (gfc_namespace);
ns->sym_root = NULL;
ns->uop_root = NULL;
+ ns->tb_sym_root = NULL;
ns->finalizers = NULL;
ns->default_access = ACCESS_UNKNOWN;
ns->parent = parent;
st = XCNEW (gfc_symtree);
st->name = gfc_get_string (name);
- st->typebound = NULL;
gfc_insert_bbt (root, st, compare_symtree);
return st;
gfc_undo_symbols (void)
{
gfc_symbol *p, *q, *old;
+ tentative_tbp *tbp, *tbq;
for (p = changed_syms; p; p = q)
{
}
changed_syms = NULL;
+
+ for (tbp = tentative_tbp_list; tbp; tbp = tbq)
+ {
+ tbq = tbp->next;
+ /* Procedure is already marked `error' by default. */
+ gfc_free (tbp);
+ }
+ tentative_tbp_list = NULL;
}
gfc_commit_symbols (void)
{
gfc_symbol *p, *q;
+ tentative_tbp *tbp, *tbq;
for (p = changed_syms; p; p = q)
{
free_old_symbol (p);
}
changed_syms = NULL;
+
+ for (tbp = tentative_tbp_list; tbp; tbp = tbq)
+ {
+ tbq = tbp->next;
+ tbp->proc->error = 0;
+ gfc_free (tbp);
+ }
+ tentative_tbp_list = NULL;
}
}
+/* Recursively free trees containing type-bound procedures. */
+
+static void
+free_tb_tree (gfc_symtree *t)
+{
+ if (t == NULL)
+ return;
+
+ free_tb_tree (t->left);
+ free_tb_tree (t->right);
+
+ /* TODO: Free type-bound procedure structs themselves; probably needs some
+ sort of ref-counting mechanism. */
+
+ gfc_free (t);
+}
+
+
/* Recursive function that deletes an entire tree and all the common
head structures it points to. */
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ free_tb_tree (ns->tb_sym_root);
gfc_free_finalizer_list (ns->finalizers);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
}
+/* Construct a typebound-procedure structure. Those are stored in a tentative
+ list and marked `error' until symbols are committed. */
+
+gfc_typebound_proc*
+gfc_get_typebound_proc (void)
+{
+ gfc_typebound_proc *result;
+ tentative_tbp *list_node;
+
+ result = XCNEW (gfc_typebound_proc);
+ result->error = 1;
+
+ list_node = XCNEW (tentative_tbp);
+ list_node->next = tentative_tbp_list;
+ list_node->proc = result;
+ tentative_tbp_list = list_node;
+
+ return result;
+}
+
+
/* Get the super-type of a given derived type. */
gfc_symbol*
/* 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 && res->typebound)
+ res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
+ if (res && res->n.tb)
{
/* We found one. */
if (t)
*t = SUCCESS;
if (!noaccess && derived->attr.use_assoc
- && res->typebound->access == ACCESS_PRIVATE)
+ && res->n.tb->access == ACCESS_PRIVATE)
{
gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
if (t)
/* Nothing found. */
return NULL;
}
+
+
+/* Get a typebound-procedure symtree or create and insert it if not yet
+ present. This is like a very simplified version of gfc_get_sym_tree for
+ tbp-symtrees rather than regular ones. */
+
+gfc_symtree*
+gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+{
+ gfc_symtree *result;
+
+ result = gfc_find_symtree (*root, name);
+ if (!result)
+ {
+ result = gfc_new_symtree (root, name);
+ gcc_assert (result);
+ result->n.tb = NULL;
+ }
+
+ return result;
+}
+2009-04-24 Daniel Kraft <d@domob.eu>
+
+ * gfortran.dg/typebound_generic_1.f03: Change so that no error is
+ expected on already erraneous symbol (renamed to fresh one).
+
2009-04-24 Paolo Bonzini <bonzini@gnu.org>
PR middle-end/39867
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 :: gen5 => p_notthere ! { dg-error "Undefined specific binding" }
+ GENERIC :: gen6 => gen1 ! { dg-error "must target a specific binding" }
GENERIC :: gensubr => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
GENERIC :: gensubr => subr
OSDN Git Service
