diff options
Diffstat (limited to 'gcc/fortran/dump-parse-tree.c')
| -rw-r--r-- | gcc/fortran/dump-parse-tree.c | 1194 |
1 files changed, 594 insertions, 600 deletions
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index dc3ab32..c195dcf 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -37,6 +37,16 @@ along with GCC; see the file COPYING3. If not see /* 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 @@ -45,12 +55,12 @@ code_indent (int level, gfc_st_label *label) 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); } @@ -60,78 +70,78 @@ code_indent (int level, gfc_st_label *label) 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) { @@ -142,37 +152,37 @@ gfc_show_array_spec (gfc_array_spec *as) 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: @@ -186,106 +196,106 @@ gfc_show_array_ref (gfc_array_ref * ar) 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); } } @@ -295,34 +305,30 @@ show_char_const (const char *c, int length) { 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; } @@ -330,25 +336,25 @@ gfc_show_expr (gfc_expr *p) { 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: @@ -358,20 +364,20 @@ gfc_show_expr (gfc_expr *p) 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: @@ -380,273 +386,264 @@ gfc_show_expr (gfc_expr *p) 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); } } @@ -656,8 +653,8 @@ gfc_show_components (gfc_symbol *sym) 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; @@ -667,78 +664,67 @@ gfc_show_symbol (gfc_symbol *sym) 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); } @@ -751,10 +737,10 @@ show_uop (gfc_user_op *uop) 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); } @@ -790,17 +776,17 @@ show_common (gfc_symtree *st) 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); } @@ -810,44 +796,41 @@ static void 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; @@ -871,7 +854,7 @@ gfc_show_omp_node (int level, gfc_code *c) default: gcc_unreachable (); } - gfc_status ("!$OMP %s", name); + fprintf (dumpfile, "!$OMP %s", name); switch (c->op) { case EXEC_OMP_DO: @@ -886,14 +869,14 @@ gfc_show_omp_node (int level, gfc_code *c) 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: @@ -907,15 +890,15 @@ gfc_show_omp_node (int level, gfc_code *c) 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) { @@ -929,13 +912,13 @@ gfc_show_omp_node (int level, gfc_code *c) 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) { @@ -949,10 +932,10 @@ gfc_show_omp_node (int level, gfc_code *c) 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) @@ -977,7 +960,7 @@ gfc_show_omp_node (int level, gfc_code *c) default: gcc_unreachable (); } - gfc_status (" REDUCTION(%s:", type); + fprintf (dumpfile, " REDUCTION(%s:", type); } else { @@ -991,52 +974,52 @@ gfc_show_omp_node (int level, gfc_code *c) 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; @@ -1053,56 +1036,56 @@ gfc_show_code_node (int level, gfc_code *c) 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); } } } @@ -1111,54 +1094,54 @@ gfc_show_code_node (int level, gfc_code *c) 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) @@ -1166,650 +1149,650 @@ gfc_show_code_node (int level, gfc_code *c) 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: @@ -1826,38 +1809,38 @@ gfc_show_code_node (int level, gfc_code *c) 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; @@ -1869,7 +1852,7 @@ gfc_show_namespace (gfc_namespace *ns) show_level++; show_indent (); - gfc_status ("Namespace:"); + fputs ("Namespace:", dumpfile); if (ns != NULL) { @@ -1883,18 +1866,18 @@ gfc_show_namespace (gfc_namespace *ns) 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; @@ -1910,36 +1893,47 @@ gfc_show_namespace (gfc_namespace *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); +} |