/* Parse tree dumper
- Copyright (C) 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Steven Bosscher
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* Actually this is just a collection of routines that used to be
TODO: Dump DATA. */
#include "config.h"
+#include "system.h"
#include "gfortran.h"
+#include "constructor.h"
/* 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);
+
+
+/* Allow dumping of an expression in the debugger. */
+void gfc_debug_expr (gfc_expr *);
+
+void
+gfc_debug_expr (gfc_expr *e)
+{
+ FILE *tmp = dumpfile;
+ dumpfile = stderr;
+ show_expr (e);
+ fputc ('\n', dumpfile);
+ dumpfile = tmp;
+}
+
+
/* Do indentation for a specific level. */
static inline void
int i;
if (label != NULL)
- gfc_status ("%-5d ", label->value);
- else
- gfc_status (" ");
+ fprintf (dumpfile, "%-5d ", label->value);
- for (i = 0; i < 2 * level; i++)
- gfc_status_char (' ');
+ for (i = 0; i < (2 * level - (label ? 6 : 0)); i++)
+ 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);
+ case BT_CLASS:
+ fprintf (dumpfile, "%s", ts->u.derived->name);
break;
case BT_CHARACTER:
- gfc_show_expr (ts->cl->length);
+ show_expr (ts->u.cl->length);
+ fprintf(dumpfile, " %d", ts->kind);
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 [%d]", as->rank, as->corank);
- if (as->rank != 0)
+ if (as->rank + as->corank > 0)
{
switch (as->type)
{
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++)
+ for (i = 0; i < as->rank + as->corank; 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_base base)
{
- for (; c; c = c->next)
+ gfc_constructor *c;
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
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 (" , ");
+ if (gfc_constructor_next (c) != NULL)
+ fputs (" , ", dumpfile);
}
}
+static void
+show_char_const (const gfc_char_t *c, int length)
+{
+ int i;
+
+ fputc ('\'', dumpfile);
+ for (i = 0; i < length; i++)
+ {
+ if (c[i] == '\'')
+ fputs ("''", dumpfile);
+ else
+ fputs (gfc_print_wide_char (c[i]), dumpfile);
+ }
+ fputc ('\'', dumpfile);
+}
+
+
+/* Show a component-call expression. */
+
+static void
+show_compcall (gfc_expr* p)
+{
+ gcc_assert (p->expr_type == EXPR_COMPCALL);
+
+ fprintf (dumpfile, "%s", p->symtree->n.sym->name);
+ show_ref (p->ref);
+ fprintf (dumpfile, "%s", p->value.compcall.name);
+
+ show_actual_arglist (p->value.compcall.actual);
+}
+
+
/* 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;
}
switch (p->expr_type)
{
case EXPR_SUBSTRING:
- c = p->value.character.string;
-
- for (i = 0; i < p->value.character.length; i++, c++)
- {
- if (*c == '\'')
- gfc_status ("''");
- else
- gfc_status ("%c", *c);
- }
-
- gfc_show_ref (p->ref);
+ show_char_const (p->value.character.string, p->value.character.length);
+ 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.u.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:
- c = p->value.character.string;
-
- gfc_status_char ('\'');
-
- for (i = 0; i < p->value.character.length; i++, c++)
- {
- if (*c == '\'')
- gfc_status ("''");
- else
- gfc_status_char (*c);
- }
-
- gfc_status_char ('\'');
-
+ show_char_const (p->value.character.string,
+ p->value.character.length);
break;
case BT_COMPLEX:
- gfc_status ("(complex ");
+ fputs ("(complex ", dumpfile);
- mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
+ mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
+ 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);
+ mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
+ 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 ("(");
- switch (p->value.op.operator)
+ fputc ('(', dumpfile);
+ switch (p->value.op.op)
{
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:
- gfc_status ("= ");
+ case INTRINSIC_EQ_OS:
+ fputs ("= ", dumpfile);
break;
case INTRINSIC_NE:
- gfc_status ("<> ");
+ case INTRINSIC_NE_OS:
+ fputs ("/= ", dumpfile);
break;
case INTRINSIC_GT:
- gfc_status ("> ");
+ case INTRINSIC_GT_OS:
+ fputs ("> ", dumpfile);
break;
case INTRINSIC_GE:
- gfc_status (">= ");
+ case INTRINSIC_GE_OS:
+ fputs (">= ", dumpfile);
break;
case INTRINSIC_LT:
- gfc_status ("< ");
+ case INTRINSIC_LT_OS:
+ fputs ("< ", dumpfile);
break;
case INTRINSIC_LE:
- gfc_status ("<= ");
+ case INTRINSIC_LE_OS:
+ 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);
+ if (gfc_is_proc_ptr_comp (p, NULL))
+ show_ref (p->ref);
+ fputc ('[', dumpfile);
+ 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);
+ if (gfc_is_proc_ptr_comp (p, NULL))
+ show_ref (p->ref);
+ fputc ('[', dumpfile);
+ fputc ('[', dumpfile);
+ show_actual_arglist (p->value.function.actual);
+ fputc (']', dumpfile);
+ fputc (']', dumpfile);
}
break;
+ case EXPR_COMPCALL:
+ show_compcall (p);
+ 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 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, const char * module)
{
-
- 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));
+ if (attr->flavor != FL_UNKNOWN)
+ fprintf (dumpfile, "(%s ", gfc_code2string (flavors, attr->flavor));
+ if (attr->access != ACCESS_UNKNOWN)
+ fprintf (dumpfile, "%s ", gfc_code2string (access_types, attr->access));
+ if (attr->proc != PROC_UNKNOWN)
+ fprintf (dumpfile, "%s ", gfc_code2string (procedures, attr->proc));
+ if (attr->save != SAVE_NONE)
+ fprintf (dumpfile, "%s", gfc_code2string (save_status, attr->save));
if (attr->allocatable)
- gfc_status (" ALLOCATABLE");
+ fputs (" ALLOCATABLE", dumpfile);
+ if (attr->asynchronous)
+ fputs (" ASYNCHRONOUS", dumpfile);
+ if (attr->codimension)
+ fputs (" CODIMENSION", dumpfile);
if (attr->dimension)
- gfc_status (" DIMENSION");
+ fputs (" DIMENSION", dumpfile);
+ if (attr->contiguous)
+ fputs (" CONTIGUOUS", 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");
- if (attr->protected)
- gfc_status (" PROTECTED");
+ fputs (" POINTER", dumpfile);
+ if (attr->is_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->intent != INTENT_UNKNOWN)
+ fprintf (dumpfile, "(%s)", gfc_intent_string (attr->intent));
+ }
+
if (attr->result)
- gfc_status (" RESULT");
+ fputs (" RESULT", dumpfile);
if (attr->entry)
- gfc_status (" ENTRY");
+ fputs (" ENTRY", dumpfile);
+ if (attr->is_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 (module != NULL)
+ fprintf (dumpfile, "(%s)", module);
+ }
+
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)
+ fputs (" ABSTRACT", 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);
- if (c->pointer)
- gfc_status (" POINTER");
- if (c->dimension)
- gfc_status (" DIMENSION");
- gfc_status_char (' ');
- gfc_show_array_spec (c->as);
- if (c->access)
- gfc_status (" %s", gfc_code2string (access_types, c->access));
- gfc_status (")");
+ fprintf (dumpfile, "(%s ", c->name);
+ show_typespec (&c->ts);
+ if (c->attr.allocatable)
+ fputs (" ALLOCATABLE", dumpfile);
+ if (c->attr.pointer)
+ fputs (" POINTER", dumpfile);
+ if (c->attr.proc_pointer)
+ fputs (" PPC", dumpfile);
+ if (c->attr.dimension)
+ fputs (" DIMENSION", dumpfile);
+ fputc (' ', dumpfile);
+ show_array_spec (c->as);
+ if (c->attr.access)
+ fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
+ fputc (')', dumpfile);
if (c->next != NULL)
- gfc_status_char (' ');
+ fputc (' ', dumpfile);
}
}
+/* Show the f2k_derived namespace with procedure bindings. */
+
+static void
+show_typebound_proc (gfc_typebound_proc* tb, const char* name)
+{
+ show_indent ();
+
+ if (tb->is_generic)
+ fputs ("GENERIC", dumpfile);
+ else
+ {
+ fputs ("PROCEDURE, ", dumpfile);
+ if (tb->nopass)
+ fputs ("NOPASS", dumpfile);
+ else
+ {
+ if (tb->pass_arg)
+ fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
+ else
+ fputs ("PASS", dumpfile);
+ }
+ if (tb->non_overridable)
+ fputs (", NON_OVERRIDABLE", dumpfile);
+ }
+
+ if (tb->access == ACCESS_PUBLIC)
+ fputs (", PUBLIC", dumpfile);
+ else
+ fputs (", PRIVATE", dumpfile);
+
+ fprintf (dumpfile, " :: %s => ", name);
+
+ if (tb->is_generic)
+ {
+ gfc_tbp_generic* g;
+ for (g = tb->u.generic; g; g = g->next)
+ {
+ fputs (g->specific_st->name, dumpfile);
+ if (g->next)
+ fputs (", ", dumpfile);
+ }
+ }
+ else
+ fputs (tb->u.specific->n.sym->name, dumpfile);
+}
+
+static void
+show_typebound_symtree (gfc_symtree* st)
+{
+ gcc_assert (st->n.tb);
+ show_typebound_proc (st->n.tb, st->name);
+}
+
+static void
+show_f2k_derived (gfc_namespace* f2k)
+{
+ gfc_finalizer* f;
+ int op;
+
+ show_indent ();
+ fputs ("Procedure bindings:", dumpfile);
+ ++show_level;
+
+ /* Finalizer bindings. */
+ for (f = f2k->finalizers; f; f = f->next)
+ {
+ show_indent ();
+ fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
+ }
+
+ /* Type-bound procedures. */
+ gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
+
+ --show_level;
+
+ show_indent ();
+ fputs ("Operator bindings:", dumpfile);
+ ++show_level;
+
+ /* User-defined operators. */
+ gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
+
+ /* Intrinsic operators. */
+ for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
+ if (f2k->tb_op[op])
+ show_typebound_proc (f2k->tb_op[op],
+ gfc_op2string ((gfc_intrinsic_op) op));
+
+ --show_level;
+}
+
+
/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
show the interface. Information needed to reconstruct the list of
specific interfaces associated with a generic symbol is done within
that symbol. */
-void
-gfc_show_symbol (gfc_symbol *sym)
+static void
+show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
+ int i,len;
if (sym == NULL)
return;
+ fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
+ len = strlen (sym->name);
+ for (i=len; i<12; i++)
+ fputc(' ', dumpfile);
+
+ ++show_level;
+
show_indent ();
+ fputs ("type spec : ", dumpfile);
+ show_typespec (&sym->ts);
- gfc_status ("symbol %s ", sym->name);
- gfc_show_typespec (&sym->ts);
- gfc_show_attr (&sym->attr);
+ show_indent ();
+ fputs ("attributes: ", dumpfile);
+ show_attr (&sym->attr, sym->module);
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->f2k_derived)
+ {
+ show_indent ();
+ if (sym->hash_value)
+ fprintf (dumpfile, "hash: %d", sym->hash_value);
+ show_f2k_derived (sym->f2k_derived);
}
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)
+ if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
+ && sym->attr.proc != PROC_ST_FUNCTION)
{
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_level;
}
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);
+ for (intr = uop->op; intr; intr = intr->next)
+ 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);
}
static void
show_symtree (gfc_symtree *st)
{
+ int len, i;
+
show_indent ();
- gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
+
+ len = strlen(st->name);
+ fprintf (dumpfile, "symtree: '%s'", st->name);
+
+ for (i=len; i<12; i++)
+ fputc(' ', dumpfile);
+
+ if (st->ambiguous)
+ fputs( " Ambiguous", dumpfile);
if (st->n.sym->ns != gfc_current_ns)
- gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name);
+ fprintf (dumpfile, "|| symbol: '%s' from namespace '%s'", st->n.sym->name,
+ 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;
case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
case EXEC_OMP_SINGLE: name = "SINGLE"; break;
+ case EXEC_OMP_TASK: name = "TASK"; break;
+ case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
default:
gcc_unreachable ();
}
- gfc_status ("!$OMP %s", name);
+ fprintf (dumpfile, "!$OMP %s", name);
switch (c->op)
{
case EXEC_OMP_DO:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_TASK:
omp_clauses = c->ext.omp_clauses;
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:
+ case EXEC_OMP_TASKWAIT:
return;
default:
break;
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)
{
case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
case OMP_SCHED_GUIDED: type = "GUIDED"; break;
case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ case OMP_SCHED_AUTO: type = "AUTO"; break;
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)
{
case OMP_DEFAULT_NONE: type = "NONE"; break;
case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
case OMP_DEFAULT_SHARED: type = "SHARED"; break;
- case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
default:
gcc_unreachable ();
}
- gfc_status (" DEFAULT(%s)", type);
+ fprintf (dumpfile, " DEFAULT(%s)", type);
}
if (omp_clauses->ordered)
- gfc_status (" ORDERED");
+ fputs (" ORDERED", dumpfile);
+ if (omp_clauses->untied)
+ fputs (" UNTIED", dumpfile);
+ if (omp_clauses->collapse)
+ fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
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;
gfc_filepos *fp;
gfc_inquire *i;
gfc_dt *dt;
+ gfc_namespace *ns;
- code_indent (level, c->here);
+ if (c->here)
+ {
+ fputc ('\n', dumpfile);
+ code_indent (level, c->here);
+ }
+ else
+ show_indent ();
switch (c->op)
{
+ case EXEC_END_PROCEDURE:
+ break;
+
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->expr1);
+ 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->expr1);
+ fprintf (dumpfile, " %d", c->label1->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->expr1);
+ fputc (' ', dumpfile);
+ show_expr (c->expr2);
break;
case EXEC_GOTO:
- gfc_status ("GOTO ");
- if (c->label)
- gfc_status ("%d", c->label->value);
+ fputs ("GOTO ", dumpfile);
+ if (c->label1)
+ fprintf (dumpfile, "%d", c->label1->value);
else
{
- gfc_show_expr (c->expr);
+ show_expr (c->expr1);
d = c->block;
if (d != NULL)
{
- gfc_status (", (");
+ fputs (", (", dumpfile);
for (; d; d = d ->block)
{
- code_indent (level, d->label);
+ code_indent (level, d->label1);
if (d->block != NULL)
- gfc_status_char (',');
+ fputc (',', dumpfile);
else
- gfc_status_char (')');
+ fputc (')', dumpfile);
}
}
}
break;
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);
+
+ show_actual_arglist (c->ext.actual);
+ break;
- gfc_show_actual_arglist (c->ext.actual);
+ case EXEC_COMPCALL:
+ fputs ("CALL ", dumpfile);
+ show_compcall (c->expr1);
+ break;
+
+ case EXEC_CALL_PPC:
+ fputs ("CALL ", dumpfile);
+ show_expr (c->expr1);
+ show_actual_arglist (c->ext.actual);
break;
case EXEC_RETURN:
- gfc_status ("RETURN ");
- if (c->expr)
- gfc_show_expr (c->expr);
+ fputs ("RETURN ", dumpfile);
+ if (c->expr1)
+ show_expr (c->expr1);
break;
case EXEC_PAUSE:
- gfc_status ("PAUSE ");
+ fputs ("PAUSE ", dumpfile);
- if (c->expr != NULL)
- gfc_show_expr (c->expr);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
else
- gfc_status ("%d", c->ext.stop_code);
+ fprintf (dumpfile, "%d", c->ext.stop_code);
break;
+ case EXEC_ERROR_STOP:
+ fputs ("ERROR ", dumpfile);
+ /* Fall through. */
+
case EXEC_STOP:
- gfc_status ("STOP ");
+ fputs ("STOP ", dumpfile);
- if (c->expr != NULL)
- gfc_show_expr (c->expr);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
else
- gfc_status ("%d", c->ext.stop_code);
+ fprintf (dumpfile, "%d", c->ext.stop_code);
break;
+ case EXEC_SYNC_ALL:
+ fputs ("SYNC ALL ", dumpfile);
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
+ case EXEC_SYNC_MEMORY:
+ fputs ("SYNC MEMORY ", dumpfile);
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
+ case EXEC_SYNC_IMAGES:
+ fputs ("SYNC IMAGES image-set=", dumpfile);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
+ else
+ fputs ("* ", dumpfile);
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
case EXEC_ARITHMETIC_IF:
- gfc_status ("IF ");
- gfc_show_expr (c->expr);
- gfc_status (" %d, %d, %d",
- c->label->value, c->label2->value, c->label3->value);
+ fputs ("IF ", dumpfile);
+ show_expr (c->expr1);
+ fprintf (dumpfile, " %d, %d, %d",
+ c->label1->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->expr1);
+
+ ++show_level;
+ show_code (level + 1, d->next);
+ --show_level;
d = d->block;
for (; d; d = d->block)
{
code_indent (level, 0);
- if (d->expr == NULL)
- gfc_status ("ELSE\n");
+ if (d->expr1 == NULL)
+ fputs ("ELSE", dumpfile);
else
{
- gfc_status ("ELSE IF ");
- gfc_show_expr (d->expr);
- gfc_status_char ('\n');
+ fputs ("ELSE IF ", dumpfile);
+ show_expr (d->expr1);
}
- gfc_show_code (level + 1, d->next);
+ ++show_level;
+ show_code (level + 1, d->next);
+ --show_level;
}
- code_indent (level, c->label);
+ if (c->label1)
+ code_indent (level, c->label1);
+ else
+ show_indent ();
- gfc_status ("ENDIF");
+ fputs ("ENDIF", dumpfile);
break;
+ case EXEC_BLOCK:
+ {
+ const char* blocktype;
+ if (c->ext.block.assoc)
+ blocktype = "ASSOCIATE";
+ else
+ blocktype = "BLOCK";
+ show_indent ();
+ fprintf (dumpfile, "%s ", blocktype);
+ ++show_level;
+ ns = c->ext.block.ns;
+ gfc_traverse_symtree (ns->sym_root, show_symtree);
+ show_code (show_level, ns->code);
+ --show_level;
+ show_indent ();
+ fprintf (dumpfile, "END %s ", blocktype);
+ 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->expr1);
+ fputc ('\n', dumpfile);
for (; d; d = d->block)
{
code_indent (level, 0);
- gfc_status ("CASE ");
- for (cp = d->ext.case_list; cp; cp = cp->next)
+ fputs ("CASE ", dumpfile);
+ for (cp = d->ext.block.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");
+ code_indent (level, c->label1);
+ 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->expr1);
+ 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->expr1);
+ 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)
+ if (c->expr1 != NULL)
{
- gfc_status_char (',');
- gfc_show_expr (c->expr);
+ fputc (',', dumpfile);
+ show_expr (c->expr1);
}
- 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 ");
-
- 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');
+ case EXEC_CRITICAL:
+ fputs ("CRITICAL\n", dumpfile);
+ show_code (level + 1, c->block->next);
+ code_indent (level, 0);
+ fputs ("END CRITICAL", dumpfile);
+ break;
- gfc_show_code (level + 1, c->block->next);
+ case EXEC_DO:
+ fputs ("DO ", dumpfile);
+ if (c->label1)
+ fprintf (dumpfile, " %-5d ", c->label1->value);
+
+ 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);
+
+ ++show_level;
+ show_code (level + 1, c->block->next);
+ --show_level;
+
+ if (c->label1)
+ break;
- code_indent (level, 0);
- gfc_status ("END DO");
+ show_indent ();
+ 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->expr1);
+ 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");
+ code_indent (level, c->label1);
+ 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 ");
- if (c->expr)
+ fputs ("ALLOCATE ", dumpfile);
+ if (c->expr1)
+ {
+ fputs (" STAT=", dumpfile);
+ show_expr (c->expr1);
+ }
+
+ if (c->expr2)
{
- gfc_status (" STAT=");
- gfc_show_expr (c->expr);
+ fputs (" ERRMSG=", dumpfile);
+ show_expr (c->expr2);
}
- for (a = c->ext.alloc_list; a; a = a->next)
+ 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 ");
- if (c->expr)
+ fputs ("DEALLOCATE ", dumpfile);
+ if (c->expr1)
+ {
+ fputs (" STAT=", dumpfile);
+ show_expr (c->expr1);
+ }
+
+ if (c->expr2)
{
- gfc_status (" STAT=");
- gfc_show_expr (c->expr);
+ fputs (" ERRMSG=", dumpfile);
+ show_expr (c->expr2);
}
- for (a = c->ext.alloc_list; a; a = a->next)
+ 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)
+ {
+ fputs (" DECIMAL=", dumpfile);
+ show_expr (open->decimal);
+ }
+ if (open->encoding)
+ {
+ fputs (" ENCODING=", dumpfile);
+ show_expr (open->encoding);
+ }
+ if (open->round)
+ {
+ fputs (" ROUND=", dumpfile);
+ show_expr (open->round);
+ }
+ if (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)
+ {
+ 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)
+ {
+ fputs (" ASYNCHRONOUS=", dumpfile);
+ show_expr (i->asynchronous);
+ }
+ if (i->decimal)
+ {
+ fputs (" DECIMAL=", dumpfile);
+ show_expr (i->decimal);
+ }
+ if (i->encoding)
+ {
+ fputs (" ENCODING=", dumpfile);
+ show_expr (i->encoding);
+ }
+ if (i->pending)
+ {
+ fputs (" PENDING=", dumpfile);
+ show_expr (i->pending);
+ }
+ if (i->round)
+ {
+ fputs (" ROUND=", dumpfile);
+ show_expr (i->round);
+ }
+ if (i->sign)
+ {
+ fputs (" SIGN=", dumpfile);
+ show_expr (i->sign);
+ }
+ if (i->size)
+ {
+ fputs (" SIZE=", dumpfile);
+ show_expr (i->size);
+ }
+ if (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->expr1);
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)
+ {
+ fputs (" ID=", dumpfile);
+ show_expr (dt->id);
+ }
+ if (dt->pos)
+ {
+ fputs (" POS=", dumpfile);
+ show_expr (dt->pos);
+ }
+ if (dt->asynchronous)
+ {
+ fputs (" ASYNCHRONOUS=", dumpfile);
+ show_expr (dt->asynchronous);
+ }
+ if (dt->blank)
+ {
+ fputs (" BLANK=", dumpfile);
+ show_expr (dt->blank);
+ }
+ if (dt->decimal)
+ {
+ fputs (" DECIMAL=", dumpfile);
+ show_expr (dt->decimal);
+ }
+ if (dt->delim)
+ {
+ fputs (" DELIM=", dumpfile);
+ show_expr (dt->delim);
+ }
+ if (dt->pad)
+ {
+ fputs (" PAD=", dumpfile);
+ show_expr (dt->pad);
+ }
+ if (dt->round)
+ {
+ fputs (" ROUND=", dumpfile);
+ show_expr (dt->round);
+ }
+ if (dt->sign)
+ {
+ fputs (" SIGN=", dumpfile);
+ show_expr (dt->sign);
}
show_dt_code:
- gfc_status_char ('\n');
for (c = c->block->next; c; c = c->next)
- gfc_show_code_node (level + (c->next != NULL), c);
+ 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->expr1);
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_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKWAIT:
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');
}
/* 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;
- gfc_intrinsic_op op;
+ int op;
gfc_equiv *eq;
int i;
save = gfc_current_ns;
- 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);
}
+ ++show_level;
gfc_current_ns = ns;
gfc_traverse_symtree (ns->common_root, show_common);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
/* User operator interfaces */
- intr = ns->operator[op];
+ intr = ns->op[op];
if (intr == NULL)
continue;
show_indent ();
- gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
+ fprintf (dumpfile, "Operator interfaces for %s:",
+ gfc_op2string ((gfc_intrinsic_op) 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);
}
}
+ else
+ ++show_level;
for (eq = ns->equiv; eq; eq = eq->next)
- gfc_show_equiv (eq);
+ show_equiv (eq);
- gfc_status_char ('\n');
- gfc_status_char ('\n');
-
- gfc_show_code (0, ns->code);
+ fputc ('\n', dumpfile);
+ show_indent ();
+ fputs ("code:", dumpfile);
+ show_code (show_level, ns->code);
+ --show_level;
for (ns = ns->contained; ns; ns = ns->sibling)
{
- show_indent ();
- gfc_status ("CONTAINS\n");
- gfc_show_namespace (ns);
+ fputs ("\nCONTAINS\n", dumpfile);
+ ++show_level;
+ show_namespace (ns);
+ --show_level;
}
- 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);
+}
OSDN Git Service
