This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] [RFC] Reworking type-bound procedures


Hi all,

I started recently working on type-bound operators (as they are the missing piece for the current type-bound procedure implementation); I did however stumble upon a little oversight in design of type-bound procedures.

Currently, those are stored in sym_root of the f2k_derived namespace; this is quite nice as it allows using a lot of already available functions for working with symbols and namespaces; however, there are two issues I became aware of:

1) This creates and maintains a full-blown gfc_symbol attached to the type-bound procedures nodes that is not used at all, and may only complicate things or could eventually lead to weird bugs in the future (who knows...).

2) For adding the type-bound operators, I want to have a new symtree (I could use sym_root for this, too, only if we did something like store operators there with mangled, special names which seems quite ugly to me). And while the ordinary TBP's inside sym_root could be as they are at the moment, the operators would have to be handled some other way (because sym_root has a special position in the API functions at the moment); I don't like to have this distinction between type-bound procedures and operators, as they are nearly the same from the implementation point of view.

Addressing these points and preparing for type-bound operators, I reworked the type-bound procedures implementation; see the gfortran.h and documentation changes for an overview.

Most of the changes were simply mechanical after the changes to gfc_symtree and gfc_namespace, but there were also some more delicate things to do. For instance, as now the tentative-symbol handling does no longer handle type-bound procedures as well (which was in any case a more-or-less lucky issue that it did so well at all!), I implemented my own list of tentative TBP's and mark those dropped as erraneous, so that the compiler gets not confused about them later.

I believe that those changes are worthwhile and make the code cleaner and more robust as well as make it easier to implement type-bound operators based on this now. But I would like to get some second opinions and fresh thoughts!

Currently running a regression-test on GNU/Linux-x86-32. Ok for trunk if successful? Or should we go for fortran-dev instead first?

Cheers,
Daniel

