symbol.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

   The integer return code indicates
     0   All OK
     1   The symbol name was ambiguous
     2   The name meant to be established was already host associated.

   So if the return value is nonzero, then an error was issued.  */

int
gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result)
{
  gfc_symtree *st;
  gfc_symbol *p;

  /* This doesn't usually happen during resolution.  */
  if (ns == NULL)
    ns = gfc_current_ns;

  /* Try to find the symbol in ns.  */
  st = gfc_find_symtree (ns->sym_root, name);

  if (st == NULL)
    {
      /* If not there, create a new symbol.  */
      p = gfc_new_symbol (name, ns);

      /* Add to the list of tentative symbols.  */
      p->old_symbol = NULL;
      p->tlink = changed_syms;
      p->mark = 1;
      p->new = 1;
      changed_syms = p;

      st = gfc_new_symtree (&ns->sym_root, name);
      st->n.sym = p;
      p->refs++;

    }
  else
    {
      /* Make sure the existing symbol is OK.  */
      if (st->ambiguous)
	{
	  ambiguous_symbol (name, st);
	  return 1;
	}

      p = st->n.sym;

      if (p->ns != ns && (!p->attr.function || ns->proc_name != p))
	{
	  /* Symbol is from another namespace.  */
	  gfc_error ("Symbol '%s' at %C has already been host associated",
		     name);
	  return 2;
	}

      p->mark = 1;

      /* Copy in case this symbol is changed.  */
      save_symbol_data (p);
    }

  *result = st;
  return 0;
}


int
gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result)
{
  gfc_symtree *st;
  int i;


  i = gfc_get_sym_tree (name, ns, &st);
  if (i != 0)
    return i;

  if (st)
    *result = st->n.sym;
  else
    *result = NULL;
  return i;
}


/* Subroutine that searches for a symbol, creating it if it doesn't
   exist, but tries to host-associate the symbol if possible.  */

int
gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result)
{
  gfc_symtree *st;
  int i;

  i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
  if (st != NULL)
    {
      save_symbol_data (st->n.sym);

      *result = st;
      return i;
    }

  if (gfc_current_ns->parent != NULL)
    {
      i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
      if (i)
	return i;

      if (st != NULL)
	{
	  *result = st;
	  return 0;
	}
    }

  return gfc_get_sym_tree (name, gfc_current_ns, result);
}


int
gfc_get_ha_symbol (const char *name, gfc_symbol ** result)
{
  int i;
  gfc_symtree *st;

  i = gfc_get_ha_sym_tree (name, &st);

  if (st)
    *result = st->n.sym;
  else
    *result = NULL;

  return i;
}

/* Return true if both symbols could refer to the same data object.  Does
   not take account of aliasing due to equivalence statements.  */

