/* Parse tree dumper
- Copyright (C) 2003 Free Software Foundation, Inc.
+ Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Steven Bosscher
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 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 version.
+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 3, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, 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
/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
-
-/* Forward declaration because this one needs all, and all need
- this one. */
-static void gfc_show_expr (gfc_expr *);
-
/* Do indentation for a specific level. */
static inline void
-code_indent (int level, gfc_st_label * label)
+code_indent (int level, gfc_st_label *label)
{
int i;
/* Simple indentation at the current level. This one
is used to show symbols. */
+
static inline void
show_indent (void)
{
/* Show type-specific information. */
-static void
-gfc_show_typespec (gfc_typespec * ts)
-{
+void
+gfc_show_typespec (gfc_typespec *ts)
+{
gfc_status ("(%s ", gfc_basic_typename (ts->type));
switch (ts->type)
/* Show an actual argument list. */
-static void
-gfc_show_actual_arglist (gfc_actual_arglist * a)
+void
+gfc_show_actual_arglist (gfc_actual_arglist *a)
{
-
gfc_status ("(");
for (; a; a = a->next)
{
gfc_status_char ('(');
- if (a->name[0] != '\0')
+ if (a->name != NULL)
gfc_status ("%s = ", a->name);
if (a->expr != NULL)
gfc_show_expr (a->expr);
}
-/* Show an gfc_array_spec array specification structure. */
+/* Show a gfc_array_spec array specification structure. */
-static void
-gfc_show_array_spec (gfc_array_spec * as)
+void
+gfc_show_array_spec (gfc_array_spec *as)
{
const char *c;
int i;
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 type.");
+ gfc_internal_error ("gfc_show_array_spec(): Unhandled array shape "
+ "type.");
}
gfc_status (" %s ", c);
}
-/* Show an gfc_array_ref array reference structure. */
+/* Show a gfc_array_ref array reference structure. */
-static void
+void
gfc_show_array_ref (gfc_array_ref * ar)
{
int i;
case AR_SECTION:
for (i = 0; i < ar->dimen; i++)
{
+ /* There are two types of array sections: either the
+ elements are identified by an integer array ('vector'),
+ or by an index range. In the former case we only have to
+ print the start expression which contains the vector, in
+ the latter case we have to print any of lower and upper
+ bound and the stride, if they're present. */
+
if (ar->start[i] != NULL)
gfc_show_expr (ar->start[i]);
- gfc_status_char (':');
-
- if (ar->end[i] != NULL)
- gfc_show_expr (ar->end[i]);
-
- if (ar->stride[i] != NULL)
+ if (ar->dimen_type[i] == DIMEN_RANGE)
{
gfc_status_char (':');
- gfc_show_expr (ar->stride[i]);
+
+ if (ar->end[i] != NULL)
+ gfc_show_expr (ar->end[i]);
+
+ if (ar->stride[i] != NULL)
+ {
+ gfc_status_char (':');
+ gfc_show_expr (ar->stride[i]);
+ }
}
if (i != ar->dimen - 1)
/* Show a list of gfc_ref structures. */
-static void
-gfc_show_ref (gfc_ref * p)
+void
+gfc_show_ref (gfc_ref *p)
{
-
for (; p; p = p->next)
switch (p->type)
{
/* Display a constructor. Works recursively for array constructors. */
-static void
-gfc_show_constructor (gfc_constructor * c)
+void
+gfc_show_constructor (gfc_constructor *c)
{
-
for (; c; c = c->next)
{
if (c->iterator == NULL)
}
+static void
+show_char_const (const char *c, int length)
+{
+ int i;
+
+ gfc_status_char ('\'');
+ for (i = 0; i < length; i++)
+ {
+ if (c[i] == '\'')
+ gfc_status ("''");
+ else if (ISPRINT (c[i]))
+ gfc_status_char (c[i]);
+ else
+ {
+ gfc_status ("' // ACHAR(");
+ printf ("%d", c[i]);
+ gfc_status (") // '");
+ }
+ }
+ gfc_status_char ('\'');
+}
+
/* Show an expression. */
-static void
-gfc_show_expr (gfc_expr * p)
+void
+gfc_show_expr (gfc_expr *p)
{
const char *c;
int i;
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);
- }
-
+ show_char_const (p->value.character.string, p->value.character.length);
gfc_show_ref (p->ref);
break;
case BT_INTEGER:
mpz_out_str (stdout, 10, p->value.integer);
- if (p->ts.kind != gfc_default_integer_kind ())
+ if (p->ts.kind != gfc_default_integer_kind)
gfc_status ("_%d", p->ts.kind);
break;
break;
case BT_REAL:
- mpf_out_str (stdout, 10, 0, p->value.real);
- if (p->ts.kind != gfc_default_real_kind ())
+ 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);
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 ");
- mpf_out_str (stdout, 10, 0, p->value.complex.r);
- if (p->ts.kind != gfc_default_complex_kind ())
+ 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);
gfc_status (" ");
- mpf_out_str (stdout, 10, 0, p->value.complex.i);
- if (p->ts.kind != gfc_default_complex_kind ())
+ 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);
gfc_status (")");
break;
+ case BT_HOLLERITH:
+ gfc_status ("%dH", p->representation.length);
+ c = p->representation.string;
+ for (i = 0; i < p->representation.length; i++, c++)
+ {
+ gfc_status_char (*c);
+ }
+ break;
+
default:
gfc_status ("???");
break;
}
+ if (p->representation.string)
+ {
+ gfc_status (" {");
+ c = p->representation.string;
+ for (i = 0; i < p->representation.length; i++, c++)
+ {
+ gfc_status ("%.2x", (unsigned int) *c);
+ if (i < p->representation.length - 1)
+ gfc_status_char (',');
+ }
+ gfc_status_char ('}');
+ }
+
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);
break;
case EXPR_OP:
gfc_status ("(");
- switch (p->operator)
+ switch (p->value.op.operator)
{
case INTRINSIC_UPLUS:
gfc_status ("U+ ");
gfc_status ("NEQV ");
break;
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
gfc_status ("= ");
break;
case INTRINSIC_NE:
- gfc_status ("<> ");
+ case INTRINSIC_NE_OS:
+ gfc_status ("/= ");
break;
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
gfc_status ("> ");
break;
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
gfc_status (">= ");
break;
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
gfc_status ("< ");
break;
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
gfc_status ("<= ");
break;
case INTRINSIC_NOT:
gfc_status ("NOT ");
break;
+ case INTRINSIC_PARENTHESES:
+ gfc_status ("parens");
+ break;
default:
gfc_internal_error
("gfc_show_expr(): Bad intrinsic in expression!");
}
- gfc_show_expr (p->op1);
+ gfc_show_expr (p->value.op.op1);
- if (p->op2)
+ if (p->value.op.op2)
{
gfc_status (" ");
- gfc_show_expr (p->op2);
+ gfc_show_expr (p->value.op.op2);
}
gfc_status (")");
}
}
+/* 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. */
-static void
-gfc_show_attr (symbol_attribute * attr)
+void
+gfc_show_attr (symbol_attribute *attr)
{
- gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor),
+ 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 (procedures, attr->proc),
+ gfc_code2string (save_status, attr->save));
if (attr->allocatable)
gfc_status (" ALLOCATABLE");
gfc_status (" OPTIONAL");
if (attr->pointer)
gfc_status (" POINTER");
- if (attr->save)
- gfc_status (" SAVE");
+ if (attr->protected)
+ gfc_status (" PROTECTED");
+ if (attr->value)
+ gfc_status (" VALUE");
+ if (attr->volatile_)
+ gfc_status (" VOLATILE");
+ if (attr->threadprivate)
+ gfc_status (" THREADPRIVATE");
if (attr->target)
gfc_status (" TARGET");
if (attr->dummy)
gfc_status (" DUMMY");
- if (attr->common)
- gfc_status (" COMMON");
if (attr->result)
gfc_status (" RESULT");
if (attr->entry)
gfc_status (" ENTRY");
+ if (attr->is_bind_c)
+ gfc_status (" BIND(C)");
if (attr->data)
gfc_status (" DATA");
gfc_status (" IN-NAMELIST");
if (attr->in_common)
gfc_status (" IN-COMMON");
- if (attr->saved_common)
- gfc_status (" SAVED-COMMON");
+ if (attr->abstract)
+ gfc_status (" ABSTRACT INTERFACE");
if (attr->function)
gfc_status (" FUNCTION");
if (attr->subroutine)
/* Show components of a derived type. */
-static void
-gfc_show_components (gfc_symbol * sym)
+void
+gfc_show_components (gfc_symbol *sym)
{
gfc_component *c;
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 (")");
if (c->next != NULL)
gfc_status_char (' ');
specific interfaces associated with a generic symbol is done within
that symbol. */
-static void
-gfc_show_symbol (gfc_symbol * sym)
+void
+gfc_show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
- gfc_symbol *s;
if (sym == NULL)
return;
gfc_status (" %s", intr->sym->name);
}
- if (sym->common_head)
- {
- show_indent ();
- gfc_status ("Common members:");
- for (s = sym->common_head; s; s = s->common_next)
- gfc_status (" %s", s->name);
- }
-
if (sym->result)
{
show_indent ();
gfc_status ("Formal arglist:");
for (formal = sym->formal; formal; formal = formal->next)
- gfc_status (" %s", formal->sym->name);
+ {
+ if (formal->sym != NULL)
+ gfc_status (" %s", formal->sym->name);
+ else
+ gfc_status (" [Alt Return]");
+ }
}
if (sym->formal_ns)
}
+/* 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');
+}
+
+
/* Show a user-defined operator. Just prints an operator
and the name of the associated subroutine, really. */
+
static void
-show_uop (gfc_user_op * uop)
+show_uop (gfc_user_op *uop)
{
gfc_interface *intr;
/* Workhorse function for traversing the user operator symtree. */
static void
-traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *))
+traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
{
-
if (st == NULL)
return;
/* Traverse the tree of user operator nodes. */
void
-gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *))
+gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
{
-
traverse_uop (ns->uop_root, func);
}
-/* Worker function to display the symbol tree. */
+/* Function to display a common block. */
static void
-show_symtree (gfc_symtree * st)
+show_common (gfc_symtree *st)
{
+ gfc_symbol *s;
show_indent ();
+ gfc_status ("common: /%s/ ", st->name);
+
+ s = st->n.common->head;
+ while (s)
+ {
+ gfc_status ("%s", s->name);
+ s = s->common_next;
+ if (s)
+ gfc_status (", ");
+ }
+ gfc_status_char ('\n');
+}
+
+
+/* Worker function to display the symbol tree. */
+
+static void
+show_symtree (gfc_symtree *st)
+{
+ show_indent ();
gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous);
if (st->n.sym->ns != gfc_current_ns)
-static void gfc_show_code_node (int level, gfc_code * c);
+static void gfc_show_code_node (int, gfc_code *);
/* Show a list of code structures. Mutually recursive with
gfc_show_code_node(). */
-static void
-gfc_show_code (int level, gfc_code * c)
+void
+gfc_show_code (int level, gfc_code *c)
{
-
for (; c; c = c->next)
gfc_show_code_node (level, c);
}
+void
+gfc_show_namelist (gfc_namelist *n)
+{
+ for (; n->next; n = n->next)
+ gfc_status ("%s,", n->sym->name);
+ gfc_status ("%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)
+{
+ gfc_omp_clauses *omp_clauses = NULL;
+ const char *name = NULL;
+
+ switch (c->op)
+ {
+ case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
+ case EXEC_OMP_BARRIER: name = "BARRIER"; break;
+ case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
+ case EXEC_OMP_FLUSH: name = "FLUSH"; break;
+ case EXEC_OMP_DO: name = "DO"; break;
+ case EXEC_OMP_MASTER: name = "MASTER"; break;
+ case EXEC_OMP_ORDERED: name = "ORDERED"; break;
+ case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
+ case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
+ 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_WORKSHARE: name = "WORKSHARE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status ("!$OMP %s", name);
+ switch (c->op)
+ {
+ case EXEC_OMP_DO:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ omp_clauses = c->ext.omp_clauses;
+ break;
+ case EXEC_OMP_CRITICAL:
+ if (c->ext.omp_name)
+ gfc_status (" (%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 (')');
+ }
+ return;
+ case EXEC_OMP_BARRIER:
+ return;
+ default:
+ break;
+ }
+ if (omp_clauses)
+ {
+ int list_type;
+
+ if (omp_clauses->if_expr)
+ {
+ gfc_status (" IF(");
+ gfc_show_expr (omp_clauses->if_expr);
+ gfc_status_char (')');
+ }
+ if (omp_clauses->num_threads)
+ {
+ gfc_status (" NUM_THREADS(");
+ gfc_show_expr (omp_clauses->num_threads);
+ gfc_status_char (')');
+ }
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE)
+ {
+ const char *type;
+ switch (omp_clauses->sched_kind)
+ {
+ case OMP_SCHED_STATIC: type = "STATIC"; break;
+ case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
+ case OMP_SCHED_GUIDED: type = "GUIDED"; break;
+ case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" SCHEDULE (%s", type);
+ if (omp_clauses->chunk_size)
+ {
+ gfc_status_char (',');
+ gfc_show_expr (omp_clauses->chunk_size);
+ }
+ gfc_status_char (')');
+ }
+ if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->default_sharing)
+ {
+ 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;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" DEFAULT(%s)", type);
+ }
+ if (omp_clauses->ordered)
+ gfc_status (" ORDERED");
+ for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
+ if (omp_clauses->lists[list_type] != NULL
+ && list_type != OMP_LIST_COPYPRIVATE)
+ {
+ const char *type;
+ if (list_type >= OMP_LIST_REDUCTION_FIRST)
+ {
+ switch (list_type)
+ {
+ case OMP_LIST_PLUS: type = "+"; break;
+ case OMP_LIST_MULT: type = "*"; break;
+ case OMP_LIST_SUB: type = "-"; break;
+ case OMP_LIST_AND: type = ".AND."; break;
+ case OMP_LIST_OR: type = ".OR."; break;
+ case OMP_LIST_EQV: type = ".EQV."; break;
+ case OMP_LIST_NEQV: type = ".NEQV."; break;
+ case OMP_LIST_MAX: type = "MAX"; break;
+ case OMP_LIST_MIN: type = "MIN"; break;
+ case OMP_LIST_IAND: type = "IAND"; break;
+ case OMP_LIST_IOR: type = "IOR"; break;
+ case OMP_LIST_IEOR: type = "IEOR"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" REDUCTION(%s:", type);
+ }
+ else
+ {
+ switch (list_type)
+ {
+ case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+ case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+ case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+ case OMP_LIST_SHARED: type = "SHARED"; break;
+ case OMP_LIST_COPYIN: type = "COPYIN"; break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_status (" %s(", type);
+ }
+ gfc_show_namelist (omp_clauses->lists[list_type]);
+ gfc_status_char (')');
+ }
+ }
+ gfc_status_char ('\n');
+ 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);
+ if (d->block == NULL)
+ break;
+ code_indent (level, 0);
+ gfc_status ("!$OMP SECTION\n");
+ d = d->block;
+ }
+ }
+ else
+ gfc_show_code (level + 1, c->block->next);
+ if (c->op == EXEC_OMP_ATOMIC)
+ return;
+ code_indent (level, 0);
+ gfc_status ("!$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 (')');
+ }
+ else if (omp_clauses->nowait)
+ gfc_status (" NOWAIT");
+ }
+ else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
+ gfc_status (" (%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)
+gfc_show_code_node (int level, gfc_code *c)
{
gfc_forall_iterator *fa;
gfc_open *open;
gfc_status ("CONTINUE");
break;
+ case EXEC_ENTRY:
+ gfc_status ("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);
break;
+
case EXEC_LABEL_ASSIGN:
gfc_status ("LABEL ASSIGN ");
gfc_show_expr (c->expr);
case EXEC_GOTO:
gfc_status ("GOTO ");
if (c->label)
- gfc_status ("%d", c->label->value);
+ gfc_status ("%d", c->label->value);
else
- {
- gfc_show_expr (c->expr);
- d = c->block;
- if (d != NULL)
- {
- gfc_status (", (");
- for (; d; d = d ->block)
- {
- code_indent (level, d->label);
- if (d->block != NULL)
- gfc_status_char (',');
- else
- gfc_status_char (')');
- }
- }
- }
+ {
+ gfc_show_expr (c->expr);
+ d = c->block;
+ if (d != NULL)
+ {
+ gfc_status (", (");
+ for (; d; d = d ->block)
+ {
+ code_indent (level, d->label);
+ if (d->block != NULL)
+ gfc_status_char (',');
+ else
+ gfc_status_char (')');
+ }
+ }
+ }
break;
case EXEC_CALL:
- gfc_status ("CALL %s ", c->resolved_sym->name);
+ case EXEC_ASSIGN_CALL:
+ if (c->resolved_sym)
+ gfc_status ("CALL %s ", c->resolved_sym->name);
+ else if (c->symtree)
+ gfc_status ("CALL %s ", c->symtree->name);
+ else
+ gfc_status ("CALL ?? ");
+
gfc_show_actual_arglist (c->ext.actual);
break;
gfc_status ("PAUSE ");
if (c->expr != NULL)
- gfc_show_expr (c->expr);
+ gfc_show_expr (c->expr);
else
- gfc_status ("%d", c->ext.stop_code);
+ gfc_status ("%d", c->ext.stop_code);
break;
gfc_status ("STOP ");
if (c->expr != NULL)
- gfc_show_expr (c->expr);
+ gfc_show_expr (c->expr);
else
- gfc_status ("%d", c->ext.stop_code);
+ gfc_status ("%d", c->ext.stop_code);
break;
gfc_status (" UNIT=");
gfc_show_expr (open->unit);
}
+ if (open->iomsg)
+ {
+ gfc_status (" IOMSG=");
+ gfc_show_expr (open->iomsg);
+ }
if (open->iostat)
{
gfc_status (" IOSTAT=");
gfc_status (" PAD=");
gfc_show_expr (open->pad);
}
+ if (open->convert)
+ {
+ gfc_status (" CONVERT=");
+ gfc_show_expr (open->convert);
+ }
if (open->err != NULL)
gfc_status (" ERR=%d", open->err->value);
gfc_status (" UNIT=");
gfc_show_expr (close->unit);
}
+ if (close->iomsg)
+ {
+ gfc_status (" IOMSG=");
+ gfc_show_expr (close->iomsg);
+ }
if (close->iostat)
{
gfc_status (" IOSTAT=");
case EXEC_REWIND:
gfc_status ("REWIND");
+ goto show_filepos;
+
+ case EXEC_FLUSH:
+ gfc_status ("FLUSH");
show_filepos:
fp = c->ext.filepos;
gfc_status (" UNIT=");
gfc_show_expr (fp->unit);
}
+ if (fp->iomsg)
+ {
+ gfc_status (" IOMSG=");
+ gfc_show_expr (fp->iomsg);
+ }
if (fp->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (i->file);
}
+ if (i->iomsg)
+ {
+ gfc_status (" IOMSG=");
+ gfc_show_expr (i->iomsg);
+ }
if (i->iostat)
{
gfc_status (" IOSTAT=");
gfc_status (" PAD=");
gfc_show_expr (i->pad);
}
+ if (i->convert)
+ {
+ gfc_status (" CONVERT=");
+ gfc_show_expr (i->convert);
+ }
if (i->err != NULL)
gfc_status (" ERR=%d", i->err->value);
case EXEC_IOLENGTH:
gfc_status ("IOLENGTH ");
gfc_show_expr (c->expr);
+ goto show_dt_code;
break;
case EXEC_READ:
gfc_status (" FMT=%d", dt->format_label->value);
if (dt->namelist)
gfc_status (" NML=%s", dt->namelist->name);
+
+ if (dt->iomsg)
+ {
+ gfc_status (" IOMSG=");
+ gfc_show_expr (dt->iomsg);
+ }
if (dt->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (dt->advance);
}
- break;
+ show_dt_code:
+ gfc_status_char ('\n');
+ for (c = c->block->next; c; c = c->next)
+ gfc_show_code_node (level + (c->next != NULL), c);
+ return;
case EXEC_TRANSFER:
gfc_status ("TRANSFER ");
gfc_status (" EOR=%d", dt->eor->value);
break;
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_FLUSH:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_MASTER:
+ case EXEC_OMP_ORDERED:
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_WORKSHARE:
+ gfc_show_omp_node (level, c);
+ break;
+
default:
gfc_internal_error ("gfc_show_code_node(): Bad statement code");
}
}
+/* Show an equivalence chain. */
+
+void
+gfc_show_equiv (gfc_equiv *eq)
+{
+ show_indent ();
+ gfc_status ("Equivalence: ");
+ while (eq)
+ {
+ gfc_show_expr (eq->expr);
+ eq = eq->eq;
+ if (eq)
+ gfc_status (", ");
+ }
+}
+
+
/* Show a freakin' whole namespace. */
void
-gfc_show_namespace (gfc_namespace * ns)
+gfc_show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
gfc_intrinsic_op op;
+ gfc_equiv *eq;
int i;
save = gfc_current_ns;
}
gfc_current_ns = ns;
- gfc_traverse_symtree (ns, show_symtree);
+ gfc_traverse_symtree (ns->common_root, show_common);
+
+ gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
gfc_traverse_user_op (ns, show_uop);
}
}
+
+ for (eq = ns->equiv; eq; eq = eq->next)
+ gfc_show_equiv (eq);
gfc_status_char ('\n');
gfc_status_char ('\n');
OSDN Git Service
