dump-parse-tree.c

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

/* Show symbol attributes.  The flavor and intent are followed by
   whatever single bit attributes are present.  */

static void
gfc_show_attr (symbol_attribute * attr)
{

  gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
	      gfc_intent_string (attr->intent),
	      gfc_code2string (access_types, attr->access),
	      gfc_code2string (procedures, attr->proc));

  if (attr->allocatable)
    gfc_status (" ALLOCATABLE");
  if (attr->dimension)
    gfc_status (" DIMENSION");
  if (attr->external)
    gfc_status (" EXTERNAL");
  if (attr->intrinsic)
    gfc_status (" INTRINSIC");
  if (attr->optional)
    gfc_status (" OPTIONAL");
  if (attr->pointer)
    gfc_status (" POINTER");
  if (attr->save)
    gfc_status (" SAVE");
  if (attr->target)
    gfc_status (" TARGET");
  if (attr->dummy)
    gfc_status (" DUMMY");
  if (attr->result)
    gfc_status (" RESULT");
  if (attr->entry)
    gfc_status (" ENTRY");

  if (attr->data)
    gfc_status (" DATA");
  if (attr->use_assoc)
    gfc_status (" USE-ASSOC");
  if (attr->in_namelist)
    gfc_status (" IN-NAMELIST");
  if (attr->in_common)
    gfc_status (" IN-COMMON");

  if (attr->function)
    gfc_status (" FUNCTION");
  if (attr->subroutine)
    gfc_status (" SUBROUTINE");
  if (attr->implicit_type)
    gfc_status (" IMPLICIT-TYPE");

  if (attr->sequence)
    gfc_status (" SEQUENCE");
  if (attr->elemental)
    gfc_status (" ELEMENTAL");
  if (attr->pure)
    gfc_status (" PURE");
  if (attr->recursive)
    gfc_status (" RECURSIVE");

  gfc_status (")");
}


/* Show components of a derived type.  */

static void
gfc_show_components (gfc_symbol * sym)
{
  gfc_component *c;

  for (c = sym->components; c; c = c->next)
    {
      gfc_status ("(%s ", c->name);
      gfc_show_typespec (&c->ts);
      if (c->pointer)
	gfc_status (" POINTER");
      if (c->dimension)
	gfc_status (" DIMENSION");
      gfc_status_char (' ');
      gfc_show_array_spec (c->as);
      gfc_status (")");
      if (c->next != NULL)
	gfc_status_char (' ');
    }
}


/* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
   show the interface.  Information needed to reconstruct the list of
   specific interfaces associated with a generic symbol is done within
   that symbol.  */

static void
gfc_show_symbol (gfc_symbol * sym)
{
  gfc_formal_arglist *formal;
  gfc_interface *intr;

  if (sym == NULL)
    return;

  show_indent ();

  gfc_status ("symbol %s ", sym->name);
  gfc_show_typespec (&sym->ts);
  gfc_show_attr (&sym->attr);

  if (sym->value)
    {
      show_indent ();
      gfc_status ("value: ");
      gfc_show_expr (sym->value);
    }

  if (sym->as)
    {
      show_indent ();
      gfc_status ("Array spec:");
      gfc_show_array_spec (sym->as);
    }

  if (sym->generic)
    {
      show_indent ();
      gfc_status ("Generic interfaces:");
      for (intr = sym->generic; intr; intr = intr->next)
	gfc_status (" %s", intr->sym->name);
    }

  if (sym->result)
    {
      show_indent ();
      gfc_status ("result: %s", sym->result->name);
    }

  if (sym->components)
    {
      show_indent ();
      gfc_status ("components: ");
      gfc_show_components (sym);
    }

  if (sym->formal)
    {
      show_indent ();
      gfc_status ("Formal arglist:");

      for (formal = sym->formal; formal; formal = formal->next)
        {
          if (formal->sym != NULL)
            gfc_status (" %s", formal->sym->name);
          else
            gfc_status (" [Alt Return]");
        }
    }

  if (sym->formal_ns)
    {
      show_indent ();
      gfc_status ("Formal namespace");
      gfc_show_namespace (sym->formal_ns);
    }

  gfc_status_char ('\n');
}