int
gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym)
{
  /* Aliasing isn't possible if the symbols have different base types.  */
  if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
    return 0;

  /* Pointers can point to other pointers, target objects and allocatable
     objects.  Two allocatable objects cannot share the same storage.  */
  if (lsym->attr.pointer
      && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
    return 1;
  if (lsym->attr.target && rsym->attr.pointer)
    return 1;
  if (lsym->attr.allocatable && rsym->attr.pointer)
    return 1;

  return 0;
}


/* Undoes all the changes made to symbols in the current statement.
   This subroutine is made simpler due to the fact that attributes are
   never removed once added.  */

void
gfc_undo_symbols (void)
{
  gfc_symbol *p, *q, *old;

  for (p = changed_syms; p; p = q)
    {
      q = p->tlink;

      if (p->new)
	{
	  /* Symbol was new.  */
	  delete_symtree (&p->ns->sym_root, p->name);

	  p->refs--;
	  if (p->refs < 0)
	    gfc_internal_error ("gfc_undo_symbols(): Negative refs");
	  if (p->refs == 0)
	    gfc_free_symbol (p);
	  continue;
	}

      /* Restore previous state of symbol.  Just copy simple stuff.  */
      p->mark = 0;
      old = p->old_symbol;

      p->ts.type = old->ts.type;
      p->ts.kind = old->ts.kind;

      p->attr = old->attr;

      if (p->value != old->value)
	{
	  gfc_free_expr (old->value);
	  p->value = NULL;
	}

      if (p->as != old->as)
	{
	  if (p->as)
	    gfc_free_array_spec (p->as);
	  p->as = old->as;
	}

      p->generic = old->generic;
      p->component_access = old->component_access;

      if (p->namelist != NULL && old->namelist == NULL)
	{
	  gfc_free_namelist (p->namelist);
	  p->namelist = NULL;
	}
      else
	{

	  if (p->namelist_tail != old->namelist_tail)
	    {
	      gfc_free_namelist (old->namelist_tail);
	      old->namelist_tail->next = NULL;
	    }
	}

      p->namelist_tail = old->namelist_tail;

      if (p->formal != old->formal)
	{
	  gfc_free_formal_arglist (p->formal);
	  p->formal = old->formal;
	}

      gfc_free (p->old_symbol);
      p->old_symbol = NULL;
      p->tlink = NULL;
    }

  changed_syms = NULL;
}


/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
   components of old_symbol that might need deallocation are the "allocatables"
   that are restored in gfc_undo_symbols(), with two exceptions: namelist and
   namelist_tail.  In case these differ between old_symbol and sym, it's just
   because sym->namelist has gotten a few more items.  */

static void
free_old_symbol (gfc_symbol * sym)
{
  if (sym->old_symbol == NULL)
    return;

  if (sym->old_symbol->as != sym->as) 
    gfc_free_array_spec (sym->old_symbol->as);

  if (sym->old_symbol->value != sym->value) 
    gfc_free_expr (sym->old_symbol->value);

  if (sym->old_symbol->formal != sym->formal)
    gfc_free_formal_arglist (sym->old_symbol->formal);

  gfc_free (sym->old_symbol);
  sym->old_symbol = NULL;
}


/* Makes the changes made in the current statement permanent-- gets
   rid of undo information.  */

void
gfc_commit_symbols (void)
{
  gfc_symbol *p, *q;

  for (p = changed_syms; p; p = q)
    {
      q = p->tlink;
      p->tlink = NULL;
      p->mark = 0;
      p->new = 0;

      free_old_symbol (p);
    }
  changed_syms = NULL;
}


/* Makes the changes made in one symbol permanent -- gets rid of undo
   information.  */

void
gfc_commit_symbol (gfc_symbol * sym)
{
  gfc_symbol *p;

  if (changed_syms == sym)
    changed_syms = sym->tlink;
  else
    {
      for (p = changed_syms; p; p = p->tlink)
        if (p->tlink == sym)
          {
            p->tlink = sym->tlink;
            break;
          }
    }

  sym->tlink = NULL;
  sym->mark = 0;
  sym->new = 0;

  free_old_symbol (sym);
}


/* Recursive function that deletes an entire tree and all the common
   head structures it points to.  */

static void
free_common_tree (gfc_symtree * common_tree)
{
  if (common_tree == NULL)
    return;

  free_common_tree (common_tree->left);
  free_common_tree (common_tree->right);

  gfc_free (common_tree);
}  


/* Recursive function that deletes an entire tree and all the user
   operator nodes that it contains.  */

static void
free_uop_tree (gfc_symtree * uop_tree)
{

  if (uop_tree == NULL)
    return;

  free_uop_tree (uop_tree->left);
  free_uop_tree (uop_tree->right);

  gfc_free_interface (uop_tree->n.uop->operator);

  gfc_free (uop_tree->n.uop);
  gfc_free (uop_tree);
}


/* Recursive function that deletes an entire tree and all the symbols
   that it contains.  */

static void
free_sym_tree (gfc_symtree * sym_tree)
{
  gfc_namespace *ns;
  gfc_symbol *sym;

  if (sym_tree == NULL)
    return;

  free_sym_tree (sym_tree->left);
  free_sym_tree (sym_tree->right);

  sym = sym_tree->n.sym;

  sym->refs--;
  if (sym->refs < 0)
    gfc_internal_error ("free_sym_tree(): Negative refs");

  if (sym->formal_ns != NULL && sym->refs == 1)
    {
      /* As formal_ns contains a reference to sym, delete formal_ns just
         before the deletion of sym.  */
      ns = sym->formal_ns;
      sym->formal_ns = NULL;
      gfc_free_namespace (ns);
    }
  else if (sym->refs == 0)
    {
      /* Go ahead and delete the symbol.  */
      gfc_free_symbol (sym);
    }

  gfc_free (sym_tree);
}


/* Free a derived type list.  */

static void
gfc_free_dt_list (gfc_dt_list * dt)
{
  gfc_dt_list *n;

  for (; dt; dt = n)
    {
      n = dt->next;
      gfc_free (dt);
    }
}


/* Free a namespace structure and everything below it.  Interface
   lists associated with intrinsic operators are not freed.  These are
   taken care of when a specific name is freed.  */

void
gfc_free_namespace (gfc_namespace * ns)
{
  gfc_charlen *cl, *cl2;
  gfc_namespace *p, *q;
  gfc_intrinsic_op i;

  if (ns == NULL)
    return;

  ns->refs--;
  if (ns->refs > 0)
    return;
  gcc_assert (ns->refs == 0);

  gfc_free_statements (ns->code);

  free_sym_tree (ns->sym_root);
  free_uop_tree (ns->uop_root);
  free_common_tree (ns->common_root);

  for (cl = ns->cl_list; cl; cl = cl2)
    {
      cl2 = cl->next;
      gfc_free_expr (cl->length);
      gfc_free (cl);
    }

  free_st_labels (ns->st_labels);

  gfc_free_equiv (ns->equiv);

  gfc_free_dt_list (ns->derived_types);

  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    gfc_free_interface (ns->operator[i]);

  gfc_free_data (ns->data);
  p = ns->contained;
  gfc_free (ns);

  /* Recursively free any contained namespaces.  */
  while (p != NULL)
    {
      q = p;
      p = p->sibling;

      gfc_free_namespace (q);
    }
}


void
gfc_symbol_init_2 (void)
{

  gfc_current_ns = gfc_get_namespace (NULL, 0);
}


void
gfc_symbol_done_2 (void)
{

  gfc_free_namespace (gfc_current_ns);
  gfc_current_ns = NULL;
}


/* Clear mark bits from symbol nodes associated with a symtree node.  */

static void
clear_sym_mark (gfc_symtree * st)
{

  st->n.sym->mark = 0;
}


/* Recursively traverse the symtree nodes.  */

void
gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *))
{
  if (st != NULL)
    {
      (*func) (st);

      gfc_traverse_symtree (st->left, func);
      gfc_traverse_symtree (st->right, func);
    }
}


