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

[thirdparty/gcc.git] / gcc / fortran / symbol.c

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6aa63bebabe02b56c41eebd1af26b2c23e616444..a82e67558fb29c9c63d3e5c5250298c0b4e20e2e 100644 (file)
--- 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;
+}