diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 36 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 36 | ||||
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 20 | ||||
| -rw-r--r-- | gcc/fortran/gfc-internals.texi | 7 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 11 | ||||
| -rw-r--r-- | gcc/fortran/module.c | 14 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 140 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 99 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/typebound_generic_1.f03 | 4 |
11 files changed, 262 insertions, 120 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6af8cbe2042..769f3c41267 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,39 @@ +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 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index b99989ffeb8..1a2e8452e5d 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -7141,8 +7141,8 @@ match_procedure_in_type (void) /* 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); @@ -7150,12 +7150,17 @@ match_procedure_in_type (void) } /* 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; } @@ -7210,10 +7215,13 @@ gfc_match_generic (void) /* 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", @@ -7221,7 +7229,6 @@ gfc_match_generic (void) goto error; } - tb = st->typebound; if (tb->access != tbattr.access) { gfc_error ("Binding at %C must have the same access as already" @@ -7231,10 +7238,10 @@ gfc_match_generic (void) } 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; @@ -7256,20 +7263,17 @@ gfc_match_generic (void) 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; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 32c97d06b73..6c915084db9 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -671,40 +671,40 @@ show_components (gfc_symbol *sym) 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) @@ -712,7 +712,7 @@ show_typebound (gfc_symtree* st) } } else - fputs (st->typebound->u.specific->n.sym->name, dumpfile); + fputs (st->n.tb->u.specific->n.sym->name, dumpfile); } static void diff --git a/gcc/fortran/gfc-internals.texi b/gcc/fortran/gfc-internals.texi index 97aec7ba89f..65fc7697dc7 100644 --- a/gcc/fortran/gfc-internals.texi +++ b/gcc/fortran/gfc-internals.texi @@ -577,15 +577,14 @@ substring reference as described in the subsection above. @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} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5ee297ba7cf..875be9516b8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1049,8 +1049,6 @@ typedef struct gfc_typebound_proc } 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 @@ -1215,11 +1213,9 @@ typedef struct gfc_symtree 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; @@ -1248,6 +1244,9 @@ typedef struct gfc_namespace 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; @@ -2370,8 +2369,10 @@ void gfc_free_dt_list (void); 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 *); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 9c55c2f36ab..12ac96600cf 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -3251,12 +3251,14 @@ mio_typebound_proc (gfc_typebound_proc** proc) (*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; @@ -3275,7 +3277,7 @@ mio_typebound_proc (gfc_typebound_proc** proc) 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) @@ -3285,7 +3287,7 @@ mio_typebound_symtree (gfc_symtree* st) } /* For IO_INPUT, the above is done in mio_f2k_derived. */ - mio_typebound_proc (&st->typebound); + mio_typebound_proc (&st->n.tb); mio_rparen (); } @@ -3338,7 +3340,7 @@ mio_f2k_derived (gfc_namespace *f2k) /* 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) @@ -3348,7 +3350,7 @@ mio_f2k_derived (gfc_namespace *f2k) 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); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index cab8f82edfb..7e41535c266 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1784,19 +1784,19 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag) 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; @@ -1811,8 +1811,6 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag) } } - gfc_set_sym_referenced (tbp->n.sym); - break; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 25834f8ca99..3277475d1e7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8283,22 +8283,22 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) 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); @@ -8306,7 +8306,7 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) } /* 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); @@ -8370,8 +8370,8 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* 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); @@ -8383,20 +8383,20 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) 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. */ @@ -8432,7 +8432,7 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* 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); @@ -8441,9 +8441,9 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old) /* 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); @@ -8512,26 +8512,26 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) 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; @@ -8541,9 +8541,9 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) 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; } @@ -8555,8 +8555,8 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) if (inherited) { - gcc_assert (inherited->typebound); - target->specific = inherited->typebound; + gcc_assert (inherited->n.tb); + target->specific = inherited->n.tb; goto specific_found; } } @@ -8579,14 +8579,14 @@ 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) { @@ -8601,7 +8601,7 @@ specific_found: } /* 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); @@ -8610,9 +8610,10 @@ specific_found: /* 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; } @@ -8632,12 +8633,17 @@ resolve_typebound_procedure (gfc_symtree* stree) 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) @@ -8646,27 +8652,27 @@ resolve_typebound_procedure (gfc_symtree* stree) } /* 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 @@ -8675,9 +8681,9 @@ resolve_typebound_procedure (gfc_symtree* stree) /* 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; @@ -8685,23 +8691,23 @@ resolve_typebound_procedure (gfc_symtree* stree) 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; } } @@ -8709,7 +8715,7 @@ resolve_typebound_procedure (gfc_symtree* stree) { /* 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" @@ -8737,15 +8743,15 @@ 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; + 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; @@ -8770,23 +8776,23 @@ resolve_typebound_procedure (gfc_symtree* stree) 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; @@ -8828,12 +8834,12 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) 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", @@ -8861,7 +8867,7 @@ ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) 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; } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6aa63bebabe..a82e67558fb 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -101,6 +101,18 @@ static gfc_symbol *changed_syms = NULL; 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 @@ -2191,6 +2203,7 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types) 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; @@ -2258,7 +2271,6 @@ gfc_new_symtree (gfc_symtree **root, const char *name) st = XCNEW (gfc_symtree); st->name = gfc_get_string (name); - st->typebound = NULL; gfc_insert_bbt (root, st, compare_symtree); return st; @@ -2691,6 +2703,7 @@ void gfc_undo_symbols (void) { gfc_symbol *p, *q, *old; + tentative_tbp *tbp, *tbq; for (p = changed_syms; p; p = q) { @@ -2789,6 +2802,14 @@ gfc_undo_symbols (void) } 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; } @@ -2826,6 +2847,7 @@ void gfc_commit_symbols (void) { gfc_symbol *p, *q; + tentative_tbp *tbp, *tbq; for (p = changed_syms; p; p = q) { @@ -2836,6 +2858,14 @@ gfc_commit_symbols (void) 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; } @@ -2867,6 +2897,24 @@ gfc_commit_symbol (gfc_symbol *sym) } +/* 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. */ @@ -3055,6 +3103,7 @@ gfc_free_namespace (gfc_namespace *ns) 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); @@ -4342,6 +4391,27 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, } +/* 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* @@ -4373,15 +4443,15 @@ 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 && 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) @@ -4403,3 +4473,24 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* 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; +} diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7fd0f1f41cd..bbe7fba7faf 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +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 diff --git a/gcc/testsuite/gfortran.dg/typebound_generic_1.f03 b/gcc/testsuite/gfortran.dg/typebound_generic_1.f03 index 08303557cf7..1ae08fc14f2 100644 --- a/gcc/testsuite/gfortran.dg/typebound_generic_1.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_generic_1.f03 @@ -28,8 +28,8 @@ MODULE m 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 |