/* Recursive namespace traversal function.  */

static void
traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *))
{

  if (st == NULL)
    return;

  if (st->n.sym->mark == 0)
    (*func) (st->n.sym);
  st->n.sym->mark = 1;

  traverse_ns (st->left, func);
  traverse_ns (st->right, func);
}


/* Call a given function for all symbols in the namespace.  We take
   care that each gfc_symbol node is called exactly once.  */

void
gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *))
{

  gfc_traverse_symtree (ns->sym_root, clear_sym_mark);

  traverse_ns (ns->sym_root, func);
}


/* Return TRUE if the symbol is an automatic variable.  */
static bool
gfc_is_var_automatic (gfc_symbol * sym)
{
  /* Pointer and allocatable variables are never automatic.  */
  if (sym->attr.pointer || sym->attr.allocatable)
    return false;
  /* Check for arrays with non-constant size.  */
  if (sym->attr.dimension && sym->as
      && !gfc_is_compile_time_shape (sym->as))
    return true;
  /* Check for non-constant length character variables.  */
  if (sym->ts.type == BT_CHARACTER
      && sym->ts.cl
      && !gfc_is_constant_expr (sym->ts.cl->length))
    return true;
  return false;
}

/* Given a symbol, mark it as SAVEd if it is allowed.  */

static void
save_symbol (gfc_symbol * sym)
{

  if (sym->attr.use_assoc)
    return;

  if (sym->attr.in_common
      || sym->attr.dummy
      || sym->attr.flavor != FL_VARIABLE)
    return;
  /* Automatic objects are not saved.  */
  if (gfc_is_var_automatic (sym))
    return;
  gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
}


/* Mark those symbols which can be SAVEd as such.  */

void
gfc_save_all (gfc_namespace * ns)
{

  gfc_traverse_ns (ns, save_symbol);
}


#ifdef GFC_DEBUG
/* Make sure that no changes to symbols are pending.  */

void
gfc_symbol_state(void) {

  if (changed_syms != NULL)
    gfc_internal_error("Symbol changes still pending!");
}
#endif


/************** Global symbol handling ************/


/* Search a tree for the global symbol.  */

gfc_gsymbol *
gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
{
  gfc_gsymbol *s;

  if (symbol == NULL)
    return NULL;
  if (strcmp (symbol->name, name) == 0)
    return symbol;

  s = gfc_find_gsymbol (symbol->left, name);
  if (s != NULL)
    return s;

  s = gfc_find_gsymbol (symbol->right, name);
  if (s != NULL)
    return s;

  return NULL;
}


/* Compare two global symbols. Used for managing the BB tree.  */

static int
gsym_compare (void * _s1, void * _s2)
{
  gfc_gsymbol *s1, *s2;

  s1 = (gfc_gsymbol *)_s1;
  s2 = (gfc_gsymbol *)_s2;
  return strcmp(s1->name, s2->name);
}


/* Get a global symbol, creating it if it doesn't exist.  */

gfc_gsymbol *
gfc_get_gsymbol (const char *name)
{
  gfc_gsymbol *s;

  s = gfc_find_gsymbol (gfc_gsym_root, name);
  if (s != NULL)
    return s;

  s = gfc_getmem (sizeof (gfc_gsymbol));
  s->type = GSYM_UNKNOWN;
  s->name = gfc_get_string (name);

  gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);

  return s;
}