--
Done:  Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri
2009-04-08  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-08  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).
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 145499)
+++ gcc/fortran/symbol.c	(working copy)
@@ -102,6 +102,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
@@ -2186,6 +2198,7 @@ gfc_get_namespace (gfc_namespace *parent
   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;
@@ -2253,7 +2266,6 @@ gfc_new_symtree (gfc_symtree **root, con
 
   st = XCNEW (gfc_symtree);
   st->name = gfc_get_string (name);
-  st->typebound = NULL;
 
   gfc_insert_bbt (root, st, compare_symtree);
   return st;
@@ -2686,6 +2698,7 @@ void
 gfc_undo_symbols (void)
 {
   gfc_symbol *p, *q, *old;
+  tentative_tbp *tbp, *tbq;
 
   for (p = changed_syms; p; p = q)
     {
@@ -2784,6 +2797,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;
 }
 
 
@@ -2821,6 +2842,7 @@ void
 gfc_commit_symbols (void)
 {
   gfc_symbol *p, *q;
+  tentative_tbp *tbp, *tbq;
 
   for (p = changed_syms; p; p = q)
     {
@@ -2831,6 +2853,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;
 }
 
 
@@ -2862,6 +2892,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.  */
 
@@ -3050,6 +3098,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);
@@ -4281,6 +4330,27 @@ gfc_check_symbol_typed (gfc_symbol* sym,
 }
 
 
+/* 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*
@@ -4312,15 +4382,15 @@ gfc_find_typebound_proc (gfc_symbol* der
 
   /* 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)
@@ -4342,3 +4412,24 @@ gfc_find_typebound_proc (gfc_symbol* der
   /* 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;
+}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 145499)
+++ gcc/fortran/decl.c	(working copy)
@@ -7032,8 +7032,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);
@@ -7041,12 +7041,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;
 }
@@ -7101,10 +7106,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",
@@ -7112,7 +7120,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"
@@ -7122,10 +7129,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;
@@ -7147,20 +7154,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;
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c	(revision 145499)
+++ gcc/fortran/dump-parse-tree.c	(working copy)
@@ -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
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 145499)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1045,8 +1045,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
@@ -1211,11 +1209,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;
 
@@ -1244,6 +1240,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;
 
@@ -2366,8 +2365,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 copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
 
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 145499)
+++ gcc/fortran/module.c	(working copy)
@@ -3251,12 +3251,14 @@ mio_typebound_proc (gfc_typebound_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**
 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);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 145499)
+++ gcc/fortran/resolve.c	(working copy)
@@ -8250,22 +8250,22 @@ check_typebound_override (gfc_symtree* p
   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);
@@ -8273,7 +8273,7 @@ check_typebound_override (gfc_symtree* p
     }
 
   /* 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);
@@ -8337,8 +8337,8 @@ check_typebound_override (gfc_symtree* p
 
   /* 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);
@@ -8350,20 +8350,20 @@ check_typebound_override (gfc_symtree* p
      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.  */
@@ -8399,7 +8399,7 @@ check_typebound_override (gfc_symtree* p
 
   /* 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);
@@ -8408,9 +8408,9 @@ check_typebound_override (gfc_symtree* p
 
   /* 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);
@@ -8479,26 +8479,26 @@ resolve_typebound_generic (gfc_symbol* d
   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;
@@ -8508,9 +8508,9 @@ resolve_typebound_generic (gfc_symbol* d
 	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;
 	  }
 
@@ -8522,8 +8522,8 @@ resolve_typebound_generic (gfc_symbol* d
 
 	    if (inherited)
 	      {
-		gcc_assert (inherited->typebound);
-		target->specific = inherited->typebound;
+		gcc_assert (inherited->n.tb);
+		target->specific = inherited->n.tb;
 		goto specific_found;
 	      }
 	  }
@@ -8546,14 +8546,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)
 	    {
@@ -8568,7 +8568,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);
@@ -8577,9 +8577,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;
 }
@@ -8599,12 +8600,17 @@ resolve_typebound_procedure (gfc_symtree
   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)
@@ -8613,27 +8619,27 @@ resolve_typebound_procedure (gfc_symtree
     }
 
   /* 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
@@ -8642,9 +8648,9 @@ resolve_typebound_procedure (gfc_symtree
 
   /* 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;
 
@@ -8652,23 +8658,23 @@ resolve_typebound_procedure (gfc_symtree
 	     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;
 	    }
 	}
@@ -8676,7 +8682,7 @@ resolve_typebound_procedure (gfc_symtree
 	{
 	  /* 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"
@@ -8704,15 +8710,15 @@ resolve_typebound_procedure (gfc_symtree
 
   /* 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;
@@ -8737,23 +8743,23 @@ resolve_typebound_procedure (gfc_symtree
       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;
@@ -8795,12 +8801,12 @@ ensure_not_abstract_walker (gfc_symbol* 
   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",
@@ -8828,7 +8834,7 @@ ensure_not_abstract (gfc_symbol* sub, gf
   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;
     }
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 145499)
+++ gcc/fortran/primary.c	(working copy)
@@ -1777,19 +1777,19 @@ gfc_match_varspec (gfc_expr *primary, in
 	  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;
@@ -1804,8 +1804,6 @@ gfc_match_varspec (gfc_expr *primary, in
 		}
 	    }
 
-	  gfc_set_sym_referenced (tbp->n.sym);
-
 	  break;
 	}
 
Index: gcc/fortran/gfc-internals.texi
===================================================================
--- gcc/fortran/gfc-internals.texi	(revision 145499)
+++ gcc/fortran/gfc-internals.texi	(working copy)
@@ -577,15 +577,14 @@ substring reference as described in the 
 @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}
Index: gcc/testsuite/gfortran.dg/typebound_generic_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_1.f03	(revision 145499)
+++ gcc/testsuite/gfortran.dg/typebound_generic_1.f03	(working copy)
@@ -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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]