/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
+/* The file handle we're dumping to is kept in a static variable. This
+ is not too cool, but it avoids a lot of passing it around. */
+static FILE *dumpfile;
+
+/* Forward declaration of some of the functions. */
+static void show_expr (gfc_expr *p);
+static void show_code_node (int, gfc_code *);
+static void show_namespace (gfc_namespace *ns);
+
+
/* Do indentation for a specific level. */
static inline void
int i;
if (label != NULL)
- gfc_status ("%-5d ", label->value);
+ fprintf (dumpfile, "%-5d ", label->value);
else
- gfc_status (" ");
+ fputs (" ", dumpfile);
for (i = 0; i < 2 * level; i++)
- gfc_status_char (' ');
+ fputc (' ', dumpfile);
}
static inline void
show_indent (void)
{
- gfc_status ("\n");
+ fputc ('\n', dumpfile);
code_indent (show_level, NULL);
}
/* Show type-specific information. */
-void
-gfc_show_typespec (gfc_typespec *ts)
+static void
+show_typespec (gfc_typespec *ts)
{
- gfc_status ("(%s ", gfc_basic_typename (ts->type));
+ fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
switch (ts->type)
{
case BT_DERIVED:
- gfc_status ("%s", ts->derived->name);
+ fprintf (dumpfile, "%s", ts->derived->name);
break;
case BT_CHARACTER:
- gfc_show_expr (ts->cl->length);
+ show_expr (ts->cl->length);
break;
default:
- gfc_status ("%d", ts->kind);
+ fprintf (dumpfile, "%d", ts->kind);
break;
}
- gfc_status (")");
+ fputc (')', dumpfile);
}
/* Show an actual argument list. */
-void
-gfc_show_actual_arglist (gfc_actual_arglist *a)
+static void
+show_actual_arglist (gfc_actual_arglist *a)
{
- gfc_status ("(");
+ fputc ('(', dumpfile);
for (; a; a = a->next)
{
- gfc_status_char ('(');
+ fputc ('(', dumpfile);
if (a->name != NULL)
- gfc_status ("%s = ", a->name);
+ fprintf (dumpfile, "%s = ", a->name);
if (a->expr != NULL)
- gfc_show_expr (a->expr);
+ show_expr (a->expr);
else
- gfc_status ("(arg not-present)");
+ fputs ("(arg not-present)", dumpfile);
- gfc_status_char (')');
+ fputc (')', dumpfile);
if (a->next != NULL)
- gfc_status (" ");
+ fputc (' ', dumpfile);
}
- gfc_status (")");
+ fputc (')', dumpfile);
}
/* Show a gfc_array_spec array specification structure. */
-void
-gfc_show_array_spec (gfc_array_spec *as)
+static void
+show_array_spec (gfc_array_spec *as)
{
const char *c;
int i;
if (as == NULL)
{
- gfc_status ("()");
+ fputs ("()", dumpfile);
return;
}
- gfc_status ("(%d", as->rank);
+ fprintf (dumpfile, "(%d", as->rank);
if (as->rank != 0)
{
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
default:
- gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape "
+ gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
}
- gfc_status (" %s ", c);
+ fprintf (dumpfile, " %s ", c);
for (i = 0; i < as->rank; i++)
{
- gfc_show_expr (as->lower[i]);
- gfc_status_char (' ');
- gfc_show_expr (as->upper[i]);
- gfc_status_char (' ');
+ show_expr (as->lower[i]);
+ fputc (' ', dumpfile);
+ show_expr (as->upper[i]);
+ fputc (' ', dumpfile);
}
}
- gfc_status (")");
+ fputc (')', dumpfile);
}
/* Show a gfc_array_ref array reference structure. */
-void
-gfc_show_array_ref (gfc_array_ref * ar)
+static void
+show_array_ref (gfc_array_ref * ar)
{
int i;
- gfc_status_char ('(');
+ fputc ('(', dumpfile);
switch (ar->type)
{
case AR_FULL:
- gfc_status ("FULL");
+ fputs ("FULL", dumpfile);
break;
case AR_SECTION:
bound and the stride, if they're present. */
if (ar->start[i] != NULL)
- gfc_show_expr (ar->start[i]);
+ show_expr (ar->start[i]);
if (ar->dimen_type[i] == DIMEN_RANGE)
{
- gfc_status_char (':');
+ fputc (':', dumpfile);
if (ar->end[i] != NULL)
- gfc_show_expr (ar->end[i]);
+ show_expr (ar->end[i]);
if (ar->stride[i] != NULL)
{
- gfc_status_char (':');
- gfc_show_expr (ar->stride[i]);
+ fputc (':', dumpfile);
+ show_expr (ar->stride[i]);
}
}
if (i != ar->dimen - 1)
- gfc_status (" , ");
+ fputs (" , ", dumpfile);
}
break;
case AR_ELEMENT:
for (i = 0; i < ar->dimen; i++)
{
- gfc_show_expr (ar->start[i]);
+ show_expr (ar->start[i]);
if (i != ar->dimen - 1)
- gfc_status (" , ");
+ fputs (" , ", dumpfile);
}
break;
case AR_UNKNOWN:
- gfc_status ("UNKNOWN");
+ fputs ("UNKNOWN", dumpfile);
break;
default:
- gfc_internal_error ("gfc_show_array_ref(): Unknown array reference");
+ gfc_internal_error ("show_array_ref(): Unknown array reference");
}
- gfc_status_char (')');
+ fputc (')', dumpfile);
}
/* Show a list of gfc_ref structures. */
-void
-gfc_show_ref (gfc_ref *p)
+static void
+show_ref (gfc_ref *p)
{
for (; p; p = p->next)
switch (p->type)
{
case REF_ARRAY:
- gfc_show_array_ref (&p->u.ar);
+ show_array_ref (&p->u.ar);
break;
case REF_COMPONENT:
- gfc_status (" %% %s", p->u.c.component->name);
+ fprintf (dumpfile, " %% %s", p->u.c.component->name);
break;
case REF_SUBSTRING:
- gfc_status_char ('(');
- gfc_show_expr (p->u.ss.start);
- gfc_status_char (':');
- gfc_show_expr (p->u.ss.end);
- gfc_status_char (')');
+ fputc ('(', dumpfile);
+ show_expr (p->u.ss.start);
+ fputc (':', dumpfile);
+ show_expr (p->u.ss.end);
+ fputc (')', dumpfile);
break;
default:
- gfc_internal_error ("gfc_show_ref(): Bad component code");
+ gfc_internal_error ("show_ref(): Bad component code");
}
}
/* Display a constructor. Works recursively for array constructors. */
-void
-gfc_show_constructor (gfc_constructor *c)
+static void
+show_constructor (gfc_constructor *c)
{
for (; c; c = c->next)
{
if (c->iterator == NULL)
- gfc_show_expr (c->expr);
+ show_expr (c->expr);
else
{
- gfc_status_char ('(');
- gfc_show_expr (c->expr);
+ fputc ('(', dumpfile);
+ show_expr (c->expr);
- gfc_status_char (' ');
- gfc_show_expr (c->iterator->var);
- gfc_status_char ('=');
- gfc_show_expr (c->iterator->start);
- gfc_status_char (',');
- gfc_show_expr (c->iterator->end);
- gfc_status_char (',');
- gfc_show_expr (c->iterator->step);
+ fputc (' ', dumpfile);
+ show_expr (c->iterator->var);
+ fputc ('=', dumpfile);
+ show_expr (c->iterator->start);
+ fputc (',', dumpfile);
+ show_expr (c->iterator->end);
+ fputc (',', dumpfile);
+ show_expr (c->iterator->step);
- gfc_status_char (')');
+ fputc (')', dumpfile);
}
if (c->next != NULL)
- gfc_status (" , ");
+ fputs (" , ", dumpfile);
}
}
{
int i;
- gfc_status_char ('\'');
+ fputc ('\'', dumpfile);
for (i = 0; i < length; i++)
{
if (c[i] == '\'')
- gfc_status ("''");
+ fputs ("''", dumpfile);
else if (ISPRINT (c[i]))
- gfc_status_char (c[i]);
+ fputc (c[i], dumpfile);
else
- {
- gfc_status ("' // ACHAR(");
- printf ("%d", c[i]);
- gfc_status (") // '");
- }
+ fprintf (dumpfile, "' // ACHAR(%d) // '", c[i]);
}
- gfc_status_char ('\'');
+ fputc ('\'', dumpfile);
}
/* Show an expression. */
-void
-gfc_show_expr (gfc_expr *p)
+static void
+show_expr (gfc_expr *p)
{
const char *c;
int i;
if (p == NULL)
{
- gfc_status ("()");
+ fputs ("()", dumpfile);
return;
}
{
case EXPR_SUBSTRING:
show_char_const (p->value.character.string, p->value.character.length);
- gfc_show_ref (p->ref);
+ show_ref (p->ref);
break;
case EXPR_STRUCTURE:
- gfc_status ("%s(", p->ts.derived->name);
- gfc_show_constructor (p->value.constructor);
- gfc_status_char (')');
+ fprintf (dumpfile, "%s(", p->ts.derived->name);
+ show_constructor (p->value.constructor);
+ fputc (')', dumpfile);
break;
case EXPR_ARRAY:
- gfc_status ("(/ ");
- gfc_show_constructor (p->value.constructor);
- gfc_status (" /)");
+ fputs ("(/ ", dumpfile);
+ show_constructor (p->value.constructor);
+ fputs (" /)", dumpfile);
- gfc_show_ref (p->ref);
+ show_ref (p->ref);
break;
case EXPR_NULL:
- gfc_status ("NULL()");
+ fputs ("NULL()", dumpfile);
break;
case EXPR_CONSTANT:
mpz_out_str (stdout, 10, p->value.integer);
if (p->ts.kind != gfc_default_integer_kind)
- gfc_status ("_%d", p->ts.kind);
+ fprintf (dumpfile, "_%d", p->ts.kind);
break;
case BT_LOGICAL:
if (p->value.logical)
- gfc_status (".true.");
+ fputs (".true.", dumpfile);
else
- gfc_status (".false.");
+ fputs (".false.", dumpfile);
break;
case BT_REAL:
mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
if (p->ts.kind != gfc_default_real_kind)
- gfc_status ("_%d", p->ts.kind);
+ fprintf (dumpfile, "_%d", p->ts.kind);
break;
case BT_CHARACTER:
break;
case BT_COMPLEX:
- gfc_status ("(complex ");
+ fputs ("(complex ", dumpfile);
mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
- gfc_status ("_%d", p->ts.kind);
+ fprintf (dumpfile, "_%d", p->ts.kind);
- gfc_status (" ");
+ fputc (' ', dumpfile);
mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
- gfc_status ("_%d", p->ts.kind);
+ fprintf (dumpfile, "_%d", p->ts.kind);
- gfc_status (")");
+ fputc (')', dumpfile);
break;
case BT_HOLLERITH:
- gfc_status ("%dH", p->representation.length);
+ fprintf (dumpfile, "%dH", p->representation.length);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
- gfc_status_char (*c);
+ fputc (*c, dumpfile);
}
break;
default:
- gfc_status ("???");
+ fputs ("???", dumpfile);
break;
}
if (p->representation.string)
{
- gfc_status (" {");
+ fputs (" {", dumpfile);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
- gfc_status ("%.2x", (unsigned int) *c);
+ fprintf (dumpfile, "%.2x", (unsigned int) *c);
if (i < p->representation.length - 1)
- gfc_status_char (',');
+ fputc (',', dumpfile);
}
- gfc_status_char ('}');
+ fputc ('}', dumpfile);
}
break;
case EXPR_VARIABLE:
if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
- gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name);
- gfc_status ("%s", p->symtree->n.sym->name);
- gfc_show_ref (p->ref);
+ fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
+ fprintf (dumpfile, "%s", p->symtree->n.sym->name);
+ show_ref (p->ref);
break;
case EXPR_OP:
- gfc_status ("(");
+ fputc ('(', dumpfile);
switch (p->value.op.operator)
{
case INTRINSIC_UPLUS:
- gfc_status ("U+ ");
+ fputs ("U+ ", dumpfile);
break;
case INTRINSIC_UMINUS:
- gfc_status ("U- ");
+ fputs ("U- ", dumpfile);
break;
case INTRINSIC_PLUS:
- gfc_status ("+ ");
+ fputs ("+ ", dumpfile);
break;
case INTRINSIC_MINUS:
- gfc_status ("- ");
+ fputs ("- ", dumpfile);
break;
case INTRINSIC_TIMES:
- gfc_status ("* ");
+ fputs ("* ", dumpfile);
break;
case INTRINSIC_DIVIDE:
- gfc_status ("/ ");
+ fputs ("/ ", dumpfile);
break;
case INTRINSIC_POWER:
- gfc_status ("** ");
+ fputs ("** ", dumpfile);
break;
case INTRINSIC_CONCAT:
- gfc_status ("// ");
+ fputs ("// ", dumpfile);
break;
case INTRINSIC_AND:
- gfc_status ("AND ");
+ fputs ("AND ", dumpfile);
break;
case INTRINSIC_OR:
- gfc_status ("OR ");
+ fputs ("OR ", dumpfile);
break;
case INTRINSIC_EQV:
- gfc_status ("EQV ");
+ fputs ("EQV ", dumpfile);
break;
case INTRINSIC_NEQV:
- gfc_status ("NEQV ");
+ fputs ("NEQV ", dumpfile);
break;
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
- gfc_status ("= ");
+ fputs ("= ", dumpfile);
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- gfc_status ("/= ");
+ fputs ("/= ", dumpfile);
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
- gfc_status ("> ");
+ fputs ("> ", dumpfile);
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
- gfc_status (">= ");
+ fputs (">= ", dumpfile);
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
- gfc_status ("< ");
+ fputs ("< ", dumpfile);
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- gfc_status ("<= ");
+ fputs ("<= ", dumpfile);
break;
case INTRINSIC_NOT:
- gfc_status ("NOT ");
+ fputs ("NOT ", dumpfile);
break;
case INTRINSIC_PARENTHESES:
- gfc_status ("parens");
+ fputs ("parens", dumpfile);
break;
default:
gfc_internal_error
- ("gfc_show_expr(): Bad intrinsic in expression!");
+ ("show_expr(): Bad intrinsic in expression!");
}
- gfc_show_expr (p->value.op.op1);
+ show_expr (p->value.op.op1);
if (p->value.op.op2)
{
- gfc_status (" ");
- gfc_show_expr (p->value.op.op2);
+ fputc (' ', dumpfile);
+ show_expr (p->value.op.op2);
}
- gfc_status (")");
+ fputc (')', dumpfile);
break;
case EXPR_FUNCTION:
if (p->value.function.name == NULL)
{
- gfc_status ("%s[", p->symtree->n.sym->name);
- gfc_show_actual_arglist (p->value.function.actual);
- gfc_status_char (']');
+ fprintf (dumpfile, "%s[", p->symtree->n.sym->name);
+ show_actual_arglist (p->value.function.actual);
+ fputc (']', dumpfile);
}
else
{
- gfc_status ("%s[[", p->value.function.name);
- gfc_show_actual_arglist (p->value.function.actual);
- gfc_status_char (']');
- gfc_status_char (']');
+ fprintf (dumpfile, "%s[[", p->value.function.name);
+ show_actual_arglist (p->value.function.actual);
+ fputc (']', dumpfile);
+ fputc (']', dumpfile);
}
break;
default:
- gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
+ gfc_internal_error ("show_expr(): Don't know how to show expr");
}
}
-/* Show an expression for diagnostic purposes. */
-void
-gfc_show_expr_n (const char * msg, gfc_expr *e)
-{
- if (msg)
- gfc_status (msg);
- gfc_show_expr (e);
- gfc_status_char ('\n');
-}
-
/* Show symbol attributes. The flavor and intent are followed by
whatever single bit attributes are present. */
-void
-gfc_show_attr (symbol_attribute *attr)
+static void
+show_attr (symbol_attribute *attr)
{
- gfc_status ("(%s %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),
- gfc_code2string (save_status, attr->save));
+ fprintf (dumpfile, "(%s %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),
+ gfc_code2string (save_status, attr->save));
if (attr->allocatable)
- gfc_status (" ALLOCATABLE");
+ fputs (" ALLOCATABLE", dumpfile);
if (attr->dimension)
- gfc_status (" DIMENSION");
+ fputs (" DIMENSION", dumpfile);
if (attr->external)
- gfc_status (" EXTERNAL");
+ fputs (" EXTERNAL", dumpfile);
if (attr->intrinsic)
- gfc_status (" INTRINSIC");
+ fputs (" INTRINSIC", dumpfile);
if (attr->optional)
- gfc_status (" OPTIONAL");
+ fputs (" OPTIONAL", dumpfile);
if (attr->pointer)
- gfc_status (" POINTER");
+ fputs (" POINTER", dumpfile);
if (attr->protected)
- gfc_status (" PROTECTED");
+ fputs (" PROTECTED", dumpfile);
if (attr->value)
- gfc_status (" VALUE");
+ fputs (" VALUE", dumpfile);
if (attr->volatile_)
- gfc_status (" VOLATILE");
+ fputs (" VOLATILE", dumpfile);
if (attr->threadprivate)
- gfc_status (" THREADPRIVATE");
+ fputs (" THREADPRIVATE", dumpfile);
if (attr->target)
- gfc_status (" TARGET");
+ fputs (" TARGET", dumpfile);
if (attr->dummy)
- gfc_status (" DUMMY");
+ fputs (" DUMMY", dumpfile);
if (attr->result)
- gfc_status (" RESULT");
+ fputs (" RESULT", dumpfile);
if (attr->entry)
- gfc_status (" ENTRY");
+ fputs (" ENTRY", dumpfile);
if (attr->is_bind_c)
- gfc_status (" BIND(C)");
+ fputs (" BIND(C)", dumpfile);
if (attr->data)
- gfc_status (" DATA");
+ fputs (" DATA", dumpfile);
if (attr->use_assoc)
- gfc_status (" USE-ASSOC");
+ fputs (" USE-ASSOC", dumpfile);
if (attr->in_namelist)
- gfc_status (" IN-NAMELIST");
+ fputs (" IN-NAMELIST", dumpfile);
if (attr->in_common)
- gfc_status (" IN-COMMON");
+ fputs (" IN-COMMON", dumpfile);
if (attr->abstract)
- gfc_status (" ABSTRACT INTERFACE");
+ fputs (" ABSTRACT INTERFACE", dumpfile);
if (attr->function)
- gfc_status (" FUNCTION");
+ fputs (" FUNCTION", dumpfile);
if (attr->subroutine)
- gfc_status (" SUBROUTINE");
+ fputs (" SUBROUTINE", dumpfile);
if (attr->implicit_type)
- gfc_status (" IMPLICIT-TYPE");
+ fputs (" IMPLICIT-TYPE", dumpfile);
if (attr->sequence)
- gfc_status (" SEQUENCE");
+ fputs (" SEQUENCE", dumpfile);
if (attr->elemental)
- gfc_status (" ELEMENTAL");
+ fputs (" ELEMENTAL", dumpfile);
if (attr->pure)
- gfc_status (" PURE");
+ fputs (" PURE", dumpfile);
if (attr->recursive)
- gfc_status (" RECURSIVE");
+ fputs (" RECURSIVE", dumpfile);
- gfc_status (")");
+ fputc (')', dumpfile);
}
/* Show components of a derived type. */
-void
-gfc_show_components (gfc_symbol *sym)
+static void
+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);
+ fprintf (dumpfile, "(%s ", c->name);
+ show_typespec (&c->ts);
if (c->pointer)
- gfc_status (" POINTER");
+ fputs (" POINTER", dumpfile);
if (c->dimension)
- gfc_status (" DIMENSION");
- gfc_status_char (' ');
- gfc_show_array_spec (c->as);
+ fputs (" DIMENSION", dumpfile);
+ fputc (' ', dumpfile);
+ show_array_spec (c->as);
if (c->access)
- gfc_status (" %s", gfc_code2string (access_types, c->access));
- gfc_status (")");
+ fprintf (dumpfile, " %s", gfc_code2string (access_types, c->access));
+ fputc (')', dumpfile);
if (c->next != NULL)
- gfc_status_char (' ');
+ fputc (' ', dumpfile);
}
}
specific interfaces associated with a generic symbol is done within
that symbol. */
-void
-gfc_show_symbol (gfc_symbol *sym)
+static void
+show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
show_indent ();
- gfc_status ("symbol %s ", sym->name);
- gfc_show_typespec (&sym->ts);
- gfc_show_attr (&sym->attr);
+ fprintf (dumpfile, "symbol %s ", sym->name);
+ show_typespec (&sym->ts);
+ show_attr (&sym->attr);
if (sym->value)
{
show_indent ();
- gfc_status ("value: ");
- gfc_show_expr (sym->value);
+ fputs ("value: ", dumpfile);
+ show_expr (sym->value);
}
if (sym->as)
{
show_indent ();
- gfc_status ("Array spec:");
- gfc_show_array_spec (sym->as);
+ fputs ("Array spec:", dumpfile);
+ show_array_spec (sym->as);
}
if (sym->generic)
{
show_indent ();
- gfc_status ("Generic interfaces:");
+ fputs ("Generic interfaces:", dumpfile);
for (intr = sym->generic; intr; intr = intr->next)
- gfc_status (" %s", intr->sym->name);
+ fprintf (dumpfile, " %s", intr->sym->name);
}
if (sym->result)
{
show_indent ();
- gfc_status ("result: %s", sym->result->name);
+ fprintf (dumpfile, "result: %s", sym->result->name);
}
if (sym->components)
{
show_indent ();
- gfc_status ("components: ");
- gfc_show_components (sym);
+ fputs ("components: ", dumpfile);
+ show_components (sym);
}
if (sym->formal)
{
show_indent ();
- gfc_status ("Formal arglist:");
+ fputs ("Formal arglist:", dumpfile);
for (formal = sym->formal; formal; formal = formal->next)
{
if (formal->sym != NULL)
- gfc_status (" %s", formal->sym->name);
+ fprintf (dumpfile, " %s", formal->sym->name);
else
- gfc_status (" [Alt Return]");
+ fputs (" [Alt Return]", dumpfile);
}
}
if (sym->formal_ns)
{
show_indent ();
- gfc_status ("Formal namespace");
- gfc_show_namespace (sym->formal_ns);
+ fputs ("Formal namespace", dumpfile);
+ show_namespace (sym->formal_ns);
}
- gfc_status_char ('\n');
-}
-
-
-/* Show a symbol for diagnostic purposes. */
-void
-gfc_show_symbol_n (const char * msg, gfc_symbol *sym)
-{
- if (msg)
- gfc_status (msg);
- gfc_show_symbol (sym);
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
}
gfc_interface *intr;
show_indent ();
- gfc_status ("%s:", uop->name);
+ fprintf (dumpfile, "%s:", uop->name);
for (intr = uop->operator; intr; intr = intr->next)
- gfc_status (" %s", intr->sym->name);
+ fprintf (dumpfile, " %s", intr->sym->name);
}
gfc_symbol *s;
show_indent ();
- gfc_status ("common: /%s/ ", st->name);
+ fprintf (dumpfile, "common: /%s/ ", st->name);
s = st->n.common->head;
while (s)
{
- gfc_status ("%s", s->name);
+ fprintf (dumpfile, "%s", s->name);
s = s->common_next;
if (s)
- gfc_status (", ");
+ fputs (", ", dumpfile);
}
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
}
show_symtree (gfc_symtree *st)
{
show_indent ();
- gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
+ fprintf (dumpfile, "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);
+ fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
else
- gfc_show_symbol (st->n.sym);
+ show_symbol (st->n.sym);
}
/******************* Show gfc_code structures **************/
-
-static void gfc_show_code_node (int, gfc_code *);
-
/* Show a list of code structures. Mutually recursive with
- gfc_show_code_node(). */
+ show_code_node(). */
-void
-gfc_show_code (int level, gfc_code *c)
+static void
+show_code (int level, gfc_code *c)
{
for (; c; c = c->next)
- gfc_show_code_node (level, c);
+ show_code_node (level, c);
}
-void
-gfc_show_namelist (gfc_namelist *n)
+static void
+show_namelist (gfc_namelist *n)
{
for (; n->next; n = n->next)
- gfc_status ("%s,", n->sym->name);
- gfc_status ("%s", n->sym->name);
+ fprintf (dumpfile, "%s,", n->sym->name);
+ fprintf (dumpfile, "%s", n->sym->name);
}
/* Show a single OpenMP directive node and everything underneath it
if necessary. */
static void
-gfc_show_omp_node (int level, gfc_code *c)
+show_omp_node (int level, gfc_code *c)
{
gfc_omp_clauses *omp_clauses = NULL;
const char *name = NULL;
default:
gcc_unreachable ();
}
- gfc_status ("!$OMP %s", name);
+ fprintf (dumpfile, "!$OMP %s", name);
switch (c->op)
{
case EXEC_OMP_DO:
break;
case EXEC_OMP_CRITICAL:
if (c->ext.omp_name)
- gfc_status (" (%s)", c->ext.omp_name);
+ fprintf (dumpfile, " (%s)", c->ext.omp_name);
break;
case EXEC_OMP_FLUSH:
if (c->ext.omp_namelist)
{
- gfc_status (" (");
- gfc_show_namelist (c->ext.omp_namelist);
- gfc_status_char (')');
+ fputs (" (", dumpfile);
+ show_namelist (c->ext.omp_namelist);
+ fputc (')', dumpfile);
}
return;
case EXEC_OMP_BARRIER:
if (omp_clauses->if_expr)
{
- gfc_status (" IF(");
- gfc_show_expr (omp_clauses->if_expr);
- gfc_status_char (')');
+ fputs (" IF(", dumpfile);
+ show_expr (omp_clauses->if_expr);
+ fputc (')', dumpfile);
}
if (omp_clauses->num_threads)
{
- gfc_status (" NUM_THREADS(");
- gfc_show_expr (omp_clauses->num_threads);
- gfc_status_char (')');
+ fputs (" NUM_THREADS(", dumpfile);
+ show_expr (omp_clauses->num_threads);
+ fputc (')', dumpfile);
}
if (omp_clauses->sched_kind != OMP_SCHED_NONE)
{
default:
gcc_unreachable ();
}
- gfc_status (" SCHEDULE (%s", type);
+ fprintf (dumpfile, " SCHEDULE (%s", type);
if (omp_clauses->chunk_size)
{
- gfc_status_char (',');
- gfc_show_expr (omp_clauses->chunk_size);
+ fputc (',', dumpfile);
+ show_expr (omp_clauses->chunk_size);
}
- gfc_status_char (')');
+ fputc (')', dumpfile);
}
if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
{
default:
gcc_unreachable ();
}
- gfc_status (" DEFAULT(%s)", type);
+ fprintf (dumpfile, " DEFAULT(%s)", type);
}
if (omp_clauses->ordered)
- gfc_status (" ORDERED");
+ fputs (" ORDERED", dumpfile);
for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
if (omp_clauses->lists[list_type] != NULL
&& list_type != OMP_LIST_COPYPRIVATE)
default:
gcc_unreachable ();
}
- gfc_status (" REDUCTION(%s:", type);
+ fprintf (dumpfile, " REDUCTION(%s:", type);
}
else
{
default:
gcc_unreachable ();
}
- gfc_status (" %s(", type);
+ fprintf (dumpfile, " %s(", type);
}
- gfc_show_namelist (omp_clauses->lists[list_type]);
- gfc_status_char (')');
+ show_namelist (omp_clauses->lists[list_type]);
+ fputc (')', dumpfile);
}
}
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
{
gfc_code *d = c->block;
while (d != NULL)
{
- gfc_show_code (level + 1, d->next);
+ show_code (level + 1, d->next);
if (d->block == NULL)
break;
code_indent (level, 0);
- gfc_status ("!$OMP SECTION\n");
+ fputs ("!$OMP SECTION\n", dumpfile);
d = d->block;
}
}
else
- gfc_show_code (level + 1, c->block->next);
+ show_code (level + 1, c->block->next);
if (c->op == EXEC_OMP_ATOMIC)
return;
code_indent (level, 0);
- gfc_status ("!$OMP END %s", name);
+ fprintf (dumpfile, "!$OMP END %s", name);
if (omp_clauses != NULL)
{
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
{
- gfc_status (" COPYPRIVATE(");
- gfc_show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
- gfc_status_char (')');
+ fputs (" COPYPRIVATE(", dumpfile);
+ show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
+ fputc (')', dumpfile);
}
else if (omp_clauses->nowait)
- gfc_status (" NOWAIT");
+ fputs (" NOWAIT", dumpfile);
}
else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
- gfc_status (" (%s)", c->ext.omp_name);
+ fprintf (dumpfile, " (%s)", c->ext.omp_name);
}
/* Show a single code node and everything underneath it if necessary. */
static void
-gfc_show_code_node (int level, gfc_code *c)
+show_code_node (int level, gfc_code *c)
{
gfc_forall_iterator *fa;
gfc_open *open;
switch (c->op)
{
case EXEC_NOP:
- gfc_status ("NOP");
+ fputs ("NOP", dumpfile);
break;
case EXEC_CONTINUE:
- gfc_status ("CONTINUE");
+ fputs ("CONTINUE", dumpfile);
break;
case EXEC_ENTRY:
- gfc_status ("ENTRY %s", c->ext.entry->sym->name);
+ fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
break;
case EXEC_INIT_ASSIGN:
case EXEC_ASSIGN:
- gfc_status ("ASSIGN ");
- gfc_show_expr (c->expr);
- gfc_status_char (' ');
- gfc_show_expr (c->expr2);
+ fputs ("ASSIGN ", dumpfile);
+ show_expr (c->expr);
+ fputc (' ', dumpfile);
+ show_expr (c->expr2);
break;
case EXEC_LABEL_ASSIGN:
- gfc_status ("LABEL ASSIGN ");
- gfc_show_expr (c->expr);
- gfc_status (" %d", c->label->value);
+ fputs ("LABEL ASSIGN ", dumpfile);
+ show_expr (c->expr);
+ fprintf (dumpfile, " %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);
+ fputs ("POINTER ASSIGN ", dumpfile);
+ show_expr (c->expr);
+ fputc (' ', dumpfile);
+ show_expr (c->expr2);
break;
case EXEC_GOTO:
- gfc_status ("GOTO ");
+ fputs ("GOTO ", dumpfile);
if (c->label)
- gfc_status ("%d", c->label->value);
+ fprintf (dumpfile, "%d", c->label->value);
else
{
- gfc_show_expr (c->expr);
+ show_expr (c->expr);
d = c->block;
if (d != NULL)
{
- gfc_status (", (");
+ fputs (", (", dumpfile);
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
- gfc_status_char (',');
+ fputc (',', dumpfile);
else
- gfc_status_char (')');
+ fputc (')', dumpfile);
}
}
}
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
if (c->resolved_sym)
- gfc_status ("CALL %s ", c->resolved_sym->name);
+ fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
else if (c->symtree)
- gfc_status ("CALL %s ", c->symtree->name);
+ fprintf (dumpfile, "CALL %s ", c->symtree->name);
else
- gfc_status ("CALL ?? ");
+ fputs ("CALL ?? ", dumpfile);
- gfc_show_actual_arglist (c->ext.actual);
+ show_actual_arglist (c->ext.actual);
break;
case EXEC_RETURN:
- gfc_status ("RETURN ");
+ fputs ("RETURN ", dumpfile);
if (c->expr)
- gfc_show_expr (c->expr);
+ show_expr (c->expr);
break;
case EXEC_PAUSE:
- gfc_status ("PAUSE ");
+ fputs ("PAUSE ", dumpfile);
if (c->expr != NULL)
- gfc_show_expr (c->expr);
+ show_expr (c->expr);
else
- gfc_status ("%d", c->ext.stop_code);
+ fprintf (dumpfile, "%d", c->ext.stop_code);
break;
case EXEC_STOP:
- gfc_status ("STOP ");
+ fputs ("STOP ", dumpfile);
if (c->expr != NULL)
- gfc_show_expr (c->expr);
+ show_expr (c->expr);
else
- gfc_status ("%d", c->ext.stop_code);
+ fprintf (dumpfile, "%d", c->ext.stop_code);
break;
case EXEC_ARITHMETIC_IF:
- gfc_status ("IF ");
- gfc_show_expr (c->expr);
- gfc_status (" %d, %d, %d",
+ fputs ("IF ", dumpfile);
+ show_expr (c->expr);
+ fprintf (dumpfile, " %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);
+ fputs ("IF ", dumpfile);
+ show_expr (d->expr);
+ fputc ('\n', dumpfile);
+ 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");
+ fputs ("ELSE\n", dumpfile);
else
{
- gfc_status ("ELSE IF ");
- gfc_show_expr (d->expr);
- gfc_status_char ('\n');
+ fputs ("ELSE IF ", dumpfile);
+ show_expr (d->expr);
+ fputc ('\n', dumpfile);
}
- gfc_show_code (level + 1, d->next);
+ show_code (level + 1, d->next);
}
code_indent (level, c->label);
- gfc_status ("ENDIF");
+ fputs ("ENDIF", dumpfile);
break;
case EXEC_SELECT:
d = c->block;
- gfc_status ("SELECT CASE ");
- gfc_show_expr (c->expr);
- gfc_status_char ('\n');
+ fputs ("SELECT CASE ", dumpfile);
+ show_expr (c->expr);
+ fputc ('\n', dumpfile);
for (; d; d = d->block)
{
code_indent (level, 0);
- gfc_status ("CASE ");
+ fputs ("CASE ", dumpfile);
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 (' ');
+ fputc ('(', dumpfile);
+ show_expr (cp->low);
+ fputc (' ', dumpfile);
+ show_expr (cp->high);
+ fputc (')', dumpfile);
+ fputc (' ', dumpfile);
}
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
- gfc_show_code (level + 1, d->next);
+ show_code (level + 1, d->next);
}
code_indent (level, c->label);
- gfc_status ("END SELECT");
+ fputs ("END SELECT", dumpfile);
break;
case EXEC_WHERE:
- gfc_status ("WHERE ");
+ fputs ("WHERE ", dumpfile);
d = c->block;
- gfc_show_expr (d->expr);
- gfc_status_char ('\n');
+ show_expr (d->expr);
+ fputc ('\n', dumpfile);
- gfc_show_code (level + 1, d->next);
+ 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);
+ fputs ("ELSE WHERE ", dumpfile);
+ show_expr (d->expr);
+ fputc ('\n', dumpfile);
+ show_code (level + 1, d->next);
}
code_indent (level, 0);
- gfc_status ("END WHERE");
+ fputs ("END WHERE", dumpfile);
break;
case EXEC_FORALL:
- gfc_status ("FORALL ");
+ fputs ("FORALL ", dumpfile);
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);
+ show_expr (fa->var);
+ fputc (' ', dumpfile);
+ show_expr (fa->start);
+ fputc (':', dumpfile);
+ show_expr (fa->end);
+ fputc (':', dumpfile);
+ show_expr (fa->stride);
if (fa->next != NULL)
- gfc_status_char (',');
+ fputc (',', dumpfile);
}
if (c->expr != NULL)
{
- gfc_status_char (',');
- gfc_show_expr (c->expr);
+ fputc (',', dumpfile);
+ show_expr (c->expr);
}
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
- gfc_show_code (level + 1, c->block->next);
+ show_code (level + 1, c->block->next);
code_indent (level, 0);
- gfc_status ("END FORALL");
+ fputs ("END FORALL", dumpfile);
break;
case EXEC_DO:
- gfc_status ("DO ");
+ fputs ("DO ", dumpfile);
- 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');
+ show_expr (c->ext.iterator->var);
+ fputc ('=', dumpfile);
+ show_expr (c->ext.iterator->start);
+ fputc (' ', dumpfile);
+ show_expr (c->ext.iterator->end);
+ fputc (' ', dumpfile);
+ show_expr (c->ext.iterator->step);
+ fputc ('\n', dumpfile);
- gfc_show_code (level + 1, c->block->next);
+ show_code (level + 1, c->block->next);
code_indent (level, 0);
- gfc_status ("END DO");
+ fputs ("END DO", dumpfile);
break;
case EXEC_DO_WHILE:
- gfc_status ("DO WHILE ");
- gfc_show_expr (c->expr);
- gfc_status_char ('\n');
+ fputs ("DO WHILE ", dumpfile);
+ show_expr (c->expr);
+ fputc ('\n', dumpfile);
- gfc_show_code (level + 1, c->block->next);
+ show_code (level + 1, c->block->next);
code_indent (level, c->label);
- gfc_status ("END DO");
+ fputs ("END DO", dumpfile);
break;
case EXEC_CYCLE:
- gfc_status ("CYCLE");
+ fputs ("CYCLE", dumpfile);
if (c->symtree)
- gfc_status (" %s", c->symtree->n.sym->name);
+ fprintf (dumpfile, " %s", c->symtree->n.sym->name);
break;
case EXEC_EXIT:
- gfc_status ("EXIT");
+ fputs ("EXIT", dumpfile);
if (c->symtree)
- gfc_status (" %s", c->symtree->n.sym->name);
+ fprintf (dumpfile, " %s", c->symtree->n.sym->name);
break;
case EXEC_ALLOCATE:
- gfc_status ("ALLOCATE ");
+ fputs ("ALLOCATE ", dumpfile);
if (c->expr)
{
- gfc_status (" STAT=");
- gfc_show_expr (c->expr);
+ fputs (" STAT=", dumpfile);
+ show_expr (c->expr);
}
for (a = c->ext.alloc_list; a; a = a->next)
{
- gfc_status_char (' ');
- gfc_show_expr (a->expr);
+ fputc (' ', dumpfile);
+ show_expr (a->expr);
}
break;
case EXEC_DEALLOCATE:
- gfc_status ("DEALLOCATE ");
+ fputs ("DEALLOCATE ", dumpfile);
if (c->expr)
{
- gfc_status (" STAT=");
- gfc_show_expr (c->expr);
+ fputs (" STAT=", dumpfile);
+ show_expr (c->expr);
}
for (a = c->ext.alloc_list; a; a = a->next)
{
- gfc_status_char (' ');
- gfc_show_expr (a->expr);
+ fputc (' ', dumpfile);
+ show_expr (a->expr);
}
break;
case EXEC_OPEN:
- gfc_status ("OPEN");
+ fputs ("OPEN", dumpfile);
open = c->ext.open;
if (open->unit)
{
- gfc_status (" UNIT=");
- gfc_show_expr (open->unit);
+ fputs (" UNIT=", dumpfile);
+ show_expr (open->unit);
}
if (open->iomsg)
{
- gfc_status (" IOMSG=");
- gfc_show_expr (open->iomsg);
+ fputs (" IOMSG=", dumpfile);
+ show_expr (open->iomsg);
}
if (open->iostat)
{
- gfc_status (" IOSTAT=");
- gfc_show_expr (open->iostat);
+ fputs (" IOSTAT=", dumpfile);
+ show_expr (open->iostat);
}
if (open->file)
{
- gfc_status (" FILE=");
- gfc_show_expr (open->file);
+ fputs (" FILE=", dumpfile);
+ show_expr (open->file);
}
if (open->status)
{
- gfc_status (" STATUS=");
- gfc_show_expr (open->status);
+ fputs (" STATUS=", dumpfile);
+ show_expr (open->status);
}
if (open->access)
{
- gfc_status (" ACCESS=");
- gfc_show_expr (open->access);
+ fputs (" ACCESS=", dumpfile);
+ show_expr (open->access);
}
if (open->form)
{
- gfc_status (" FORM=");
- gfc_show_expr (open->form);
+ fputs (" FORM=", dumpfile);
+ show_expr (open->form);
}
if (open->recl)
{
- gfc_status (" RECL=");
- gfc_show_expr (open->recl);
+ fputs (" RECL=", dumpfile);
+ show_expr (open->recl);
}
if (open->blank)
{
- gfc_status (" BLANK=");
- gfc_show_expr (open->blank);
+ fputs (" BLANK=", dumpfile);
+ show_expr (open->blank);
}
if (open->position)
{
- gfc_status (" POSITION=");
- gfc_show_expr (open->position);
+ fputs (" POSITION=", dumpfile);
+ show_expr (open->position);
}
if (open->action)
{
- gfc_status (" ACTION=");
- gfc_show_expr (open->action);
+ fputs (" ACTION=", dumpfile);
+ show_expr (open->action);
}
if (open->delim)
{
- gfc_status (" DELIM=");
- gfc_show_expr (open->delim);
+ fputs (" DELIM=", dumpfile);
+ show_expr (open->delim);
}
if (open->pad)
{
- gfc_status (" PAD=");
- gfc_show_expr (open->pad);
+ fputs (" PAD=", dumpfile);
+ show_expr (open->pad);
}
if (open->decimal)
{
- gfc_status (" DECIMAL=");
- gfc_show_expr (open->decimal);
+ fputs (" DECIMAL=", dumpfile);
+ show_expr (open->decimal);
}
if (open->encoding)
{
- gfc_status (" ENCODING=");
- gfc_show_expr (open->encoding);
+ fputs (" ENCODING=", dumpfile);
+ show_expr (open->encoding);
}
if (open->round)
{
- gfc_status (" ROUND=");
- gfc_show_expr (open->round);
+ fputs (" ROUND=", dumpfile);
+ show_expr (open->round);
}
if (open->sign)
{
- gfc_status (" SIGN=");
- gfc_show_expr (open->sign);
+ fputs (" SIGN=", dumpfile);
+ show_expr (open->sign);
}
if (open->convert)
{
- gfc_status (" CONVERT=");
- gfc_show_expr (open->convert);
+ fputs (" CONVERT=", dumpfile);
+ show_expr (open->convert);
}
if (open->asynchronous)
{
- gfc_status (" ASYNCHRONOUS=");
- gfc_show_expr (open->asynchronous);
+ fputs (" ASYNCHRONOUS=", dumpfile);
+ show_expr (open->asynchronous);
}
if (open->err != NULL)
- gfc_status (" ERR=%d", open->err->value);
+ fprintf (dumpfile, " ERR=%d", open->err->value);
break;
case EXEC_CLOSE:
- gfc_status ("CLOSE");
+ fputs ("CLOSE", dumpfile);
close = c->ext.close;
if (close->unit)
{
- gfc_status (" UNIT=");
- gfc_show_expr (close->unit);
+ fputs (" UNIT=", dumpfile);
+ show_expr (close->unit);
}
if (close->iomsg)
{
- gfc_status (" IOMSG=");
- gfc_show_expr (close->iomsg);
+ fputs (" IOMSG=", dumpfile);
+ show_expr (close->iomsg);
}
if (close->iostat)
{
- gfc_status (" IOSTAT=");
- gfc_show_expr (close->iostat);
+ fputs (" IOSTAT=", dumpfile);
+ show_expr (close->iostat);
}
if (close->status)
{
- gfc_status (" STATUS=");
- gfc_show_expr (close->status);
+ fputs (" STATUS=", dumpfile);
+ show_expr (close->status);
}
if (close->err != NULL)
- gfc_status (" ERR=%d", close->err->value);
+ fprintf (dumpfile, " ERR=%d", close->err->value);
break;
case EXEC_BACKSPACE:
- gfc_status ("BACKSPACE");
+ fputs ("BACKSPACE", dumpfile);
goto show_filepos;
case EXEC_ENDFILE:
- gfc_status ("ENDFILE");
+ fputs ("ENDFILE", dumpfile);
goto show_filepos;
case EXEC_REWIND:
- gfc_status ("REWIND");
+ fputs ("REWIND", dumpfile);
goto show_filepos;
case EXEC_FLUSH:
- gfc_status ("FLUSH");
+ fputs ("FLUSH", dumpfile);
show_filepos:
fp = c->ext.filepos;
if (fp->unit)
{
- gfc_status (" UNIT=");
- gfc_show_expr (fp->unit);
+ fputs (" UNIT=", dumpfile);
+ show_expr (fp->unit);
}
if (fp->iomsg)
{
- gfc_status (" IOMSG=");
- gfc_show_expr (fp->iomsg);
+ fputs (" IOMSG=", dumpfile);
+ show_expr (fp->iomsg);
}
if (fp->iostat)
{
- gfc_status (" IOSTAT=");
- gfc_show_expr (fp->iostat);
+ fputs (" IOSTAT=", dumpfile);
+ show_expr (fp->iostat);
}
if (fp->err != NULL)
- gfc_status (" ERR=%d", fp->err->value);
+ fprintf (dumpfile, " ERR=%d", fp->err->value);
break;
case EXEC_INQUIRE:
- gfc_status ("INQUIRE");
+ fputs ("INQUIRE", dumpfile);
i = c->ext.inquire;
if (i->unit)
{
- gfc_status (" UNIT=");
- gfc_show_expr (i->unit);
+ fputs (" UNIT=", dumpfile);
+ show_expr (i->unit);
}
if (i->file)
{
- gfc_status (" FILE=");
- gfc_show_expr (i->file);
+ fputs (" FILE=", dumpfile);
+ show_expr (i->file);
}
if (i->iomsg)
{
- gfc_status (" IOMSG=");
- gfc_show_expr (i->iomsg);
+ fputs (" IOMSG=", dumpfile);
+ show_expr (i->iomsg);
}
if (i->iostat)
{
- gfc_status (" IOSTAT=");
- gfc_show_expr (i->iostat);
+ fputs (" IOSTAT=", dumpfile);
+ show_expr (i->iostat);
}
if (i->exist)
{
- gfc_status (" EXIST=");
- gfc_show_expr (i->exist);
+ fputs (" EXIST=", dumpfile);
+ show_expr (i->exist);
}
if (i->opened)
{
- gfc_status (" OPENED=");
- gfc_show_expr (i->opened);
+ fputs (" OPENED=", dumpfile);
+ show_expr (i->opened);
}
if (i->number)
{
- gfc_status (" NUMBER=");
- gfc_show_expr (i->number);
+ fputs (" NUMBER=", dumpfile);
+ show_expr (i->number);
}
if (i->named)
{
- gfc_status (" NAMED=");
- gfc_show_expr (i->named);
+ fputs (" NAMED=", dumpfile);
+ show_expr (i->named);
}
if (i->name)
{
- gfc_status (" NAME=");
- gfc_show_expr (i->name);
+ fputs (" NAME=", dumpfile);
+ show_expr (i->name);
}
if (i->access)
{
- gfc_status (" ACCESS=");
- gfc_show_expr (i->access);
+ fputs (" ACCESS=", dumpfile);
+ show_expr (i->access);
}
if (i->sequential)
{
- gfc_status (" SEQUENTIAL=");
- gfc_show_expr (i->sequential);
+ fputs (" SEQUENTIAL=", dumpfile);
+ show_expr (i->sequential);
}
if (i->direct)
{
- gfc_status (" DIRECT=");
- gfc_show_expr (i->direct);
+ fputs (" DIRECT=", dumpfile);
+ show_expr (i->direct);
}
if (i->form)
{
- gfc_status (" FORM=");
- gfc_show_expr (i->form);
+ fputs (" FORM=", dumpfile);
+ show_expr (i->form);
}
if (i->formatted)
{
- gfc_status (" FORMATTED");
- gfc_show_expr (i->formatted);
+ fputs (" FORMATTED", dumpfile);
+ show_expr (i->formatted);
}
if (i->unformatted)
{
- gfc_status (" UNFORMATTED=");
- gfc_show_expr (i->unformatted);
+ fputs (" UNFORMATTED=", dumpfile);
+ show_expr (i->unformatted);
}
if (i->recl)
{
- gfc_status (" RECL=");
- gfc_show_expr (i->recl);
+ fputs (" RECL=", dumpfile);
+ show_expr (i->recl);
}
if (i->nextrec)
{
- gfc_status (" NEXTREC=");
- gfc_show_expr (i->nextrec);
+ fputs (" NEXTREC=", dumpfile);
+ show_expr (i->nextrec);
}
if (i->blank)
{
- gfc_status (" BLANK=");
- gfc_show_expr (i->blank);
+ fputs (" BLANK=", dumpfile);
+ show_expr (i->blank);
}
if (i->position)
{
- gfc_status (" POSITION=");
- gfc_show_expr (i->position);
+ fputs (" POSITION=", dumpfile);
+ show_expr (i->position);
}
if (i->action)
{
- gfc_status (" ACTION=");
- gfc_show_expr (i->action);
+ fputs (" ACTION=", dumpfile);
+ show_expr (i->action);
}
if (i->read)
{
- gfc_status (" READ=");
- gfc_show_expr (i->read);
+ fputs (" READ=", dumpfile);
+ show_expr (i->read);
}
if (i->write)
{
- gfc_status (" WRITE=");
- gfc_show_expr (i->write);
+ fputs (" WRITE=", dumpfile);
+ show_expr (i->write);
}
if (i->readwrite)
{
- gfc_status (" READWRITE=");
- gfc_show_expr (i->readwrite);
+ fputs (" READWRITE=", dumpfile);
+ show_expr (i->readwrite);
}
if (i->delim)
{
- gfc_status (" DELIM=");
- gfc_show_expr (i->delim);
+ fputs (" DELIM=", dumpfile);
+ show_expr (i->delim);
}
if (i->pad)
{
- gfc_status (" PAD=");
- gfc_show_expr (i->pad);
+ fputs (" PAD=", dumpfile);
+ show_expr (i->pad);
}
if (i->convert)
{
- gfc_status (" CONVERT=");
- gfc_show_expr (i->convert);
+ fputs (" CONVERT=", dumpfile);
+ show_expr (i->convert);
}
if (i->asynchronous)
{
- gfc_status (" ASYNCHRONOUS=");
- gfc_show_expr (i->asynchronous);
+ fputs (" ASYNCHRONOUS=", dumpfile);
+ show_expr (i->asynchronous);
}
if (i->decimal)
{
- gfc_status (" DECIMAL=");
- gfc_show_expr (i->decimal);
+ fputs (" DECIMAL=", dumpfile);
+ show_expr (i->decimal);
}
if (i->encoding)
{
- gfc_status (" ENCODING=");
- gfc_show_expr (i->encoding);
+ fputs (" ENCODING=", dumpfile);
+ show_expr (i->encoding);
}
if (i->pending)
{
- gfc_status (" PENDING=");
- gfc_show_expr (i->pending);
+ fputs (" PENDING=", dumpfile);
+ show_expr (i->pending);
}
if (i->round)
{
- gfc_status (" ROUND=");
- gfc_show_expr (i->round);
+ fputs (" ROUND=", dumpfile);
+ show_expr (i->round);
}
if (i->sign)
{
- gfc_status (" SIGN=");
- gfc_show_expr (i->sign);
+ fputs (" SIGN=", dumpfile);
+ show_expr (i->sign);
}
if (i->size)
{
- gfc_status (" SIZE=");
- gfc_show_expr (i->size);
+ fputs (" SIZE=", dumpfile);
+ show_expr (i->size);
}
if (i->id)
{
- gfc_status (" ID=");
- gfc_show_expr (i->id);
+ fputs (" ID=", dumpfile);
+ show_expr (i->id);
}
if (i->err != NULL)
- gfc_status (" ERR=%d", i->err->value);
+ fprintf (dumpfile, " ERR=%d", i->err->value);
break;
case EXEC_IOLENGTH:
- gfc_status ("IOLENGTH ");
- gfc_show_expr (c->expr);
+ fputs ("IOLENGTH ", dumpfile);
+ show_expr (c->expr);
goto show_dt_code;
break;
case EXEC_READ:
- gfc_status ("READ");
+ fputs ("READ", dumpfile);
goto show_dt;
case EXEC_WRITE:
- gfc_status ("WRITE");
+ fputs ("WRITE", dumpfile);
show_dt:
dt = c->ext.dt;
if (dt->io_unit)
{
- gfc_status (" UNIT=");
- gfc_show_expr (dt->io_unit);
+ fputs (" UNIT=", dumpfile);
+ show_expr (dt->io_unit);
}
if (dt->format_expr)
{
- gfc_status (" FMT=");
- gfc_show_expr (dt->format_expr);
+ fputs (" FMT=", dumpfile);
+ show_expr (dt->format_expr);
}
if (dt->format_label != NULL)
- gfc_status (" FMT=%d", dt->format_label->value);
+ fprintf (dumpfile, " FMT=%d", dt->format_label->value);
if (dt->namelist)
- gfc_status (" NML=%s", dt->namelist->name);
+ fprintf (dumpfile, " NML=%s", dt->namelist->name);
if (dt->iomsg)
{
- gfc_status (" IOMSG=");
- gfc_show_expr (dt->iomsg);
+ fputs (" IOMSG=", dumpfile);
+ show_expr (dt->iomsg);
}
if (dt->iostat)
{
- gfc_status (" IOSTAT=");
- gfc_show_expr (dt->iostat);
+ fputs (" IOSTAT=", dumpfile);
+ show_expr (dt->iostat);
}
if (dt->size)
{
- gfc_status (" SIZE=");
- gfc_show_expr (dt->size);
+ fputs (" SIZE=", dumpfile);
+ show_expr (dt->size);
}
if (dt->rec)
{
- gfc_status (" REC=");
- gfc_show_expr (dt->rec);
+ fputs (" REC=", dumpfile);
+ show_expr (dt->rec);
}
if (dt->advance)
{
- gfc_status (" ADVANCE=");
- gfc_show_expr (dt->advance);
+ fputs (" ADVANCE=", dumpfile);
+ show_expr (dt->advance);
}
if (dt->id)
{
- gfc_status (" ID=");
- gfc_show_expr (dt->id);
+ fputs (" ID=", dumpfile);
+ show_expr (dt->id);
}
if (dt->pos)
{
- gfc_status (" POS=");
- gfc_show_expr (dt->pos);
+ fputs (" POS=", dumpfile);
+ show_expr (dt->pos);
}
if (dt->asynchronous)
{
- gfc_status (" ASYNCHRONOUS=");
- gfc_show_expr (dt->asynchronous);
+ fputs (" ASYNCHRONOUS=", dumpfile);
+ show_expr (dt->asynchronous);
}
if (dt->blank)
{
- gfc_status (" BLANK=");
- gfc_show_expr (dt->blank);
+ fputs (" BLANK=", dumpfile);
+ show_expr (dt->blank);
}
if (dt->decimal)
{
- gfc_status (" DECIMAL=");
- gfc_show_expr (dt->decimal);
+ fputs (" DECIMAL=", dumpfile);
+ show_expr (dt->decimal);
}
if (dt->delim)
{
- gfc_status (" DELIM=");
- gfc_show_expr (dt->delim);
+ fputs (" DELIM=", dumpfile);
+ show_expr (dt->delim);
}
if (dt->pad)
{
- gfc_status (" PAD=");
- gfc_show_expr (dt->pad);
+ fputs (" PAD=", dumpfile);
+ show_expr (dt->pad);
}
if (dt->round)
{
- gfc_status (" ROUND=");
- gfc_show_expr (dt->round);
+ fputs (" ROUND=", dumpfile);
+ show_expr (dt->round);
}
if (dt->sign)
{
- gfc_status (" SIGN=");
- gfc_show_expr (dt->sign);
+ fputs (" SIGN=", dumpfile);
+ show_expr (dt->sign);
}
show_dt_code:
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
for (c = c->block->next; c; c = c->next)
- gfc_show_code_node (level + (c->next != NULL), c);
+ show_code_node (level + (c->next != NULL), c);
return;
case EXEC_TRANSFER:
- gfc_status ("TRANSFER ");
- gfc_show_expr (c->expr);
+ fputs ("TRANSFER ", dumpfile);
+ show_expr (c->expr);
break;
case EXEC_DT_END:
- gfc_status ("DT_END");
+ fputs ("DT_END", dumpfile);
dt = c->ext.dt;
if (dt->err != NULL)
- gfc_status (" ERR=%d", dt->err->value);
+ fprintf (dumpfile, " ERR=%d", dt->err->value);
if (dt->end != NULL)
- gfc_status (" END=%d", dt->end->value);
+ fprintf (dumpfile, " END=%d", dt->end->value);
if (dt->eor != NULL)
- gfc_status (" EOR=%d", dt->eor->value);
+ fprintf (dumpfile, " EOR=%d", dt->eor->value);
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
- gfc_show_omp_node (level, c);
+ show_omp_node (level, c);
break;
default:
- gfc_internal_error ("gfc_show_code_node(): Bad statement code");
+ gfc_internal_error ("show_code_node(): Bad statement code");
}
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
}
/* Show an equivalence chain. */
-void
-gfc_show_equiv (gfc_equiv *eq)
+static void
+show_equiv (gfc_equiv *eq)
{
show_indent ();
- gfc_status ("Equivalence: ");
+ fputs ("Equivalence: ", dumpfile);
while (eq)
{
- gfc_show_expr (eq->expr);
+ show_expr (eq->expr);
eq = eq->eq;
if (eq)
- gfc_status (", ");
+ fputs (", ", dumpfile);
}
}
-
+
/* Show a freakin' whole namespace. */
-void
-gfc_show_namespace (gfc_namespace *ns)
+static void
+show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
show_level++;
show_indent ();
- gfc_status ("Namespace:");
+ fputs ("Namespace:", dumpfile);
if (ns != NULL)
{
i++;
if (i > l)
- gfc_status(" %c-%c: ", l+'A', i+'A');
+ fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
else
- gfc_status(" %c: ", l+'A');
+ fprintf (dumpfile, " %c: ", l+'A');
- gfc_show_typespec(&ns->default_type[l]);
+ 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);
+ fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
}
gfc_current_ns = ns;
continue;
show_indent ();
- gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
+ fprintf (dumpfile, "Operator interfaces for %s:",
+ gfc_op2string (op));
for (; intr; intr = intr->next)
- gfc_status (" %s", intr->sym->name);
+ fprintf (dumpfile, " %s", intr->sym->name);
}
if (ns->uop_root != NULL)
{
show_indent ();
- gfc_status ("User operators:\n");
+ fputs ("User operators:\n", dumpfile);
gfc_traverse_user_op (ns, show_uop);
}
}
for (eq = ns->equiv; eq; eq = eq->next)
- gfc_show_equiv (eq);
+ show_equiv (eq);
- gfc_status_char ('\n');
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
+ fputc ('\n', dumpfile);
- gfc_show_code (0, ns->code);
+ show_code (0, ns->code);
for (ns = ns->contained; ns; ns = ns->sibling)
{
show_indent ();
- gfc_status ("CONTAINS\n");
- gfc_show_namespace (ns);
+ fputs ("CONTAINS\n", dumpfile);
+ show_namespace (ns);
}
show_level--;
- gfc_status_char ('\n');
+ fputc ('\n', dumpfile);
gfc_current_ns = save;
}
+
+
+/* Main function for dumping a parse tree. */
+
+void
+gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
+{
+ dumpfile = file;
+ show_namespace (ns);
+}
projects / gcc.git / commitdiff