/* Show a user-defined operator.  Just prints an operator
   and the name of the associated subroutine, really.  */

static void
show_uop (gfc_user_op * uop)
{
  gfc_interface *intr;

  show_indent ();
  gfc_status ("%s:", uop->name);

  for (intr = uop->operator; intr; intr = intr->next)
    gfc_status (" %s", intr->sym->name);
}


/* Workhorse function for traversing the user operator symtree.  */

static void
traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
{

  if (st == NULL)
    return;

  (*func) (st->n.uop);

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


/* Traverse the tree of user operator nodes.  */

void
gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
{

  traverse_uop (ns->uop_root, func);
}


/* Function to display a common block.  */

static void
show_common (gfc_symtree * st)
{
  gfc_symbol *s;

  show_indent ();
  gfc_status ("common: /%s/ ", st->name);

  s = st->n.common->head;
  while (s)
    {
      gfc_status ("%s", s->name);
      s = s->common_next;
      if (s)
	gfc_status (", ");
    }
  gfc_status_char ('\n');
}    


/* Worker function to display the symbol tree.  */

static void
show_symtree (gfc_symtree * st)
{

  show_indent ();
  gfc_status ("symtree: %s  Ambig %d", st->name, st->ambiguous);

  if (st->n.sym->ns != gfc_current_ns)
    gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
  else
    gfc_show_symbol (st->n.sym);
}


/******************* Show gfc_code structures **************/



static void gfc_show_code_node (int level, gfc_code * c);

/* Show a list of code structures.  Mutually recursive with
   gfc_show_code_node().  */

static void
gfc_show_code (int level, gfc_code * c)
{

  for (; c; c = c->next)
    gfc_show_code_node (level, c);
}


/* Show a single code node and everything underneath it if necessary.  */

static void
gfc_show_code_node (int level, gfc_code * c)
{
  gfc_forall_iterator *fa;
  gfc_open *open;
  gfc_case *cp;
  gfc_alloc *a;
  gfc_code *d;
  gfc_close *close;
  gfc_filepos *fp;
  gfc_inquire *i;
  gfc_dt *dt;

  code_indent (level, c->here);

  switch (c->op)
    {
    case EXEC_NOP:
      gfc_status ("NOP");
      break;

    case EXEC_CONTINUE:
      gfc_status ("CONTINUE");
      break;

    case EXEC_ENTRY:
      gfc_status ("ENTRY %s", c->ext.entry->sym->name);
      break;

    case EXEC_ASSIGN:
      gfc_status ("ASSIGN ");
      gfc_show_expr (c->expr);
      gfc_status_char (' ');
      gfc_show_expr (c->expr2);
      break;

    case EXEC_LABEL_ASSIGN:
      gfc_status ("LABEL ASSIGN ");
      gfc_show_expr (c->expr);
      gfc_status (" %d", c->label->value);
      break;

    case EXEC_POINTER_ASSIGN:
      gfc_status ("POINTER ASSIGN ");
      gfc_show_expr (c->expr);
      gfc_status_char (' ');
      gfc_show_expr (c->expr2);
      break;

    case EXEC_GOTO:
      gfc_status ("GOTO ");
      if (c->label)
        gfc_status ("%d", c->label->value);
      else
        {
          gfc_show_expr (c->expr);
          d = c->block;
          if (d != NULL)
            {
              gfc_status (", (");
              for (; d; d = d ->block)
                {
                  code_indent (level, d->label);
                  if (d->block != NULL)
                    gfc_status_char (',');
                  else
                    gfc_status_char (')');
                }
            }
        }
      break;

    case EXEC_CALL:
      gfc_status ("CALL %s ", c->resolved_sym->name);
      gfc_show_actual_arglist (c->ext.actual);
      break;

    case EXEC_RETURN:
      gfc_status ("RETURN ");
      if (c->expr)
	gfc_show_expr (c->expr);
      break;

    case EXEC_PAUSE:
      gfc_status ("PAUSE ");

      if (c->expr != NULL)
        gfc_show_expr (c->expr);
      else
        gfc_status ("%d", c->ext.stop_code);

      break;

    case EXEC_STOP:
      gfc_status ("STOP ");

      if (c->expr != NULL)
        gfc_show_expr (c->expr);
      else
        gfc_status ("%d", c->ext.stop_code);

      break;

    case EXEC_ARITHMETIC_IF:
      gfc_status ("IF ");
      gfc_show_expr (c->expr);
      gfc_status (" %d, %d, %d",
		  c->label->value, c->label2->value, c->label3->value);
      break;

    case EXEC_IF:
      d = c->block;
      gfc_status ("IF ");
      gfc_show_expr (d->expr);
      gfc_status_char ('\n');
      gfc_show_code (level + 1, d->next);

      d = d->block;
      for (; d; d = d->block)
	{
	  code_indent (level, 0);

	  if (d->expr == NULL)
	    gfc_status ("ELSE\n");
	  else
	    {
	      gfc_status ("ELSE IF ");
	      gfc_show_expr (d->expr);
	      gfc_status_char ('\n');
	    }

	  gfc_show_code (level + 1, d->next);
	}

      code_indent (level, c->label);

      gfc_status ("ENDIF");
      break;

    case EXEC_SELECT:
      d = c->block;
      gfc_status ("SELECT CASE ");
      gfc_show_expr (c->expr);
      gfc_status_char ('\n');

      for (; d; d = d->block)
	{
	  code_indent (level, 0);

	  gfc_status ("CASE ");
	  for (cp = d->ext.case_list; cp; cp = cp->next)
	    {
	      gfc_status_char ('(');
	      gfc_show_expr (cp->low);
	      gfc_status_char (' ');
	      gfc_show_expr (cp->high);
	      gfc_status_char (')');
	      gfc_status_char (' ');
	    }
	  gfc_status_char ('\n');

	  gfc_show_code (level + 1, d->next);
	}

      code_indent (level, c->label);
      gfc_status ("END SELECT");
      break;

    case EXEC_WHERE:
      gfc_status ("WHERE ");

      d = c->block;
      gfc_show_expr (d->expr);
      gfc_status_char ('\n');

      gfc_show_code (level + 1, d->next);

      for (d = d->block; d; d = d->block)
	{
	  code_indent (level, 0);
	  gfc_status ("ELSE WHERE ");
	  gfc_show_expr (d->expr);
	  gfc_status_char ('\n');
	  gfc_show_code (level + 1, d->next);
	}

      code_indent (level, 0);
      gfc_status ("END WHERE");
      break;


    case EXEC_FORALL:
      gfc_status ("FORALL ");
      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
	{
	  gfc_show_expr (fa->var);
	  gfc_status_char (' ');
	  gfc_show_expr (fa->start);
	  gfc_status_char (':');
	  gfc_show_expr (fa->end);
	  gfc_status_char (':');
	  gfc_show_expr (fa->stride);

	  if (fa->next != NULL)
	    gfc_status_char (',');
	}

      if (c->expr != NULL)
	{
	  gfc_status_char (',');
	  gfc_show_expr (c->expr);
	}
      gfc_status_char ('\n');

      gfc_show_code (level + 1, c->block->next);

      code_indent (level, 0);
      gfc_status ("END FORALL");
      break;

    case EXEC_DO:
      gfc_status ("DO ");

      gfc_show_expr (c->ext.iterator->var);
      gfc_status_char ('=');
      gfc_show_expr (c->ext.iterator->start);
      gfc_status_char (' ');
      gfc_show_expr (c->ext.iterator->end);
      gfc_status_char (' ');
      gfc_show_expr (c->ext.iterator->step);
      gfc_status_char ('\n');

      gfc_show_code (level + 1, c->block->next);

      code_indent (level, 0);
      gfc_status ("END DO");
      break;

    case EXEC_DO_WHILE:
      gfc_status ("DO WHILE ");
      gfc_show_expr (c->expr);
      gfc_status_char ('\n');

      gfc_show_code (level + 1, c->block->next);

      code_indent (level, c->label);
      gfc_status ("END DO");
      break;

    case EXEC_CYCLE:
      gfc_status ("CYCLE");
      if (c->symtree)
	gfc_status (" %s", c->symtree->n.sym->name);