Skip to content

R
riscv-gcc-1
Commit 6c1abb5c by François-Xavier Coudert
Options

dump-parse-tree.c: Use fprintf, fputs and fputc instead of gfc_status and gfc_status_char. 

	* dump-parse-tree.c: Use fprintf, fputs and fputc instead of
	gfc_status and gfc_status_char. Remove gfc_ prefix of the gfc_show_*
	functions and make them static. Add new gfc_dump_parse_tree
	function.
	* gfortran.h (gfc_option_t): Rename verbose into dump_parse_tree.
	(gfc_status, gfc_status_char): Delete prototypes.
	* error.c (gfc_status, gfc_status_char): Remove functions.
	* scanner.c (gfc_new_file): Use printf instead of gfc_status.
	* options.c (gfc_init_options): Rename verbose into dump_parse_tree.
	(gfc_handle_module_path_options): Use gfc_fatal_error instead of
	gfc_status and exit.
	(gfc_handle_option): Rename verbose into dump_parse_tree.

From-SVN: r133958
parent 1bde5bc4
Showing with 618 additions and 660 deletions
gcc/fortran/ChangeLog
2008-04-06 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* dump-parse-tree.c: Use fprintf, fputs and fputc instead of
gfc_status and gfc_status_char. Remove gfc_ prefix of the gfc_show_*
functions and make them static. Add new gfc_dump_parse_tree
function.
* gfortran.h (gfc_option_t): Rename verbose into dump_parse_tree.
(gfc_status, gfc_status_char): Delete prototypes.
* error.c (gfc_status, gfc_status_char): Remove functions.
* scanner.c (gfc_new_file): Use printf instead of gfc_status.
* options.c (gfc_init_options): Rename verbose into dump_parse_tree.
(gfc_handle_module_path_options): Use gfc_fatal_error instead of
gfc_status and exit.
(gfc_handle_option): Rename verbose into dump_parse_tree.
2008-04-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
......@@ -49,7 +64,7 @@
2008-04-03 Paolo Bonzini <bonzini@gnu.org>
* f95-lang.c (insert_block): Kill.
* f95-lang.c (insert_block): Kill.
2008-04-01 George Helffrich <george@gcc.gnu.org>
......
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);
}
gcc/fortran/error.c
......@@ -963,31 +963,6 @@ gfc_free_error (gfc_error_buf *err)
}
/* Debug wrapper for printf. */
void
gfc_status (const char *cmsgid, ...)
{
va_list argp;
va_start (argp, cmsgid);
vprintf (_(cmsgid), argp);
va_end (argp);
}
/* Subroutine for outputting a single char so that we don't have to go
around creating a lot of 1-character strings. */
void
gfc_status_char (char c)
{
putchar (c);
}
/* Report the number of warnings and errors that occurred to the caller. */
void
......
gcc/fortran/gfortran.h
......@@ -1818,7 +1818,7 @@ typedef struct
int max_continue_fixed;
int max_continue_free;
int max_identifier_length;
int verbose;
int dump_parse_tree;
int warn_aliasing;
int warn_ampersand;
......@@ -2012,9 +2012,6 @@ void gfc_push_error (gfc_error_buf *);
void gfc_pop_error (gfc_error_buf *);
void gfc_free_error (gfc_error_buf *);
void gfc_status (const char *, ...) ATTRIBUTE_PRINTF_1;
void gfc_status_char (char);
void gfc_get_errors (int *, int *);
/* arith.c */
......@@ -2360,22 +2357,7 @@ void gfc_insert_bbt (void *, void *, compare_fn);
void gfc_delete_bbt (void *, void *, compare_fn);
/* dump-parse-tree.c */
void gfc_show_actual_arglist (gfc_actual_arglist *);
void gfc_show_array_ref (gfc_array_ref *);
void gfc_show_array_spec (gfc_array_spec *);
void gfc_show_attr (symbol_attribute *);
void gfc_show_code (int, gfc_code *);
void gfc_show_components (gfc_symbol *);
void gfc_show_constructor (gfc_constructor *);
void gfc_show_equiv (gfc_equiv *);
void gfc_show_expr (gfc_expr *);
void gfc_show_expr_n (const char *, gfc_expr *);
void gfc_show_namelist (gfc_namelist *);
void gfc_show_namespace (gfc_namespace *);
void gfc_show_ref (gfc_ref *);
void gfc_show_symbol (gfc_symbol *);
void gfc_show_symbol_n (const char *, gfc_symbol *);
void gfc_show_typespec (gfc_typespec *);
void gfc_dump_parse_tree (gfc_namespace *, FILE *);
/* parse.c */
try gfc_parse_file (void);
......
gcc/fortran/options.c
......@@ -64,7 +64,7 @@ gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED,
gfc_option.max_subrecord_length = 0;
gfc_option.convert = GFC_CONVERT_NATIVE;
gfc_option.record_marker = 0;
gfc_option.verbose = 0;
gfc_option.dump_parse_tree = 0;
gfc_option.warn_aliasing = 0;
gfc_option.warn_ampersand = 0;
......@@ -391,16 +391,10 @@ gfc_handle_module_path_options (const char *arg)
{
if (gfc_option.module_dir != NULL)
{
gfc_status ("gfortran: Only one -M option allowed\n");
exit (3);
}
gfc_fatal_error ("gfortran: Only one -M option allowed");
if (arg == NULL)
{
gfc_status ("gfortran: Directory required after -M\n");
exit (3);
}
gfc_fatal_error ("gfortran: Directory required after -M");
gfc_option.module_dir = (char *) gfc_getmem (strlen (arg) + 2);
strcpy (gfc_option.module_dir, arg);
......@@ -564,7 +558,7 @@ gfc_handle_option (size_t scode, const char *arg, int value)
break;
case OPT_fdump_parse_tree:
gfc_option.verbose = value;
gfc_option.dump_parse_tree = value;
break;
case OPT_ffixed_form:
......
gcc/fortran/scanner.c
......@@ -1684,10 +1684,8 @@ gfc_new_file (void)
#if 0 /* Debugging aid. */
for (; line_head; line_head = line_head->next)
gfc_status ("%s:%3d %s\n",
LOCATION_FILE (line_head->location),
LOCATION_LINE (line_head->location),
line_head->line);
printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location),
LOCATION_LINE (line_head->location), line_head->line);
exit (0);
#endif
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment