dump-parse-tree.c

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

      break;

    case EXEC_EXIT:
      gfc_status ("EXIT");
      if (c->symtree)
	gfc_status (" %s", c->symtree->n.sym->name);
      break;

    case EXEC_ALLOCATE:
      gfc_status ("ALLOCATE ");
      if (c->expr)
	{
	  gfc_status (" STAT=");
	  gfc_show_expr (c->expr);
	}

      for (a = c->ext.alloc_list; a; a = a->next)
	{
	  gfc_status_char (' ');
	  gfc_show_expr (a->expr);
	}

      break;

    case EXEC_DEALLOCATE:
      gfc_status ("DEALLOCATE ");
      if (c->expr)
	{
	  gfc_status (" STAT=");
	  gfc_show_expr (c->expr);
	}

      for (a = c->ext.alloc_list; a; a = a->next)
	{
	  gfc_status_char (' ');
	  gfc_show_expr (a->expr);
	}

      break;

    case EXEC_OPEN:
      gfc_status ("OPEN");
      open = c->ext.open;

      if (open->unit)
	{
	  gfc_status (" UNIT=");
	  gfc_show_expr (open->unit);
	}
      if (open->iomsg)
	{
	  gfc_status (" IOMSG=");
	  gfc_show_expr (open->iomsg);
	}
      if (open->iostat)
	{
	  gfc_status (" IOSTAT=");
	  gfc_show_expr (open->iostat);
	}
      if (open->file)
	{
	  gfc_status (" FILE=");
	  gfc_show_expr (open->file);
	}
      if (open->status)
	{
	  gfc_status (" STATUS=");
	  gfc_show_expr (open->status);
	}
      if (open->access)
	{
	  gfc_status (" ACCESS=");
	  gfc_show_expr (open->access);
	}
      if (open->form)
	{
	  gfc_status (" FORM=");
	  gfc_show_expr (open->form);
	}
      if (open->recl)
	{
	  gfc_status (" RECL=");
	  gfc_show_expr (open->recl);
	}
      if (open->blank)
	{
	  gfc_status (" BLANK=");
	  gfc_show_expr (open->blank);
	}
      if (open->position)
	{
	  gfc_status (" POSITION=");
	  gfc_show_expr (open->position);
	}
      if (open->action)
	{
	  gfc_status (" ACTION=");
	  gfc_show_expr (open->action);
	}
      if (open->delim)
	{
	  gfc_status (" DELIM=");
	  gfc_show_expr (open->delim);
	}
      if (open->pad)
	{
	  gfc_status (" PAD=");
	  gfc_show_expr (open->pad);
	}
      if (open->convert)
	{
	  gfc_status (" CONVERT=");
	  gfc_show_expr (open->convert);
	}
      if (open->err != NULL)
	gfc_status (" ERR=%d", open->err->value);

      break;

    case EXEC_CLOSE:
      gfc_status ("CLOSE");
      close = c->ext.close;

      if (close->unit)
	{
	  gfc_status (" UNIT=");
	  gfc_show_expr (close->unit);
	}
      if (close->iomsg)
	{
	  gfc_status (" IOMSG=");
	  gfc_show_expr (close->iomsg);
	}
      if (close->iostat)
	{
	  gfc_status (" IOSTAT=");
	  gfc_show_expr (close->iostat);
	}
      if (close->status)
	{
	  gfc_status (" STATUS=");
	  gfc_show_expr (close->status);
	}
      if (close->err != NULL)
	gfc_status (" ERR=%d", close->err->value);
      break;

    case EXEC_BACKSPACE:
      gfc_status ("BACKSPACE");
      goto show_filepos;

    case EXEC_ENDFILE:
      gfc_status ("ENDFILE");
      goto show_filepos;

    case EXEC_REWIND:
      gfc_status ("REWIND");
      goto show_filepos;

    case EXEC_FLUSH:
      gfc_status ("FLUSH");

    show_filepos:
      fp = c->ext.filepos;

      if (fp->unit)
	{
	  gfc_status (" UNIT=");
	  gfc_show_expr (fp->unit);
	}
      if (fp->iomsg)
	{
	  gfc_status (" IOMSG=");
	  gfc_show_expr (fp->iomsg);
	}
      if (fp->iostat)
	{
	  gfc_status (" IOSTAT=");
	  gfc_show_expr (fp->iostat);
	}
      if (fp->err != NULL)
	gfc_status (" ERR=%d", fp->err->value);
      break;

    case EXEC_INQUIRE:
      gfc_status ("INQUIRE");
      i = c->ext.inquire;

      if (i->unit)
	{
	  gfc_status (" UNIT=");
	  gfc_show_expr (i->unit);
	}
      if (i->file)
	{
	  gfc_status (" FILE=");
	  gfc_show_expr (i->file);
	}

      if (i->iomsg)
	{
	  gfc_status (" IOMSG=");
	  gfc_show_expr (i->iomsg);
	}
      if (i->iostat)
	{
	  gfc_status (" IOSTAT=");
	  gfc_show_expr (i->iostat);
	}
      if (i->exist)
	{
	  gfc_status (" EXIST=");
	  gfc_show_expr (i->exist);
	}
      if (i->opened)
	{
	  gfc_status (" OPENED=");
	  gfc_show_expr (i->opened);
	}
      if (i->number)
	{
	  gfc_status (" NUMBER=");
	  gfc_show_expr (i->number);
	}
      if (i->named)
	{
	  gfc_status (" NAMED=");
	  gfc_show_expr (i->named);
	}
      if (i->name)
	{
	  gfc_status (" NAME=");
	  gfc_show_expr (i->name);
	}
      if (i->access)
	{
	  gfc_status (" ACCESS=");
	  gfc_show_expr (i->access);
	}
      if (i->sequential)
	{
	  gfc_status (" SEQUENTIAL=");
	  gfc_show_expr (i->sequential);
	}

      if (i->direct)
	{
	  gfc_status (" DIRECT=");
	  gfc_show_expr (i->direct);
	}
      if (i->form)
	{
	  gfc_status (" FORM=");
	  gfc_show_expr (i->form);
	}
      if (i->formatted)
	{
	  gfc_status (" FORMATTED");
	  gfc_show_expr (i->formatted);
	}
      if (i->unformatted)
	{
	  gfc_status (" UNFORMATTED=");
	  gfc_show_expr (i->unformatted);
	}
      if (i->recl)
	{
	  gfc_status (" RECL=");
	  gfc_show_expr (i->recl);
	}
      if (i->nextrec)
	{
	  gfc_status (" NEXTREC=");
	  gfc_show_expr (i->nextrec);
	}
      if (i->blank)
	{
	  gfc_status (" BLANK=");
	  gfc_show_expr (i->blank);
	}
      if (i->position)
	{
	  gfc_status (" POSITION=");
	  gfc_show_expr (i->position);
	}
      if (i->action)
	{
	  gfc_status (" ACTION=");
	  gfc_show_expr (i->action);
	}
      if (i->read)
	{
	  gfc_status (" READ=");
	  gfc_show_expr (i->read);
	}
      if (i->write)
	{
	  gfc_status (" WRITE=");
	  gfc_show_expr (i->write);
	}
      if (i->readwrite)
	{
	  gfc_status (" READWRITE=");
	  gfc_show_expr (i->readwrite);
	}
      if (i->delim)
	{
	  gfc_status (" DELIM=");
	  gfc_show_expr (i->delim);
	}
      if (i->pad)
	{
	  gfc_status (" PAD=");
	  gfc_show_expr (i->pad);
	}
      if (i->convert)
	{
	  gfc_status (" CONVERT=");
	  gfc_show_expr (i->convert);
	}

      if (i->err != NULL)
	gfc_status (" ERR=%d", i->err->value);
      break;

    case EXEC_IOLENGTH:
      gfc_status ("IOLENGTH ");
      gfc_show_expr (c->expr);
      goto show_dt_code;
      break;

    case EXEC_READ:
      gfc_status ("READ");
      goto show_dt;

    case EXEC_WRITE:
      gfc_status ("WRITE");

    show_dt:
      dt = c->ext.dt;
      if (dt->io_unit)
	{
	  gfc_status (" UNIT=");
	  gfc_show_expr (dt->io_unit);
	}

      if (dt->format_expr)
	{
	  gfc_status (" FMT=");
	  gfc_show_expr (dt->format_expr);
	}

      if (dt->format_label != NULL)
	gfc_status (" FMT=%d", dt->format_label->value);
      if (dt->namelist)
	gfc_status (" NML=%s", dt->namelist->name);

      if (dt->iomsg)
	{
	  gfc_status (" IOMSG=");
	  gfc_show_expr (dt->iomsg);
	}
      if (dt->iostat)
	{
	  gfc_status (" IOSTAT=");
	  gfc_show_expr (dt->iostat);
	}
      if (dt->size)
	{
	  gfc_status (" SIZE=");
	  gfc_show_expr (dt->size);
	}
      if (dt->rec)
	{
	  gfc_status (" REC=");
	  gfc_show_expr (dt->rec);
	}
      if (dt->advance)
	{
	  gfc_status (" ADVANCE=");
	  gfc_show_expr (dt->advance);
	}

    show_dt_code:
      gfc_status_char ('\n');
      for (c = c->block->next; c; c = c->next)
	gfc_show_code_node (level + (c->next != NULL), c);
      return;

    case EXEC_TRANSFER:
      gfc_status ("TRANSFER ");
      gfc_show_expr (c->expr);
      break;

    case EXEC_DT_END:
      gfc_status ("DT_END");
      dt = c->ext.dt;

      if (dt->err != NULL)
	gfc_status (" ERR=%d", dt->err->value);
      if (dt->end != NULL)
	gfc_status (" END=%d", dt->end->value);
      if (dt->eor != NULL)
	gfc_status (" EOR=%d", dt->eor->value);
      break;

    default:
      gfc_internal_error ("gfc_show_code_node(): Bad statement code");
    }

  gfc_status_char ('\n');
}


