gfortran.h (gfc_get_typebound_proc): Removed as macro, now a function.

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  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).

From-SVN: r146733

gcc/fortran/ChangeLog

+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

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;

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

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}

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 *);

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 = &current_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);

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

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

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

gcc/testsuite/ChangeLog

+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

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