/* Show an equivalence chain.  */

static void
gfc_show_equiv (gfc_equiv *eq)
{
  show_indent ();
  gfc_status ("Equivalence: ");
  while (eq)
    {
      gfc_show_expr (eq->expr);
      eq = eq->eq;
      if (eq)
	gfc_status (", ");
    }
}

    
/* Show a freakin' whole namespace.  */

void
gfc_show_namespace (gfc_namespace * ns)
{
  gfc_interface *intr;
  gfc_namespace *save;
  gfc_intrinsic_op op;
  gfc_equiv *eq;
  int i;

  save = gfc_current_ns;
  show_level++;

  show_indent ();
  gfc_status ("Namespace:");

  if (ns != NULL)
    {
      i = 0;
      do
	{
	  int l = i;
	  while (i < GFC_LETTERS - 1
		 && gfc_compare_types(&ns->default_type[i+1],
				      &ns->default_type[l]))
	    i++;

	  if (i > l)
	    gfc_status(" %c-%c: ", l+'A', i+'A');
	  else
	    gfc_status(" %c: ", l+'A');

	  gfc_show_typespec(&ns->default_type[l]);
	  i++;
      } while (i < GFC_LETTERS);

      if (ns->proc_name != NULL)
	{
	  show_indent ();
	  gfc_status ("procedure name = %s", ns->proc_name->name);
	}

      gfc_current_ns = ns;
      gfc_traverse_symtree (ns->common_root, show_common);

      gfc_traverse_symtree (ns->sym_root, show_symtree);

      for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
	{
	  /* User operator interfaces */
	  intr = ns->operator[op];
	  if (intr == NULL)
	    continue;

	  show_indent ();
	  gfc_status ("Operator interfaces for %s:", gfc_op2string (op));

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

      if (ns->uop_root != NULL)
	{
	  show_indent ();
	  gfc_status ("User operators:\n");
	  gfc_traverse_user_op (ns, show_uop);
	}
    }
  
  for (eq = ns->equiv; eq; eq = eq->next)
    gfc_show_equiv (eq);

  gfc_status_char ('\n');
  gfc_status_char ('\n');

  gfc_show_code (0, ns->code);

  for (ns = ns->contained; ns; ns = ns->sibling)
    {
      show_indent ();
      gfc_status ("CONTAINS\n");
      gfc_show_namespace (ns);
    }

  show_level--;
  gfc_status_char ('\n');
  gfc_current_ns = save;
}