/* Parse tree dumper
|
/* Parse tree dumper
|
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
|
Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Steven Bosscher
|
Contributed by Steven Bosscher
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
/* Actually this is just a collection of routines that used to be
|
/* Actually this is just a collection of routines that used to be
|
scattered around the sources. Now that they are all in a single
|
scattered around the sources. Now that they are all in a single
|
file, almost all of them can be static, and the other files don't
|
file, almost all of them can be static, and the other files don't
|
have this mess in them.
|
have this mess in them.
|
|
|
As a nice side-effect, this file can act as documentation of the
|
As a nice side-effect, this file can act as documentation of the
|
gfc_code and gfc_expr structures and all their friends and
|
gfc_code and gfc_expr structures and all their friends and
|
relatives.
|
relatives.
|
|
|
TODO: Dump DATA. */
|
TODO: Dump DATA. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
|
|
/* Keep track of indentation for symbol tree dumps. */
|
/* Keep track of indentation for symbol tree dumps. */
|
static int show_level = 0;
|
static int show_level = 0;
|
|
|
/* The file handle we're dumping to is kept in a static variable. This
|
/* 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. */
|
is not too cool, but it avoids a lot of passing it around. */
|
static FILE *dumpfile;
|
static FILE *dumpfile;
|
|
|
/* Forward declaration of some of the functions. */
|
/* Forward declaration of some of the functions. */
|
static void show_expr (gfc_expr *p);
|
static void show_expr (gfc_expr *p);
|
static void show_code_node (int, gfc_code *);
|
static void show_code_node (int, gfc_code *);
|
static void show_namespace (gfc_namespace *ns);
|
static void show_namespace (gfc_namespace *ns);
|
|
|
|
|
/* Do indentation for a specific level. */
|
/* Do indentation for a specific level. */
|
|
|
static inline void
|
static inline void
|
code_indent (int level, gfc_st_label *label)
|
code_indent (int level, gfc_st_label *label)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (label != NULL)
|
if (label != NULL)
|
fprintf (dumpfile, "%-5d ", label->value);
|
fprintf (dumpfile, "%-5d ", label->value);
|
else
|
else
|
fputs (" ", dumpfile);
|
fputs (" ", dumpfile);
|
|
|
for (i = 0; i < 2 * level; i++)
|
for (i = 0; i < 2 * level; i++)
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
}
|
}
|
|
|
|
|
/* Simple indentation at the current level. This one
|
/* Simple indentation at the current level. This one
|
is used to show symbols. */
|
is used to show symbols. */
|
|
|
static inline void
|
static inline void
|
show_indent (void)
|
show_indent (void)
|
{
|
{
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
code_indent (show_level, NULL);
|
code_indent (show_level, NULL);
|
}
|
}
|
|
|
|
|
/* Show type-specific information. */
|
/* Show type-specific information. */
|
|
|
static void
|
static void
|
show_typespec (gfc_typespec *ts)
|
show_typespec (gfc_typespec *ts)
|
{
|
{
|
fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
|
fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
|
|
|
switch (ts->type)
|
switch (ts->type)
|
{
|
{
|
case BT_DERIVED:
|
case BT_DERIVED:
|
fprintf (dumpfile, "%s", ts->u.derived->name);
|
fprintf (dumpfile, "%s", ts->u.derived->name);
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
show_expr (ts->u.cl->length);
|
show_expr (ts->u.cl->length);
|
break;
|
break;
|
|
|
default:
|
default:
|
fprintf (dumpfile, "%d", ts->kind);
|
fprintf (dumpfile, "%d", ts->kind);
|
break;
|
break;
|
}
|
}
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show an actual argument list. */
|
/* Show an actual argument list. */
|
|
|
static void
|
static void
|
show_actual_arglist (gfc_actual_arglist *a)
|
show_actual_arglist (gfc_actual_arglist *a)
|
{
|
{
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
|
|
for (; a; a = a->next)
|
for (; a; a = a->next)
|
{
|
{
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
if (a->name != NULL)
|
if (a->name != NULL)
|
fprintf (dumpfile, "%s = ", a->name);
|
fprintf (dumpfile, "%s = ", a->name);
|
if (a->expr != NULL)
|
if (a->expr != NULL)
|
show_expr (a->expr);
|
show_expr (a->expr);
|
else
|
else
|
fputs ("(arg not-present)", dumpfile);
|
fputs ("(arg not-present)", dumpfile);
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
if (a->next != NULL)
|
if (a->next != NULL)
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
}
|
}
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show a gfc_array_spec array specification structure. */
|
/* Show a gfc_array_spec array specification structure. */
|
|
|
static void
|
static void
|
show_array_spec (gfc_array_spec *as)
|
show_array_spec (gfc_array_spec *as)
|
{
|
{
|
const char *c;
|
const char *c;
|
int i;
|
int i;
|
|
|
if (as == NULL)
|
if (as == NULL)
|
{
|
{
|
fputs ("()", dumpfile);
|
fputs ("()", dumpfile);
|
return;
|
return;
|
}
|
}
|
|
|
fprintf (dumpfile, "(%d", as->rank);
|
fprintf (dumpfile, "(%d", as->rank);
|
|
|
if (as->rank != 0)
|
if (as->rank != 0)
|
{
|
{
|
switch (as->type)
|
switch (as->type)
|
{
|
{
|
case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
|
case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
|
case AS_DEFERRED: c = "AS_DEFERRED"; break;
|
case AS_DEFERRED: c = "AS_DEFERRED"; break;
|
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
|
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
|
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
|
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
|
default:
|
default:
|
gfc_internal_error ("show_array_spec(): Unhandled array shape "
|
gfc_internal_error ("show_array_spec(): Unhandled array shape "
|
"type.");
|
"type.");
|
}
|
}
|
fprintf (dumpfile, " %s ", c);
|
fprintf (dumpfile, " %s ", c);
|
|
|
for (i = 0; i < as->rank; i++)
|
for (i = 0; i < as->rank; i++)
|
{
|
{
|
show_expr (as->lower[i]);
|
show_expr (as->lower[i]);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (as->upper[i]);
|
show_expr (as->upper[i]);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
}
|
}
|
}
|
}
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show a gfc_array_ref array reference structure. */
|
/* Show a gfc_array_ref array reference structure. */
|
|
|
static void
|
static void
|
show_array_ref (gfc_array_ref * ar)
|
show_array_ref (gfc_array_ref * ar)
|
{
|
{
|
int i;
|
int i;
|
|
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
|
|
switch (ar->type)
|
switch (ar->type)
|
{
|
{
|
case AR_FULL:
|
case AR_FULL:
|
fputs ("FULL", dumpfile);
|
fputs ("FULL", dumpfile);
|
break;
|
break;
|
|
|
case AR_SECTION:
|
case AR_SECTION:
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
/* There are two types of array sections: either the
|
/* There are two types of array sections: either the
|
elements are identified by an integer array ('vector'),
|
elements are identified by an integer array ('vector'),
|
or by an index range. In the former case we only have to
|
or by an index range. In the former case we only have to
|
print the start expression which contains the vector, in
|
print the start expression which contains the vector, in
|
the latter case we have to print any of lower and upper
|
the latter case we have to print any of lower and upper
|
bound and the stride, if they're present. */
|
bound and the stride, if they're present. */
|
|
|
if (ar->start[i] != NULL)
|
if (ar->start[i] != NULL)
|
show_expr (ar->start[i]);
|
show_expr (ar->start[i]);
|
|
|
if (ar->dimen_type[i] == DIMEN_RANGE)
|
if (ar->dimen_type[i] == DIMEN_RANGE)
|
{
|
{
|
fputc (':', dumpfile);
|
fputc (':', dumpfile);
|
|
|
if (ar->end[i] != NULL)
|
if (ar->end[i] != NULL)
|
show_expr (ar->end[i]);
|
show_expr (ar->end[i]);
|
|
|
if (ar->stride[i] != NULL)
|
if (ar->stride[i] != NULL)
|
{
|
{
|
fputc (':', dumpfile);
|
fputc (':', dumpfile);
|
show_expr (ar->stride[i]);
|
show_expr (ar->stride[i]);
|
}
|
}
|
}
|
}
|
|
|
if (i != ar->dimen - 1)
|
if (i != ar->dimen - 1)
|
fputs (" , ", dumpfile);
|
fputs (" , ", dumpfile);
|
}
|
}
|
break;
|
break;
|
|
|
case AR_ELEMENT:
|
case AR_ELEMENT:
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
show_expr (ar->start[i]);
|
show_expr (ar->start[i]);
|
if (i != ar->dimen - 1)
|
if (i != ar->dimen - 1)
|
fputs (" , ", dumpfile);
|
fputs (" , ", dumpfile);
|
}
|
}
|
break;
|
break;
|
|
|
case AR_UNKNOWN:
|
case AR_UNKNOWN:
|
fputs ("UNKNOWN", dumpfile);
|
fputs ("UNKNOWN", dumpfile);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("show_array_ref(): Unknown array reference");
|
gfc_internal_error ("show_array_ref(): Unknown array reference");
|
}
|
}
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show a list of gfc_ref structures. */
|
/* Show a list of gfc_ref structures. */
|
|
|
static void
|
static void
|
show_ref (gfc_ref *p)
|
show_ref (gfc_ref *p)
|
{
|
{
|
for (; p; p = p->next)
|
for (; p; p = p->next)
|
switch (p->type)
|
switch (p->type)
|
{
|
{
|
case REF_ARRAY:
|
case REF_ARRAY:
|
show_array_ref (&p->u.ar);
|
show_array_ref (&p->u.ar);
|
break;
|
break;
|
|
|
case REF_COMPONENT:
|
case REF_COMPONENT:
|
fprintf (dumpfile, " %% %s", p->u.c.component->name);
|
fprintf (dumpfile, " %% %s", p->u.c.component->name);
|
break;
|
break;
|
|
|
case REF_SUBSTRING:
|
case REF_SUBSTRING:
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
show_expr (p->u.ss.start);
|
show_expr (p->u.ss.start);
|
fputc (':', dumpfile);
|
fputc (':', dumpfile);
|
show_expr (p->u.ss.end);
|
show_expr (p->u.ss.end);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("show_ref(): Bad component code");
|
gfc_internal_error ("show_ref(): Bad component code");
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Display a constructor. Works recursively for array constructors. */
|
/* Display a constructor. Works recursively for array constructors. */
|
|
|
static void
|
static void
|
show_constructor (gfc_constructor *c)
|
show_constructor (gfc_constructor *c)
|
{
|
{
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
{
|
{
|
if (c->iterator == NULL)
|
if (c->iterator == NULL)
|
show_expr (c->expr);
|
show_expr (c->expr);
|
else
|
else
|
{
|
{
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
show_expr (c->expr);
|
show_expr (c->expr);
|
|
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (c->iterator->var);
|
show_expr (c->iterator->var);
|
fputc ('=', dumpfile);
|
fputc ('=', dumpfile);
|
show_expr (c->iterator->start);
|
show_expr (c->iterator->start);
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
show_expr (c->iterator->end);
|
show_expr (c->iterator->end);
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
show_expr (c->iterator->step);
|
show_expr (c->iterator->step);
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
|
|
if (c->next != NULL)
|
if (c->next != NULL)
|
fputs (" , ", dumpfile);
|
fputs (" , ", dumpfile);
|
}
|
}
|
}
|
}
|
|
|
|
|
static void
|
static void
|
show_char_const (const gfc_char_t *c, int length)
|
show_char_const (const gfc_char_t *c, int length)
|
{
|
{
|
int i;
|
int i;
|
|
|
fputc ('\'', dumpfile);
|
fputc ('\'', dumpfile);
|
for (i = 0; i < length; i++)
|
for (i = 0; i < length; i++)
|
{
|
{
|
if (c[i] == '\'')
|
if (c[i] == '\'')
|
fputs ("''", dumpfile);
|
fputs ("''", dumpfile);
|
else
|
else
|
fputs (gfc_print_wide_char (c[i]), dumpfile);
|
fputs (gfc_print_wide_char (c[i]), dumpfile);
|
}
|
}
|
fputc ('\'', dumpfile);
|
fputc ('\'', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show a component-call expression. */
|
/* Show a component-call expression. */
|
|
|
static void
|
static void
|
show_compcall (gfc_expr* p)
|
show_compcall (gfc_expr* p)
|
{
|
{
|
gcc_assert (p->expr_type == EXPR_COMPCALL);
|
gcc_assert (p->expr_type == EXPR_COMPCALL);
|
|
|
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
|
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
|
show_ref (p->ref);
|
show_ref (p->ref);
|
fprintf (dumpfile, "%s", p->value.compcall.name);
|
fprintf (dumpfile, "%s", p->value.compcall.name);
|
|
|
show_actual_arglist (p->value.compcall.actual);
|
show_actual_arglist (p->value.compcall.actual);
|
}
|
}
|
|
|
|
|
/* Show an expression. */
|
/* Show an expression. */
|
|
|
static void
|
static void
|
show_expr (gfc_expr *p)
|
show_expr (gfc_expr *p)
|
{
|
{
|
const char *c;
|
const char *c;
|
int i;
|
int i;
|
|
|
if (p == NULL)
|
if (p == NULL)
|
{
|
{
|
fputs ("()", dumpfile);
|
fputs ("()", dumpfile);
|
return;
|
return;
|
}
|
}
|
|
|
switch (p->expr_type)
|
switch (p->expr_type)
|
{
|
{
|
case EXPR_SUBSTRING:
|
case EXPR_SUBSTRING:
|
show_char_const (p->value.character.string, p->value.character.length);
|
show_char_const (p->value.character.string, p->value.character.length);
|
show_ref (p->ref);
|
show_ref (p->ref);
|
break;
|
break;
|
|
|
case EXPR_STRUCTURE:
|
case EXPR_STRUCTURE:
|
fprintf (dumpfile, "%s(", p->ts.u.derived->name);
|
fprintf (dumpfile, "%s(", p->ts.u.derived->name);
|
show_constructor (p->value.constructor);
|
show_constructor (p->value.constructor);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
break;
|
break;
|
|
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
fputs ("(/ ", dumpfile);
|
fputs ("(/ ", dumpfile);
|
show_constructor (p->value.constructor);
|
show_constructor (p->value.constructor);
|
fputs (" /)", dumpfile);
|
fputs (" /)", dumpfile);
|
|
|
show_ref (p->ref);
|
show_ref (p->ref);
|
break;
|
break;
|
|
|
case EXPR_NULL:
|
case EXPR_NULL:
|
fputs ("NULL()", dumpfile);
|
fputs ("NULL()", dumpfile);
|
break;
|
break;
|
|
|
case EXPR_CONSTANT:
|
case EXPR_CONSTANT:
|
switch (p->ts.type)
|
switch (p->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
mpz_out_str (stdout, 10, p->value.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)
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
break;
|
break;
|
|
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
if (p->value.logical)
|
if (p->value.logical)
|
fputs (".true.", dumpfile);
|
fputs (".true.", dumpfile);
|
else
|
else
|
fputs (".false.", dumpfile);
|
fputs (".false.", dumpfile);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
|
mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
|
if (p->ts.kind != gfc_default_real_kind)
|
if (p->ts.kind != gfc_default_real_kind)
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
show_char_const (p->value.character.string,
|
show_char_const (p->value.character.string,
|
p->value.character.length);
|
p->value.character.length);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
fputs ("(complex ", dumpfile);
|
fputs ("(complex ", dumpfile);
|
|
|
mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
|
mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
if (p->ts.kind != gfc_default_complex_kind)
|
if (p->ts.kind != gfc_default_complex_kind)
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
|
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
|
|
mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
|
mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
|
GFC_RND_MODE);
|
GFC_RND_MODE);
|
if (p->ts.kind != gfc_default_complex_kind)
|
if (p->ts.kind != gfc_default_complex_kind)
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
fprintf (dumpfile, "_%d", p->ts.kind);
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
break;
|
break;
|
|
|
case BT_HOLLERITH:
|
case BT_HOLLERITH:
|
fprintf (dumpfile, "%dH", p->representation.length);
|
fprintf (dumpfile, "%dH", p->representation.length);
|
c = p->representation.string;
|
c = p->representation.string;
|
for (i = 0; i < p->representation.length; i++, c++)
|
for (i = 0; i < p->representation.length; i++, c++)
|
{
|
{
|
fputc (*c, dumpfile);
|
fputc (*c, dumpfile);
|
}
|
}
|
break;
|
break;
|
|
|
default:
|
default:
|
fputs ("???", dumpfile);
|
fputs ("???", dumpfile);
|
break;
|
break;
|
}
|
}
|
|
|
if (p->representation.string)
|
if (p->representation.string)
|
{
|
{
|
fputs (" {", dumpfile);
|
fputs (" {", dumpfile);
|
c = p->representation.string;
|
c = p->representation.string;
|
for (i = 0; i < p->representation.length; i++, c++)
|
for (i = 0; i < p->representation.length; i++, c++)
|
{
|
{
|
fprintf (dumpfile, "%.2x", (unsigned int) *c);
|
fprintf (dumpfile, "%.2x", (unsigned int) *c);
|
if (i < p->representation.length - 1)
|
if (i < p->representation.length - 1)
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
}
|
}
|
fputc ('}', dumpfile);
|
fputc ('}', dumpfile);
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
|
if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
|
fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
|
fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
|
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
|
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
|
show_ref (p->ref);
|
show_ref (p->ref);
|
break;
|
break;
|
|
|
case EXPR_OP:
|
case EXPR_OP:
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
switch (p->value.op.op)
|
switch (p->value.op.op)
|
{
|
{
|
case INTRINSIC_UPLUS:
|
case INTRINSIC_UPLUS:
|
fputs ("U+ ", dumpfile);
|
fputs ("U+ ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_UMINUS:
|
case INTRINSIC_UMINUS:
|
fputs ("U- ", dumpfile);
|
fputs ("U- ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_PLUS:
|
case INTRINSIC_PLUS:
|
fputs ("+ ", dumpfile);
|
fputs ("+ ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_MINUS:
|
case INTRINSIC_MINUS:
|
fputs ("- ", dumpfile);
|
fputs ("- ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_TIMES:
|
case INTRINSIC_TIMES:
|
fputs ("* ", dumpfile);
|
fputs ("* ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_DIVIDE:
|
case INTRINSIC_DIVIDE:
|
fputs ("/ ", dumpfile);
|
fputs ("/ ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_POWER:
|
case INTRINSIC_POWER:
|
fputs ("** ", dumpfile);
|
fputs ("** ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_CONCAT:
|
case INTRINSIC_CONCAT:
|
fputs ("// ", dumpfile);
|
fputs ("// ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_AND:
|
case INTRINSIC_AND:
|
fputs ("AND ", dumpfile);
|
fputs ("AND ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_OR:
|
case INTRINSIC_OR:
|
fputs ("OR ", dumpfile);
|
fputs ("OR ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_EQV:
|
case INTRINSIC_EQV:
|
fputs ("EQV ", dumpfile);
|
fputs ("EQV ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_NEQV:
|
case INTRINSIC_NEQV:
|
fputs ("NEQV ", dumpfile);
|
fputs ("NEQV ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ:
|
case INTRINSIC_EQ_OS:
|
case INTRINSIC_EQ_OS:
|
fputs ("= ", dumpfile);
|
fputs ("= ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_NE:
|
case INTRINSIC_NE:
|
case INTRINSIC_NE_OS:
|
case INTRINSIC_NE_OS:
|
fputs ("/= ", dumpfile);
|
fputs ("/= ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_GT:
|
case INTRINSIC_GT:
|
case INTRINSIC_GT_OS:
|
case INTRINSIC_GT_OS:
|
fputs ("> ", dumpfile);
|
fputs ("> ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_GE:
|
case INTRINSIC_GE:
|
case INTRINSIC_GE_OS:
|
case INTRINSIC_GE_OS:
|
fputs (">= ", dumpfile);
|
fputs (">= ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_LT:
|
case INTRINSIC_LT:
|
case INTRINSIC_LT_OS:
|
case INTRINSIC_LT_OS:
|
fputs ("< ", dumpfile);
|
fputs ("< ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_LE:
|
case INTRINSIC_LE:
|
case INTRINSIC_LE_OS:
|
case INTRINSIC_LE_OS:
|
fputs ("<= ", dumpfile);
|
fputs ("<= ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_NOT:
|
case INTRINSIC_NOT:
|
fputs ("NOT ", dumpfile);
|
fputs ("NOT ", dumpfile);
|
break;
|
break;
|
case INTRINSIC_PARENTHESES:
|
case INTRINSIC_PARENTHESES:
|
fputs ("parens", dumpfile);
|
fputs ("parens", dumpfile);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error
|
gfc_internal_error
|
("show_expr(): Bad intrinsic in expression!");
|
("show_expr(): Bad intrinsic in expression!");
|
}
|
}
|
|
|
show_expr (p->value.op.op1);
|
show_expr (p->value.op.op1);
|
|
|
if (p->value.op.op2)
|
if (p->value.op.op2)
|
{
|
{
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (p->value.op.op2);
|
show_expr (p->value.op.op2);
|
}
|
}
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
break;
|
break;
|
|
|
case EXPR_FUNCTION:
|
case EXPR_FUNCTION:
|
if (p->value.function.name == NULL)
|
if (p->value.function.name == NULL)
|
{
|
{
|
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
|
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
|
if (gfc_is_proc_ptr_comp (p, NULL))
|
if (gfc_is_proc_ptr_comp (p, NULL))
|
show_ref (p->ref);
|
show_ref (p->ref);
|
fputc ('[', dumpfile);
|
fputc ('[', dumpfile);
|
show_actual_arglist (p->value.function.actual);
|
show_actual_arglist (p->value.function.actual);
|
fputc (']', dumpfile);
|
fputc (']', dumpfile);
|
}
|
}
|
else
|
else
|
{
|
{
|
fprintf (dumpfile, "%s", p->value.function.name);
|
fprintf (dumpfile, "%s", p->value.function.name);
|
if (gfc_is_proc_ptr_comp (p, NULL))
|
if (gfc_is_proc_ptr_comp (p, NULL))
|
show_ref (p->ref);
|
show_ref (p->ref);
|
fputc ('[', dumpfile);
|
fputc ('[', dumpfile);
|
fputc ('[', dumpfile);
|
fputc ('[', dumpfile);
|
show_actual_arglist (p->value.function.actual);
|
show_actual_arglist (p->value.function.actual);
|
fputc (']', dumpfile);
|
fputc (']', dumpfile);
|
fputc (']', dumpfile);
|
fputc (']', dumpfile);
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case EXPR_COMPCALL:
|
case EXPR_COMPCALL:
|
show_compcall (p);
|
show_compcall (p);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("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
|
/* Show symbol attributes. The flavor and intent are followed by
|
whatever single bit attributes are present. */
|
whatever single bit attributes are present. */
|
|
|
static void
|
static void
|
show_attr (symbol_attribute *attr)
|
show_attr (symbol_attribute *attr)
|
{
|
{
|
|
|
fprintf (dumpfile, "(%s %s %s %s %s",
|
fprintf (dumpfile, "(%s %s %s %s %s",
|
gfc_code2string (flavors, attr->flavor),
|
gfc_code2string (flavors, attr->flavor),
|
gfc_intent_string (attr->intent),
|
gfc_intent_string (attr->intent),
|
gfc_code2string (access_types, attr->access),
|
gfc_code2string (access_types, attr->access),
|
gfc_code2string (procedures, attr->proc),
|
gfc_code2string (procedures, attr->proc),
|
gfc_code2string (save_status, attr->save));
|
gfc_code2string (save_status, attr->save));
|
|
|
if (attr->allocatable)
|
if (attr->allocatable)
|
fputs (" ALLOCATABLE", dumpfile);
|
fputs (" ALLOCATABLE", dumpfile);
|
if (attr->asynchronous)
|
if (attr->asynchronous)
|
fputs (" ASYNCHRONOUS", dumpfile);
|
fputs (" ASYNCHRONOUS", dumpfile);
|
if (attr->dimension)
|
if (attr->dimension)
|
fputs (" DIMENSION", dumpfile);
|
fputs (" DIMENSION", dumpfile);
|
if (attr->external)
|
if (attr->external)
|
fputs (" EXTERNAL", dumpfile);
|
fputs (" EXTERNAL", dumpfile);
|
if (attr->intrinsic)
|
if (attr->intrinsic)
|
fputs (" INTRINSIC", dumpfile);
|
fputs (" INTRINSIC", dumpfile);
|
if (attr->optional)
|
if (attr->optional)
|
fputs (" OPTIONAL", dumpfile);
|
fputs (" OPTIONAL", dumpfile);
|
if (attr->pointer)
|
if (attr->pointer)
|
fputs (" POINTER", dumpfile);
|
fputs (" POINTER", dumpfile);
|
if (attr->is_protected)
|
if (attr->is_protected)
|
fputs (" PROTECTED", dumpfile);
|
fputs (" PROTECTED", dumpfile);
|
if (attr->value)
|
if (attr->value)
|
fputs (" VALUE", dumpfile);
|
fputs (" VALUE", dumpfile);
|
if (attr->volatile_)
|
if (attr->volatile_)
|
fputs (" VOLATILE", dumpfile);
|
fputs (" VOLATILE", dumpfile);
|
if (attr->threadprivate)
|
if (attr->threadprivate)
|
fputs (" THREADPRIVATE", dumpfile);
|
fputs (" THREADPRIVATE", dumpfile);
|
if (attr->target)
|
if (attr->target)
|
fputs (" TARGET", dumpfile);
|
fputs (" TARGET", dumpfile);
|
if (attr->dummy)
|
if (attr->dummy)
|
fputs (" DUMMY", dumpfile);
|
fputs (" DUMMY", dumpfile);
|
if (attr->result)
|
if (attr->result)
|
fputs (" RESULT", dumpfile);
|
fputs (" RESULT", dumpfile);
|
if (attr->entry)
|
if (attr->entry)
|
fputs (" ENTRY", dumpfile);
|
fputs (" ENTRY", dumpfile);
|
if (attr->is_bind_c)
|
if (attr->is_bind_c)
|
fputs (" BIND(C)", dumpfile);
|
fputs (" BIND(C)", dumpfile);
|
|
|
if (attr->data)
|
if (attr->data)
|
fputs (" DATA", dumpfile);
|
fputs (" DATA", dumpfile);
|
if (attr->use_assoc)
|
if (attr->use_assoc)
|
fputs (" USE-ASSOC", dumpfile);
|
fputs (" USE-ASSOC", dumpfile);
|
if (attr->in_namelist)
|
if (attr->in_namelist)
|
fputs (" IN-NAMELIST", dumpfile);
|
fputs (" IN-NAMELIST", dumpfile);
|
if (attr->in_common)
|
if (attr->in_common)
|
fputs (" IN-COMMON", dumpfile);
|
fputs (" IN-COMMON", dumpfile);
|
|
|
if (attr->abstract)
|
if (attr->abstract)
|
fputs (" ABSTRACT", dumpfile);
|
fputs (" ABSTRACT", dumpfile);
|
if (attr->function)
|
if (attr->function)
|
fputs (" FUNCTION", dumpfile);
|
fputs (" FUNCTION", dumpfile);
|
if (attr->subroutine)
|
if (attr->subroutine)
|
fputs (" SUBROUTINE", dumpfile);
|
fputs (" SUBROUTINE", dumpfile);
|
if (attr->implicit_type)
|
if (attr->implicit_type)
|
fputs (" IMPLICIT-TYPE", dumpfile);
|
fputs (" IMPLICIT-TYPE", dumpfile);
|
|
|
if (attr->sequence)
|
if (attr->sequence)
|
fputs (" SEQUENCE", dumpfile);
|
fputs (" SEQUENCE", dumpfile);
|
if (attr->elemental)
|
if (attr->elemental)
|
fputs (" ELEMENTAL", dumpfile);
|
fputs (" ELEMENTAL", dumpfile);
|
if (attr->pure)
|
if (attr->pure)
|
fputs (" PURE", dumpfile);
|
fputs (" PURE", dumpfile);
|
if (attr->recursive)
|
if (attr->recursive)
|
fputs (" RECURSIVE", dumpfile);
|
fputs (" RECURSIVE", dumpfile);
|
|
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show components of a derived type. */
|
/* Show components of a derived type. */
|
|
|
static void
|
static void
|
show_components (gfc_symbol *sym)
|
show_components (gfc_symbol *sym)
|
{
|
{
|
gfc_component *c;
|
gfc_component *c;
|
|
|
for (c = sym->components; c; c = c->next)
|
for (c = sym->components; c; c = c->next)
|
{
|
{
|
fprintf (dumpfile, "(%s ", c->name);
|
fprintf (dumpfile, "(%s ", c->name);
|
show_typespec (&c->ts);
|
show_typespec (&c->ts);
|
if (c->attr.pointer)
|
if (c->attr.pointer)
|
fputs (" POINTER", dumpfile);
|
fputs (" POINTER", dumpfile);
|
if (c->attr.proc_pointer)
|
if (c->attr.proc_pointer)
|
fputs (" PPC", dumpfile);
|
fputs (" PPC", dumpfile);
|
if (c->attr.dimension)
|
if (c->attr.dimension)
|
fputs (" DIMENSION", dumpfile);
|
fputs (" DIMENSION", dumpfile);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_array_spec (c->as);
|
show_array_spec (c->as);
|
if (c->attr.access)
|
if (c->attr.access)
|
fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
|
fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
if (c->next != NULL)
|
if (c->next != NULL)
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Show the f2k_derived namespace with procedure bindings. */
|
/* Show the f2k_derived namespace with procedure bindings. */
|
|
|
static void
|
static void
|
show_typebound_proc (gfc_typebound_proc* tb, const char* name)
|
show_typebound_proc (gfc_typebound_proc* tb, const char* name)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
|
|
if (tb->is_generic)
|
if (tb->is_generic)
|
fputs ("GENERIC", dumpfile);
|
fputs ("GENERIC", dumpfile);
|
else
|
else
|
{
|
{
|
fputs ("PROCEDURE, ", dumpfile);
|
fputs ("PROCEDURE, ", dumpfile);
|
if (tb->nopass)
|
if (tb->nopass)
|
fputs ("NOPASS", dumpfile);
|
fputs ("NOPASS", dumpfile);
|
else
|
else
|
{
|
{
|
if (tb->pass_arg)
|
if (tb->pass_arg)
|
fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
|
fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
|
else
|
else
|
fputs ("PASS", dumpfile);
|
fputs ("PASS", dumpfile);
|
}
|
}
|
if (tb->non_overridable)
|
if (tb->non_overridable)
|
fputs (", NON_OVERRIDABLE", dumpfile);
|
fputs (", NON_OVERRIDABLE", dumpfile);
|
}
|
}
|
|
|
if (tb->access == ACCESS_PUBLIC)
|
if (tb->access == ACCESS_PUBLIC)
|
fputs (", PUBLIC", dumpfile);
|
fputs (", PUBLIC", dumpfile);
|
else
|
else
|
fputs (", PRIVATE", dumpfile);
|
fputs (", PRIVATE", dumpfile);
|
|
|
fprintf (dumpfile, " :: %s => ", name);
|
fprintf (dumpfile, " :: %s => ", name);
|
|
|
if (tb->is_generic)
|
if (tb->is_generic)
|
{
|
{
|
gfc_tbp_generic* g;
|
gfc_tbp_generic* g;
|
for (g = tb->u.generic; g; g = g->next)
|
for (g = tb->u.generic; g; g = g->next)
|
{
|
{
|
fputs (g->specific_st->name, dumpfile);
|
fputs (g->specific_st->name, dumpfile);
|
if (g->next)
|
if (g->next)
|
fputs (", ", dumpfile);
|
fputs (", ", dumpfile);
|
}
|
}
|
}
|
}
|
else
|
else
|
fputs (tb->u.specific->n.sym->name, dumpfile);
|
fputs (tb->u.specific->n.sym->name, dumpfile);
|
}
|
}
|
|
|
static void
|
static void
|
show_typebound_symtree (gfc_symtree* st)
|
show_typebound_symtree (gfc_symtree* st)
|
{
|
{
|
gcc_assert (st->n.tb);
|
gcc_assert (st->n.tb);
|
show_typebound_proc (st->n.tb, st->name);
|
show_typebound_proc (st->n.tb, st->name);
|
}
|
}
|
|
|
static void
|
static void
|
show_f2k_derived (gfc_namespace* f2k)
|
show_f2k_derived (gfc_namespace* f2k)
|
{
|
{
|
gfc_finalizer* f;
|
gfc_finalizer* f;
|
int op;
|
int op;
|
|
|
show_indent ();
|
show_indent ();
|
fputs ("Procedure bindings:", dumpfile);
|
fputs ("Procedure bindings:", dumpfile);
|
++show_level;
|
++show_level;
|
|
|
/* Finalizer bindings. */
|
/* Finalizer bindings. */
|
for (f = f2k->finalizers; f; f = f->next)
|
for (f = f2k->finalizers; f; f = f->next)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
|
fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
|
}
|
}
|
|
|
/* Type-bound procedures. */
|
/* Type-bound procedures. */
|
gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
|
gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
|
|
|
--show_level;
|
--show_level;
|
|
|
show_indent ();
|
show_indent ();
|
fputs ("Operator bindings:", dumpfile);
|
fputs ("Operator bindings:", dumpfile);
|
++show_level;
|
++show_level;
|
|
|
/* User-defined operators. */
|
/* User-defined operators. */
|
gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
|
gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
|
|
|
/* Intrinsic operators. */
|
/* Intrinsic operators. */
|
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
|
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
|
if (f2k->tb_op[op])
|
if (f2k->tb_op[op])
|
show_typebound_proc (f2k->tb_op[op],
|
show_typebound_proc (f2k->tb_op[op],
|
gfc_op2string ((gfc_intrinsic_op) op));
|
gfc_op2string ((gfc_intrinsic_op) op));
|
|
|
--show_level;
|
--show_level;
|
}
|
}
|
|
|
|
|
/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
|
/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
|
show the interface. Information needed to reconstruct the list of
|
show the interface. Information needed to reconstruct the list of
|
specific interfaces associated with a generic symbol is done within
|
specific interfaces associated with a generic symbol is done within
|
that symbol. */
|
that symbol. */
|
|
|
static void
|
static void
|
show_symbol (gfc_symbol *sym)
|
show_symbol (gfc_symbol *sym)
|
{
|
{
|
gfc_formal_arglist *formal;
|
gfc_formal_arglist *formal;
|
gfc_interface *intr;
|
gfc_interface *intr;
|
|
|
if (sym == NULL)
|
if (sym == NULL)
|
return;
|
return;
|
|
|
show_indent ();
|
show_indent ();
|
|
|
fprintf (dumpfile, "symbol %s ", sym->name);
|
fprintf (dumpfile, "symbol %s ", sym->name);
|
show_typespec (&sym->ts);
|
show_typespec (&sym->ts);
|
show_attr (&sym->attr);
|
show_attr (&sym->attr);
|
|
|
if (sym->value)
|
if (sym->value)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("value: ", dumpfile);
|
fputs ("value: ", dumpfile);
|
show_expr (sym->value);
|
show_expr (sym->value);
|
}
|
}
|
|
|
if (sym->as)
|
if (sym->as)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("Array spec:", dumpfile);
|
fputs ("Array spec:", dumpfile);
|
show_array_spec (sym->as);
|
show_array_spec (sym->as);
|
}
|
}
|
|
|
if (sym->generic)
|
if (sym->generic)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("Generic interfaces:", dumpfile);
|
fputs ("Generic interfaces:", dumpfile);
|
for (intr = sym->generic; intr; intr = intr->next)
|
for (intr = sym->generic; intr; intr = intr->next)
|
fprintf (dumpfile, " %s", intr->sym->name);
|
fprintf (dumpfile, " %s", intr->sym->name);
|
}
|
}
|
|
|
if (sym->result)
|
if (sym->result)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "result: %s", sym->result->name);
|
fprintf (dumpfile, "result: %s", sym->result->name);
|
}
|
}
|
|
|
if (sym->components)
|
if (sym->components)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("components: ", dumpfile);
|
fputs ("components: ", dumpfile);
|
show_components (sym);
|
show_components (sym);
|
}
|
}
|
|
|
if (sym->f2k_derived)
|
if (sym->f2k_derived)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
if (sym->hash_value)
|
if (sym->hash_value)
|
fprintf (dumpfile, "hash: %d", sym->hash_value);
|
fprintf (dumpfile, "hash: %d", sym->hash_value);
|
show_f2k_derived (sym->f2k_derived);
|
show_f2k_derived (sym->f2k_derived);
|
}
|
}
|
|
|
if (sym->formal)
|
if (sym->formal)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("Formal arglist:", dumpfile);
|
fputs ("Formal arglist:", dumpfile);
|
|
|
for (formal = sym->formal; formal; formal = formal->next)
|
for (formal = sym->formal; formal; formal = formal->next)
|
{
|
{
|
if (formal->sym != NULL)
|
if (formal->sym != NULL)
|
fprintf (dumpfile, " %s", formal->sym->name);
|
fprintf (dumpfile, " %s", formal->sym->name);
|
else
|
else
|
fputs (" [Alt Return]", dumpfile);
|
fputs (" [Alt Return]", dumpfile);
|
}
|
}
|
}
|
}
|
|
|
if (sym->formal_ns && (sym->formal_ns->proc_name != sym))
|
if (sym->formal_ns && (sym->formal_ns->proc_name != sym))
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("Formal namespace", dumpfile);
|
fputs ("Formal namespace", dumpfile);
|
show_namespace (sym->formal_ns);
|
show_namespace (sym->formal_ns);
|
}
|
}
|
|
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show a user-defined operator. Just prints an operator
|
/* Show a user-defined operator. Just prints an operator
|
and the name of the associated subroutine, really. */
|
and the name of the associated subroutine, really. */
|
|
|
static void
|
static void
|
show_uop (gfc_user_op *uop)
|
show_uop (gfc_user_op *uop)
|
{
|
{
|
gfc_interface *intr;
|
gfc_interface *intr;
|
|
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "%s:", uop->name);
|
fprintf (dumpfile, "%s:", uop->name);
|
|
|
for (intr = uop->op; intr; intr = intr->next)
|
for (intr = uop->op; intr; intr = intr->next)
|
fprintf (dumpfile, " %s", intr->sym->name);
|
fprintf (dumpfile, " %s", intr->sym->name);
|
}
|
}
|
|
|
|
|
/* Workhorse function for traversing the user operator symtree. */
|
/* Workhorse function for traversing the user operator symtree. */
|
|
|
static void
|
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)
|
if (st == NULL)
|
return;
|
return;
|
|
|
(*func) (st->n.uop);
|
(*func) (st->n.uop);
|
|
|
traverse_uop (st->left, func);
|
traverse_uop (st->left, func);
|
traverse_uop (st->right, func);
|
traverse_uop (st->right, func);
|
}
|
}
|
|
|
|
|
/* Traverse the tree of user operator nodes. */
|
/* Traverse the tree of user operator nodes. */
|
|
|
void
|
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);
|
traverse_uop (ns->uop_root, func);
|
}
|
}
|
|
|
|
|
/* Function to display a common block. */
|
/* Function to display a common block. */
|
|
|
static void
|
static void
|
show_common (gfc_symtree *st)
|
show_common (gfc_symtree *st)
|
{
|
{
|
gfc_symbol *s;
|
gfc_symbol *s;
|
|
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "common: /%s/ ", st->name);
|
fprintf (dumpfile, "common: /%s/ ", st->name);
|
|
|
s = st->n.common->head;
|
s = st->n.common->head;
|
while (s)
|
while (s)
|
{
|
{
|
fprintf (dumpfile, "%s", s->name);
|
fprintf (dumpfile, "%s", s->name);
|
s = s->common_next;
|
s = s->common_next;
|
if (s)
|
if (s)
|
fputs (", ", dumpfile);
|
fputs (", ", dumpfile);
|
}
|
}
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
}
|
}
|
|
|
|
|
/* Worker function to display the symbol tree. */
|
/* Worker function to display the symbol tree. */
|
|
|
static void
|
static void
|
show_symtree (gfc_symtree *st)
|
show_symtree (gfc_symtree *st)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "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)
|
if (st->n.sym->ns != gfc_current_ns)
|
fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
|
fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
|
else
|
else
|
show_symbol (st->n.sym);
|
show_symbol (st->n.sym);
|
}
|
}
|
|
|
|
|
/******************* Show gfc_code structures **************/
|
/******************* Show gfc_code structures **************/
|
|
|
|
|
/* Show a list of code structures. Mutually recursive with
|
/* Show a list of code structures. Mutually recursive with
|
show_code_node(). */
|
show_code_node(). */
|
|
|
static void
|
static void
|
show_code (int level, gfc_code *c)
|
show_code (int level, gfc_code *c)
|
{
|
{
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
show_code_node (level, c);
|
show_code_node (level, c);
|
}
|
}
|
|
|
static void
|
static void
|
show_namelist (gfc_namelist *n)
|
show_namelist (gfc_namelist *n)
|
{
|
{
|
for (; n->next; n = n->next)
|
for (; n->next; n = n->next)
|
fprintf (dumpfile, "%s,", n->sym->name);
|
fprintf (dumpfile, "%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
|
/* Show a single OpenMP directive node and everything underneath it
|
if necessary. */
|
if necessary. */
|
|
|
static void
|
static void
|
show_omp_node (int level, gfc_code *c)
|
show_omp_node (int level, gfc_code *c)
|
{
|
{
|
gfc_omp_clauses *omp_clauses = NULL;
|
gfc_omp_clauses *omp_clauses = NULL;
|
const char *name = NULL;
|
const char *name = NULL;
|
|
|
switch (c->op)
|
switch (c->op)
|
{
|
{
|
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
|
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
|
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
|
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
|
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
|
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
|
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
|
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
|
case EXEC_OMP_DO: name = "DO"; break;
|
case EXEC_OMP_DO: name = "DO"; break;
|
case EXEC_OMP_MASTER: name = "MASTER"; break;
|
case EXEC_OMP_MASTER: name = "MASTER"; break;
|
case EXEC_OMP_ORDERED: name = "ORDERED"; break;
|
case EXEC_OMP_ORDERED: name = "ORDERED"; break;
|
case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
|
case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
|
case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
|
case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
|
case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
|
case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
|
case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
|
case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
|
case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
|
case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
|
case EXEC_OMP_SINGLE: name = "SINGLE"; break;
|
case EXEC_OMP_SINGLE: name = "SINGLE"; break;
|
case EXEC_OMP_TASK: name = "TASK"; break;
|
case EXEC_OMP_TASK: name = "TASK"; break;
|
case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
|
case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
|
case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
|
case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
fprintf (dumpfile, "!$OMP %s", name);
|
fprintf (dumpfile, "!$OMP %s", name);
|
switch (c->op)
|
switch (c->op)
|
{
|
{
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASK:
|
omp_clauses = c->ext.omp_clauses;
|
omp_clauses = c->ext.omp_clauses;
|
break;
|
break;
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_CRITICAL:
|
if (c->ext.omp_name)
|
if (c->ext.omp_name)
|
fprintf (dumpfile, " (%s)", c->ext.omp_name);
|
fprintf (dumpfile, " (%s)", c->ext.omp_name);
|
break;
|
break;
|
case EXEC_OMP_FLUSH:
|
case EXEC_OMP_FLUSH:
|
if (c->ext.omp_namelist)
|
if (c->ext.omp_namelist)
|
{
|
{
|
fputs (" (", dumpfile);
|
fputs (" (", dumpfile);
|
show_namelist (c->ext.omp_namelist);
|
show_namelist (c->ext.omp_namelist);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
return;
|
return;
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_TASKWAIT:
|
return;
|
return;
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
if (omp_clauses)
|
if (omp_clauses)
|
{
|
{
|
int list_type;
|
int list_type;
|
|
|
if (omp_clauses->if_expr)
|
if (omp_clauses->if_expr)
|
{
|
{
|
fputs (" IF(", dumpfile);
|
fputs (" IF(", dumpfile);
|
show_expr (omp_clauses->if_expr);
|
show_expr (omp_clauses->if_expr);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
if (omp_clauses->num_threads)
|
if (omp_clauses->num_threads)
|
{
|
{
|
fputs (" NUM_THREADS(", dumpfile);
|
fputs (" NUM_THREADS(", dumpfile);
|
show_expr (omp_clauses->num_threads);
|
show_expr (omp_clauses->num_threads);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
if (omp_clauses->sched_kind != OMP_SCHED_NONE)
|
if (omp_clauses->sched_kind != OMP_SCHED_NONE)
|
{
|
{
|
const char *type;
|
const char *type;
|
switch (omp_clauses->sched_kind)
|
switch (omp_clauses->sched_kind)
|
{
|
{
|
case OMP_SCHED_STATIC: type = "STATIC"; break;
|
case OMP_SCHED_STATIC: type = "STATIC"; break;
|
case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
|
case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
|
case OMP_SCHED_GUIDED: type = "GUIDED"; break;
|
case OMP_SCHED_GUIDED: type = "GUIDED"; break;
|
case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
|
case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
|
case OMP_SCHED_AUTO: type = "AUTO"; break;
|
case OMP_SCHED_AUTO: type = "AUTO"; break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
fprintf (dumpfile, " SCHEDULE (%s", type);
|
fprintf (dumpfile, " SCHEDULE (%s", type);
|
if (omp_clauses->chunk_size)
|
if (omp_clauses->chunk_size)
|
{
|
{
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
show_expr (omp_clauses->chunk_size);
|
show_expr (omp_clauses->chunk_size);
|
}
|
}
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
|
if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
|
{
|
{
|
const char *type;
|
const char *type;
|
switch (omp_clauses->default_sharing)
|
switch (omp_clauses->default_sharing)
|
{
|
{
|
case OMP_DEFAULT_NONE: type = "NONE"; break;
|
case OMP_DEFAULT_NONE: type = "NONE"; break;
|
case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
|
case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
|
case OMP_DEFAULT_SHARED: type = "SHARED"; break;
|
case OMP_DEFAULT_SHARED: type = "SHARED"; break;
|
case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
|
case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
fprintf (dumpfile, " DEFAULT(%s)", type);
|
fprintf (dumpfile, " DEFAULT(%s)", type);
|
}
|
}
|
if (omp_clauses->ordered)
|
if (omp_clauses->ordered)
|
fputs (" ORDERED", dumpfile);
|
fputs (" ORDERED", dumpfile);
|
if (omp_clauses->untied)
|
if (omp_clauses->untied)
|
fputs (" UNTIED", dumpfile);
|
fputs (" UNTIED", dumpfile);
|
if (omp_clauses->collapse)
|
if (omp_clauses->collapse)
|
fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
|
fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
|
for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
|
for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
|
if (omp_clauses->lists[list_type] != NULL
|
if (omp_clauses->lists[list_type] != NULL
|
&& list_type != OMP_LIST_COPYPRIVATE)
|
&& list_type != OMP_LIST_COPYPRIVATE)
|
{
|
{
|
const char *type;
|
const char *type;
|
if (list_type >= OMP_LIST_REDUCTION_FIRST)
|
if (list_type >= OMP_LIST_REDUCTION_FIRST)
|
{
|
{
|
switch (list_type)
|
switch (list_type)
|
{
|
{
|
case OMP_LIST_PLUS: type = "+"; break;
|
case OMP_LIST_PLUS: type = "+"; break;
|
case OMP_LIST_MULT: type = "*"; break;
|
case OMP_LIST_MULT: type = "*"; break;
|
case OMP_LIST_SUB: type = "-"; break;
|
case OMP_LIST_SUB: type = "-"; break;
|
case OMP_LIST_AND: type = ".AND."; break;
|
case OMP_LIST_AND: type = ".AND."; break;
|
case OMP_LIST_OR: type = ".OR."; break;
|
case OMP_LIST_OR: type = ".OR."; break;
|
case OMP_LIST_EQV: type = ".EQV."; break;
|
case OMP_LIST_EQV: type = ".EQV."; break;
|
case OMP_LIST_NEQV: type = ".NEQV."; break;
|
case OMP_LIST_NEQV: type = ".NEQV."; break;
|
case OMP_LIST_MAX: type = "MAX"; break;
|
case OMP_LIST_MAX: type = "MAX"; break;
|
case OMP_LIST_MIN: type = "MIN"; break;
|
case OMP_LIST_MIN: type = "MIN"; break;
|
case OMP_LIST_IAND: type = "IAND"; break;
|
case OMP_LIST_IAND: type = "IAND"; break;
|
case OMP_LIST_IOR: type = "IOR"; break;
|
case OMP_LIST_IOR: type = "IOR"; break;
|
case OMP_LIST_IEOR: type = "IEOR"; break;
|
case OMP_LIST_IEOR: type = "IEOR"; break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
fprintf (dumpfile, " REDUCTION(%s:", type);
|
fprintf (dumpfile, " REDUCTION(%s:", type);
|
}
|
}
|
else
|
else
|
{
|
{
|
switch (list_type)
|
switch (list_type)
|
{
|
{
|
case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
|
case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
|
case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
|
case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
|
case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
|
case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
|
case OMP_LIST_SHARED: type = "SHARED"; break;
|
case OMP_LIST_SHARED: type = "SHARED"; break;
|
case OMP_LIST_COPYIN: type = "COPYIN"; break;
|
case OMP_LIST_COPYIN: type = "COPYIN"; break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
fprintf (dumpfile, " %s(", type);
|
fprintf (dumpfile, " %s(", type);
|
}
|
}
|
show_namelist (omp_clauses->lists[list_type]);
|
show_namelist (omp_clauses->lists[list_type]);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
}
|
}
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
|
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
|
{
|
{
|
gfc_code *d = c->block;
|
gfc_code *d = c->block;
|
while (d != NULL)
|
while (d != NULL)
|
{
|
{
|
show_code (level + 1, d->next);
|
show_code (level + 1, d->next);
|
if (d->block == NULL)
|
if (d->block == NULL)
|
break;
|
break;
|
code_indent (level, 0);
|
code_indent (level, 0);
|
fputs ("!$OMP SECTION\n", dumpfile);
|
fputs ("!$OMP SECTION\n", dumpfile);
|
d = d->block;
|
d = d->block;
|
}
|
}
|
}
|
}
|
else
|
else
|
show_code (level + 1, c->block->next);
|
show_code (level + 1, c->block->next);
|
if (c->op == EXEC_OMP_ATOMIC)
|
if (c->op == EXEC_OMP_ATOMIC)
|
return;
|
return;
|
code_indent (level, 0);
|
code_indent (level, 0);
|
fprintf (dumpfile, "!$OMP END %s", name);
|
fprintf (dumpfile, "!$OMP END %s", name);
|
if (omp_clauses != NULL)
|
if (omp_clauses != NULL)
|
{
|
{
|
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
|
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
|
{
|
{
|
fputs (" COPYPRIVATE(", dumpfile);
|
fputs (" COPYPRIVATE(", dumpfile);
|
show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
|
show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
else if (omp_clauses->nowait)
|
else if (omp_clauses->nowait)
|
fputs (" NOWAIT", dumpfile);
|
fputs (" NOWAIT", dumpfile);
|
}
|
}
|
else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
|
else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
|
fprintf (dumpfile, " (%s)", c->ext.omp_name);
|
fprintf (dumpfile, " (%s)", c->ext.omp_name);
|
}
|
}
|
|
|
|
|
/* Show a single code node and everything underneath it if necessary. */
|
/* Show a single code node and everything underneath it if necessary. */
|
|
|
static void
|
static void
|
show_code_node (int level, gfc_code *c)
|
show_code_node (int level, gfc_code *c)
|
{
|
{
|
gfc_forall_iterator *fa;
|
gfc_forall_iterator *fa;
|
gfc_open *open;
|
gfc_open *open;
|
gfc_case *cp;
|
gfc_case *cp;
|
gfc_alloc *a;
|
gfc_alloc *a;
|
gfc_code *d;
|
gfc_code *d;
|
gfc_close *close;
|
gfc_close *close;
|
gfc_filepos *fp;
|
gfc_filepos *fp;
|
gfc_inquire *i;
|
gfc_inquire *i;
|
gfc_dt *dt;
|
gfc_dt *dt;
|
|
|
code_indent (level, c->here);
|
code_indent (level, c->here);
|
|
|
switch (c->op)
|
switch (c->op)
|
{
|
{
|
case EXEC_END_PROCEDURE:
|
case EXEC_END_PROCEDURE:
|
break;
|
break;
|
|
|
case EXEC_NOP:
|
case EXEC_NOP:
|
fputs ("NOP", dumpfile);
|
fputs ("NOP", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_CONTINUE:
|
case EXEC_CONTINUE:
|
fputs ("CONTINUE", dumpfile);
|
fputs ("CONTINUE", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_ENTRY:
|
case EXEC_ENTRY:
|
fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
|
fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
|
break;
|
break;
|
|
|
case EXEC_INIT_ASSIGN:
|
case EXEC_INIT_ASSIGN:
|
case EXEC_ASSIGN:
|
case EXEC_ASSIGN:
|
fputs ("ASSIGN ", dumpfile);
|
fputs ("ASSIGN ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (c->expr2);
|
show_expr (c->expr2);
|
break;
|
break;
|
|
|
case EXEC_LABEL_ASSIGN:
|
case EXEC_LABEL_ASSIGN:
|
fputs ("LABEL ASSIGN ", dumpfile);
|
fputs ("LABEL ASSIGN ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
fprintf (dumpfile, " %d", c->label1->value);
|
fprintf (dumpfile, " %d", c->label1->value);
|
break;
|
break;
|
|
|
case EXEC_POINTER_ASSIGN:
|
case EXEC_POINTER_ASSIGN:
|
fputs ("POINTER ASSIGN ", dumpfile);
|
fputs ("POINTER ASSIGN ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (c->expr2);
|
show_expr (c->expr2);
|
break;
|
break;
|
|
|
case EXEC_GOTO:
|
case EXEC_GOTO:
|
fputs ("GOTO ", dumpfile);
|
fputs ("GOTO ", dumpfile);
|
if (c->label1)
|
if (c->label1)
|
fprintf (dumpfile, "%d", c->label1->value);
|
fprintf (dumpfile, "%d", c->label1->value);
|
else
|
else
|
{
|
{
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
d = c->block;
|
d = c->block;
|
if (d != NULL)
|
if (d != NULL)
|
{
|
{
|
fputs (", (", dumpfile);
|
fputs (", (", dumpfile);
|
for (; d; d = d ->block)
|
for (; d; d = d ->block)
|
{
|
{
|
code_indent (level, d->label1);
|
code_indent (level, d->label1);
|
if (d->block != NULL)
|
if (d->block != NULL)
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
else
|
else
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
}
|
}
|
}
|
}
|
}
|
}
|
break;
|
break;
|
|
|
case EXEC_CALL:
|
case EXEC_CALL:
|
case EXEC_ASSIGN_CALL:
|
case EXEC_ASSIGN_CALL:
|
if (c->resolved_sym)
|
if (c->resolved_sym)
|
fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
|
fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
|
else if (c->symtree)
|
else if (c->symtree)
|
fprintf (dumpfile, "CALL %s ", c->symtree->name);
|
fprintf (dumpfile, "CALL %s ", c->symtree->name);
|
else
|
else
|
fputs ("CALL ?? ", dumpfile);
|
fputs ("CALL ?? ", dumpfile);
|
|
|
show_actual_arglist (c->ext.actual);
|
show_actual_arglist (c->ext.actual);
|
break;
|
break;
|
|
|
case EXEC_COMPCALL:
|
case EXEC_COMPCALL:
|
fputs ("CALL ", dumpfile);
|
fputs ("CALL ", dumpfile);
|
show_compcall (c->expr1);
|
show_compcall (c->expr1);
|
break;
|
break;
|
|
|
case EXEC_CALL_PPC:
|
case EXEC_CALL_PPC:
|
fputs ("CALL ", dumpfile);
|
fputs ("CALL ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
show_actual_arglist (c->ext.actual);
|
show_actual_arglist (c->ext.actual);
|
break;
|
break;
|
|
|
case EXEC_RETURN:
|
case EXEC_RETURN:
|
fputs ("RETURN ", dumpfile);
|
fputs ("RETURN ", dumpfile);
|
if (c->expr1)
|
if (c->expr1)
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
break;
|
break;
|
|
|
case EXEC_PAUSE:
|
case EXEC_PAUSE:
|
fputs ("PAUSE ", dumpfile);
|
fputs ("PAUSE ", dumpfile);
|
|
|
if (c->expr1 != NULL)
|
if (c->expr1 != NULL)
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
else
|
else
|
fprintf (dumpfile, "%d", c->ext.stop_code);
|
fprintf (dumpfile, "%d", c->ext.stop_code);
|
|
|
break;
|
break;
|
|
|
case EXEC_STOP:
|
case EXEC_STOP:
|
fputs ("STOP ", dumpfile);
|
fputs ("STOP ", dumpfile);
|
|
|
if (c->expr1 != NULL)
|
if (c->expr1 != NULL)
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
else
|
else
|
fprintf (dumpfile, "%d", c->ext.stop_code);
|
fprintf (dumpfile, "%d", c->ext.stop_code);
|
|
|
break;
|
break;
|
|
|
case EXEC_ARITHMETIC_IF:
|
case EXEC_ARITHMETIC_IF:
|
fputs ("IF ", dumpfile);
|
fputs ("IF ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
fprintf (dumpfile, " %d, %d, %d",
|
fprintf (dumpfile, " %d, %d, %d",
|
c->label1->value, c->label2->value, c->label3->value);
|
c->label1->value, c->label2->value, c->label3->value);
|
break;
|
break;
|
|
|
case EXEC_IF:
|
case EXEC_IF:
|
d = c->block;
|
d = c->block;
|
fputs ("IF ", dumpfile);
|
fputs ("IF ", dumpfile);
|
show_expr (d->expr1);
|
show_expr (d->expr1);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
show_code (level + 1, d->next);
|
show_code (level + 1, d->next);
|
|
|
d = d->block;
|
d = d->block;
|
for (; d; d = d->block)
|
for (; d; d = d->block)
|
{
|
{
|
code_indent (level, 0);
|
code_indent (level, 0);
|
|
|
if (d->expr1 == NULL)
|
if (d->expr1 == NULL)
|
fputs ("ELSE\n", dumpfile);
|
fputs ("ELSE\n", dumpfile);
|
else
|
else
|
{
|
{
|
fputs ("ELSE IF ", dumpfile);
|
fputs ("ELSE IF ", dumpfile);
|
show_expr (d->expr1);
|
show_expr (d->expr1);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
}
|
}
|
|
|
show_code (level + 1, d->next);
|
show_code (level + 1, d->next);
|
}
|
}
|
|
|
code_indent (level, c->label1);
|
code_indent (level, c->label1);
|
|
|
fputs ("ENDIF", dumpfile);
|
fputs ("ENDIF", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_SELECT:
|
case EXEC_SELECT:
|
d = c->block;
|
d = c->block;
|
fputs ("SELECT CASE ", dumpfile);
|
fputs ("SELECT CASE ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
for (; d; d = d->block)
|
for (; d; d = d->block)
|
{
|
{
|
code_indent (level, 0);
|
code_indent (level, 0);
|
|
|
fputs ("CASE ", dumpfile);
|
fputs ("CASE ", dumpfile);
|
for (cp = d->ext.case_list; cp; cp = cp->next)
|
for (cp = d->ext.case_list; cp; cp = cp->next)
|
{
|
{
|
fputc ('(', dumpfile);
|
fputc ('(', dumpfile);
|
show_expr (cp->low);
|
show_expr (cp->low);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (cp->high);
|
show_expr (cp->high);
|
fputc (')', dumpfile);
|
fputc (')', dumpfile);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
}
|
}
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
show_code (level + 1, d->next);
|
show_code (level + 1, d->next);
|
}
|
}
|
|
|
code_indent (level, c->label1);
|
code_indent (level, c->label1);
|
fputs ("END SELECT", dumpfile);
|
fputs ("END SELECT", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_WHERE:
|
case EXEC_WHERE:
|
fputs ("WHERE ", dumpfile);
|
fputs ("WHERE ", dumpfile);
|
|
|
d = c->block;
|
d = c->block;
|
show_expr (d->expr1);
|
show_expr (d->expr1);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
show_code (level + 1, d->next);
|
show_code (level + 1, d->next);
|
|
|
for (d = d->block; d; d = d->block)
|
for (d = d->block; d; d = d->block)
|
{
|
{
|
code_indent (level, 0);
|
code_indent (level, 0);
|
fputs ("ELSE WHERE ", dumpfile);
|
fputs ("ELSE WHERE ", dumpfile);
|
show_expr (d->expr1);
|
show_expr (d->expr1);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
show_code (level + 1, d->next);
|
show_code (level + 1, d->next);
|
}
|
}
|
|
|
code_indent (level, 0);
|
code_indent (level, 0);
|
fputs ("END WHERE", dumpfile);
|
fputs ("END WHERE", dumpfile);
|
break;
|
break;
|
|
|
|
|
case EXEC_FORALL:
|
case EXEC_FORALL:
|
fputs ("FORALL ", dumpfile);
|
fputs ("FORALL ", dumpfile);
|
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
|
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
|
{
|
{
|
show_expr (fa->var);
|
show_expr (fa->var);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (fa->start);
|
show_expr (fa->start);
|
fputc (':', dumpfile);
|
fputc (':', dumpfile);
|
show_expr (fa->end);
|
show_expr (fa->end);
|
fputc (':', dumpfile);
|
fputc (':', dumpfile);
|
show_expr (fa->stride);
|
show_expr (fa->stride);
|
|
|
if (fa->next != NULL)
|
if (fa->next != NULL)
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
}
|
}
|
|
|
if (c->expr1 != NULL)
|
if (c->expr1 != NULL)
|
{
|
{
|
fputc (',', dumpfile);
|
fputc (',', dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
}
|
}
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
show_code (level + 1, c->block->next);
|
show_code (level + 1, c->block->next);
|
|
|
code_indent (level, 0);
|
code_indent (level, 0);
|
fputs ("END FORALL", dumpfile);
|
fputs ("END FORALL", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_DO:
|
case EXEC_DO:
|
fputs ("DO ", dumpfile);
|
fputs ("DO ", dumpfile);
|
|
|
show_expr (c->ext.iterator->var);
|
show_expr (c->ext.iterator->var);
|
fputc ('=', dumpfile);
|
fputc ('=', dumpfile);
|
show_expr (c->ext.iterator->start);
|
show_expr (c->ext.iterator->start);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (c->ext.iterator->end);
|
show_expr (c->ext.iterator->end);
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (c->ext.iterator->step);
|
show_expr (c->ext.iterator->step);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
show_code (level + 1, c->block->next);
|
show_code (level + 1, c->block->next);
|
|
|
code_indent (level, 0);
|
code_indent (level, 0);
|
fputs ("END DO", dumpfile);
|
fputs ("END DO", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_DO_WHILE:
|
case EXEC_DO_WHILE:
|
fputs ("DO WHILE ", dumpfile);
|
fputs ("DO WHILE ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
show_code (level + 1, c->block->next);
|
show_code (level + 1, c->block->next);
|
|
|
code_indent (level, c->label1);
|
code_indent (level, c->label1);
|
fputs ("END DO", dumpfile);
|
fputs ("END DO", dumpfile);
|
break;
|
break;
|
|
|
case EXEC_CYCLE:
|
case EXEC_CYCLE:
|
fputs ("CYCLE", dumpfile);
|
fputs ("CYCLE", dumpfile);
|
if (c->symtree)
|
if (c->symtree)
|
fprintf (dumpfile, " %s", c->symtree->n.sym->name);
|
fprintf (dumpfile, " %s", c->symtree->n.sym->name);
|
break;
|
break;
|
|
|
case EXEC_EXIT:
|
case EXEC_EXIT:
|
fputs ("EXIT", dumpfile);
|
fputs ("EXIT", dumpfile);
|
if (c->symtree)
|
if (c->symtree)
|
fprintf (dumpfile, " %s", c->symtree->n.sym->name);
|
fprintf (dumpfile, " %s", c->symtree->n.sym->name);
|
break;
|
break;
|
|
|
case EXEC_ALLOCATE:
|
case EXEC_ALLOCATE:
|
fputs ("ALLOCATE ", dumpfile);
|
fputs ("ALLOCATE ", dumpfile);
|
if (c->expr1)
|
if (c->expr1)
|
{
|
{
|
fputs (" STAT=", dumpfile);
|
fputs (" STAT=", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
}
|
}
|
|
|
if (c->expr2)
|
if (c->expr2)
|
{
|
{
|
fputs (" ERRMSG=", dumpfile);
|
fputs (" ERRMSG=", dumpfile);
|
show_expr (c->expr2);
|
show_expr (c->expr2);
|
}
|
}
|
|
|
for (a = c->ext.alloc.list; a; a = a->next)
|
for (a = c->ext.alloc.list; a; a = a->next)
|
{
|
{
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (a->expr);
|
show_expr (a->expr);
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case EXEC_DEALLOCATE:
|
case EXEC_DEALLOCATE:
|
fputs ("DEALLOCATE ", dumpfile);
|
fputs ("DEALLOCATE ", dumpfile);
|
if (c->expr1)
|
if (c->expr1)
|
{
|
{
|
fputs (" STAT=", dumpfile);
|
fputs (" STAT=", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
}
|
}
|
|
|
if (c->expr2)
|
if (c->expr2)
|
{
|
{
|
fputs (" ERRMSG=", dumpfile);
|
fputs (" ERRMSG=", dumpfile);
|
show_expr (c->expr2);
|
show_expr (c->expr2);
|
}
|
}
|
|
|
for (a = c->ext.alloc.list; a; a = a->next)
|
for (a = c->ext.alloc.list; a; a = a->next)
|
{
|
{
|
fputc (' ', dumpfile);
|
fputc (' ', dumpfile);
|
show_expr (a->expr);
|
show_expr (a->expr);
|
}
|
}
|
|
|
break;
|
break;
|
|
|
case EXEC_OPEN:
|
case EXEC_OPEN:
|
fputs ("OPEN", dumpfile);
|
fputs ("OPEN", dumpfile);
|
open = c->ext.open;
|
open = c->ext.open;
|
|
|
if (open->unit)
|
if (open->unit)
|
{
|
{
|
fputs (" UNIT=", dumpfile);
|
fputs (" UNIT=", dumpfile);
|
show_expr (open->unit);
|
show_expr (open->unit);
|
}
|
}
|
if (open->iomsg)
|
if (open->iomsg)
|
{
|
{
|
fputs (" IOMSG=", dumpfile);
|
fputs (" IOMSG=", dumpfile);
|
show_expr (open->iomsg);
|
show_expr (open->iomsg);
|
}
|
}
|
if (open->iostat)
|
if (open->iostat)
|
{
|
{
|
fputs (" IOSTAT=", dumpfile);
|
fputs (" IOSTAT=", dumpfile);
|
show_expr (open->iostat);
|
show_expr (open->iostat);
|
}
|
}
|
if (open->file)
|
if (open->file)
|
{
|
{
|
fputs (" FILE=", dumpfile);
|
fputs (" FILE=", dumpfile);
|
show_expr (open->file);
|
show_expr (open->file);
|
}
|
}
|
if (open->status)
|
if (open->status)
|
{
|
{
|
fputs (" STATUS=", dumpfile);
|
fputs (" STATUS=", dumpfile);
|
show_expr (open->status);
|
show_expr (open->status);
|
}
|
}
|
if (open->access)
|
if (open->access)
|
{
|
{
|
fputs (" ACCESS=", dumpfile);
|
fputs (" ACCESS=", dumpfile);
|
show_expr (open->access);
|
show_expr (open->access);
|
}
|
}
|
if (open->form)
|
if (open->form)
|
{
|
{
|
fputs (" FORM=", dumpfile);
|
fputs (" FORM=", dumpfile);
|
show_expr (open->form);
|
show_expr (open->form);
|
}
|
}
|
if (open->recl)
|
if (open->recl)
|
{
|
{
|
fputs (" RECL=", dumpfile);
|
fputs (" RECL=", dumpfile);
|
show_expr (open->recl);
|
show_expr (open->recl);
|
}
|
}
|
if (open->blank)
|
if (open->blank)
|
{
|
{
|
fputs (" BLANK=", dumpfile);
|
fputs (" BLANK=", dumpfile);
|
show_expr (open->blank);
|
show_expr (open->blank);
|
}
|
}
|
if (open->position)
|
if (open->position)
|
{
|
{
|
fputs (" POSITION=", dumpfile);
|
fputs (" POSITION=", dumpfile);
|
show_expr (open->position);
|
show_expr (open->position);
|
}
|
}
|
if (open->action)
|
if (open->action)
|
{
|
{
|
fputs (" ACTION=", dumpfile);
|
fputs (" ACTION=", dumpfile);
|
show_expr (open->action);
|
show_expr (open->action);
|
}
|
}
|
if (open->delim)
|
if (open->delim)
|
{
|
{
|
fputs (" DELIM=", dumpfile);
|
fputs (" DELIM=", dumpfile);
|
show_expr (open->delim);
|
show_expr (open->delim);
|
}
|
}
|
if (open->pad)
|
if (open->pad)
|
{
|
{
|
fputs (" PAD=", dumpfile);
|
fputs (" PAD=", dumpfile);
|
show_expr (open->pad);
|
show_expr (open->pad);
|
}
|
}
|
if (open->decimal)
|
if (open->decimal)
|
{
|
{
|
fputs (" DECIMAL=", dumpfile);
|
fputs (" DECIMAL=", dumpfile);
|
show_expr (open->decimal);
|
show_expr (open->decimal);
|
}
|
}
|
if (open->encoding)
|
if (open->encoding)
|
{
|
{
|
fputs (" ENCODING=", dumpfile);
|
fputs (" ENCODING=", dumpfile);
|
show_expr (open->encoding);
|
show_expr (open->encoding);
|
}
|
}
|
if (open->round)
|
if (open->round)
|
{
|
{
|
fputs (" ROUND=", dumpfile);
|
fputs (" ROUND=", dumpfile);
|
show_expr (open->round);
|
show_expr (open->round);
|
}
|
}
|
if (open->sign)
|
if (open->sign)
|
{
|
{
|
fputs (" SIGN=", dumpfile);
|
fputs (" SIGN=", dumpfile);
|
show_expr (open->sign);
|
show_expr (open->sign);
|
}
|
}
|
if (open->convert)
|
if (open->convert)
|
{
|
{
|
fputs (" CONVERT=", dumpfile);
|
fputs (" CONVERT=", dumpfile);
|
show_expr (open->convert);
|
show_expr (open->convert);
|
}
|
}
|
if (open->asynchronous)
|
if (open->asynchronous)
|
{
|
{
|
fputs (" ASYNCHRONOUS=", dumpfile);
|
fputs (" ASYNCHRONOUS=", dumpfile);
|
show_expr (open->asynchronous);
|
show_expr (open->asynchronous);
|
}
|
}
|
if (open->err != NULL)
|
if (open->err != NULL)
|
fprintf (dumpfile, " ERR=%d", open->err->value);
|
fprintf (dumpfile, " ERR=%d", open->err->value);
|
|
|
break;
|
break;
|
|
|
case EXEC_CLOSE:
|
case EXEC_CLOSE:
|
fputs ("CLOSE", dumpfile);
|
fputs ("CLOSE", dumpfile);
|
close = c->ext.close;
|
close = c->ext.close;
|
|
|
if (close->unit)
|
if (close->unit)
|
{
|
{
|
fputs (" UNIT=", dumpfile);
|
fputs (" UNIT=", dumpfile);
|
show_expr (close->unit);
|
show_expr (close->unit);
|
}
|
}
|
if (close->iomsg)
|
if (close->iomsg)
|
{
|
{
|
fputs (" IOMSG=", dumpfile);
|
fputs (" IOMSG=", dumpfile);
|
show_expr (close->iomsg);
|
show_expr (close->iomsg);
|
}
|
}
|
if (close->iostat)
|
if (close->iostat)
|
{
|
{
|
fputs (" IOSTAT=", dumpfile);
|
fputs (" IOSTAT=", dumpfile);
|
show_expr (close->iostat);
|
show_expr (close->iostat);
|
}
|
}
|
if (close->status)
|
if (close->status)
|
{
|
{
|
fputs (" STATUS=", dumpfile);
|
fputs (" STATUS=", dumpfile);
|
show_expr (close->status);
|
show_expr (close->status);
|
}
|
}
|
if (close->err != NULL)
|
if (close->err != NULL)
|
fprintf (dumpfile, " ERR=%d", close->err->value);
|
fprintf (dumpfile, " ERR=%d", close->err->value);
|
break;
|
break;
|
|
|
case EXEC_BACKSPACE:
|
case EXEC_BACKSPACE:
|
fputs ("BACKSPACE", dumpfile);
|
fputs ("BACKSPACE", dumpfile);
|
goto show_filepos;
|
goto show_filepos;
|
|
|
case EXEC_ENDFILE:
|
case EXEC_ENDFILE:
|
fputs ("ENDFILE", dumpfile);
|
fputs ("ENDFILE", dumpfile);
|
goto show_filepos;
|
goto show_filepos;
|
|
|
case EXEC_REWIND:
|
case EXEC_REWIND:
|
fputs ("REWIND", dumpfile);
|
fputs ("REWIND", dumpfile);
|
goto show_filepos;
|
goto show_filepos;
|
|
|
case EXEC_FLUSH:
|
case EXEC_FLUSH:
|
fputs ("FLUSH", dumpfile);
|
fputs ("FLUSH", dumpfile);
|
|
|
show_filepos:
|
show_filepos:
|
fp = c->ext.filepos;
|
fp = c->ext.filepos;
|
|
|
if (fp->unit)
|
if (fp->unit)
|
{
|
{
|
fputs (" UNIT=", dumpfile);
|
fputs (" UNIT=", dumpfile);
|
show_expr (fp->unit);
|
show_expr (fp->unit);
|
}
|
}
|
if (fp->iomsg)
|
if (fp->iomsg)
|
{
|
{
|
fputs (" IOMSG=", dumpfile);
|
fputs (" IOMSG=", dumpfile);
|
show_expr (fp->iomsg);
|
show_expr (fp->iomsg);
|
}
|
}
|
if (fp->iostat)
|
if (fp->iostat)
|
{
|
{
|
fputs (" IOSTAT=", dumpfile);
|
fputs (" IOSTAT=", dumpfile);
|
show_expr (fp->iostat);
|
show_expr (fp->iostat);
|
}
|
}
|
if (fp->err != NULL)
|
if (fp->err != NULL)
|
fprintf (dumpfile, " ERR=%d", fp->err->value);
|
fprintf (dumpfile, " ERR=%d", fp->err->value);
|
break;
|
break;
|
|
|
case EXEC_INQUIRE:
|
case EXEC_INQUIRE:
|
fputs ("INQUIRE", dumpfile);
|
fputs ("INQUIRE", dumpfile);
|
i = c->ext.inquire;
|
i = c->ext.inquire;
|
|
|
if (i->unit)
|
if (i->unit)
|
{
|
{
|
fputs (" UNIT=", dumpfile);
|
fputs (" UNIT=", dumpfile);
|
show_expr (i->unit);
|
show_expr (i->unit);
|
}
|
}
|
if (i->file)
|
if (i->file)
|
{
|
{
|
fputs (" FILE=", dumpfile);
|
fputs (" FILE=", dumpfile);
|
show_expr (i->file);
|
show_expr (i->file);
|
}
|
}
|
|
|
if (i->iomsg)
|
if (i->iomsg)
|
{
|
{
|
fputs (" IOMSG=", dumpfile);
|
fputs (" IOMSG=", dumpfile);
|
show_expr (i->iomsg);
|
show_expr (i->iomsg);
|
}
|
}
|
if (i->iostat)
|
if (i->iostat)
|
{
|
{
|
fputs (" IOSTAT=", dumpfile);
|
fputs (" IOSTAT=", dumpfile);
|
show_expr (i->iostat);
|
show_expr (i->iostat);
|
}
|
}
|
if (i->exist)
|
if (i->exist)
|
{
|
{
|
fputs (" EXIST=", dumpfile);
|
fputs (" EXIST=", dumpfile);
|
show_expr (i->exist);
|
show_expr (i->exist);
|
}
|
}
|
if (i->opened)
|
if (i->opened)
|
{
|
{
|
fputs (" OPENED=", dumpfile);
|
fputs (" OPENED=", dumpfile);
|
show_expr (i->opened);
|
show_expr (i->opened);
|
}
|
}
|
if (i->number)
|
if (i->number)
|
{
|
{
|
fputs (" NUMBER=", dumpfile);
|
fputs (" NUMBER=", dumpfile);
|
show_expr (i->number);
|
show_expr (i->number);
|
}
|
}
|
if (i->named)
|
if (i->named)
|
{
|
{
|
fputs (" NAMED=", dumpfile);
|
fputs (" NAMED=", dumpfile);
|
show_expr (i->named);
|
show_expr (i->named);
|
}
|
}
|
if (i->name)
|
if (i->name)
|
{
|
{
|
fputs (" NAME=", dumpfile);
|
fputs (" NAME=", dumpfile);
|
show_expr (i->name);
|
show_expr (i->name);
|
}
|
}
|
if (i->access)
|
if (i->access)
|
{
|
{
|
fputs (" ACCESS=", dumpfile);
|
fputs (" ACCESS=", dumpfile);
|
show_expr (i->access);
|
show_expr (i->access);
|
}
|
}
|
if (i->sequential)
|
if (i->sequential)
|
{
|
{
|
fputs (" SEQUENTIAL=", dumpfile);
|
fputs (" SEQUENTIAL=", dumpfile);
|
show_expr (i->sequential);
|
show_expr (i->sequential);
|
}
|
}
|
|
|
if (i->direct)
|
if (i->direct)
|
{
|
{
|
fputs (" DIRECT=", dumpfile);
|
fputs (" DIRECT=", dumpfile);
|
show_expr (i->direct);
|
show_expr (i->direct);
|
}
|
}
|
if (i->form)
|
if (i->form)
|
{
|
{
|
fputs (" FORM=", dumpfile);
|
fputs (" FORM=", dumpfile);
|
show_expr (i->form);
|
show_expr (i->form);
|
}
|
}
|
if (i->formatted)
|
if (i->formatted)
|
{
|
{
|
fputs (" FORMATTED", dumpfile);
|
fputs (" FORMATTED", dumpfile);
|
show_expr (i->formatted);
|
show_expr (i->formatted);
|
}
|
}
|
if (i->unformatted)
|
if (i->unformatted)
|
{
|
{
|
fputs (" UNFORMATTED=", dumpfile);
|
fputs (" UNFORMATTED=", dumpfile);
|
show_expr (i->unformatted);
|
show_expr (i->unformatted);
|
}
|
}
|
if (i->recl)
|
if (i->recl)
|
{
|
{
|
fputs (" RECL=", dumpfile);
|
fputs (" RECL=", dumpfile);
|
show_expr (i->recl);
|
show_expr (i->recl);
|
}
|
}
|
if (i->nextrec)
|
if (i->nextrec)
|
{
|
{
|
fputs (" NEXTREC=", dumpfile);
|
fputs (" NEXTREC=", dumpfile);
|
show_expr (i->nextrec);
|
show_expr (i->nextrec);
|
}
|
}
|
if (i->blank)
|
if (i->blank)
|
{
|
{
|
fputs (" BLANK=", dumpfile);
|
fputs (" BLANK=", dumpfile);
|
show_expr (i->blank);
|
show_expr (i->blank);
|
}
|
}
|
if (i->position)
|
if (i->position)
|
{
|
{
|
fputs (" POSITION=", dumpfile);
|
fputs (" POSITION=", dumpfile);
|
show_expr (i->position);
|
show_expr (i->position);
|
}
|
}
|
if (i->action)
|
if (i->action)
|
{
|
{
|
fputs (" ACTION=", dumpfile);
|
fputs (" ACTION=", dumpfile);
|
show_expr (i->action);
|
show_expr (i->action);
|
}
|
}
|
if (i->read)
|
if (i->read)
|
{
|
{
|
fputs (" READ=", dumpfile);
|
fputs (" READ=", dumpfile);
|
show_expr (i->read);
|
show_expr (i->read);
|
}
|
}
|
if (i->write)
|
if (i->write)
|
{
|
{
|
fputs (" WRITE=", dumpfile);
|
fputs (" WRITE=", dumpfile);
|
show_expr (i->write);
|
show_expr (i->write);
|
}
|
}
|
if (i->readwrite)
|
if (i->readwrite)
|
{
|
{
|
fputs (" READWRITE=", dumpfile);
|
fputs (" READWRITE=", dumpfile);
|
show_expr (i->readwrite);
|
show_expr (i->readwrite);
|
}
|
}
|
if (i->delim)
|
if (i->delim)
|
{
|
{
|
fputs (" DELIM=", dumpfile);
|
fputs (" DELIM=", dumpfile);
|
show_expr (i->delim);
|
show_expr (i->delim);
|
}
|
}
|
if (i->pad)
|
if (i->pad)
|
{
|
{
|
fputs (" PAD=", dumpfile);
|
fputs (" PAD=", dumpfile);
|
show_expr (i->pad);
|
show_expr (i->pad);
|
}
|
}
|
if (i->convert)
|
if (i->convert)
|
{
|
{
|
fputs (" CONVERT=", dumpfile);
|
fputs (" CONVERT=", dumpfile);
|
show_expr (i->convert);
|
show_expr (i->convert);
|
}
|
}
|
if (i->asynchronous)
|
if (i->asynchronous)
|
{
|
{
|
fputs (" ASYNCHRONOUS=", dumpfile);
|
fputs (" ASYNCHRONOUS=", dumpfile);
|
show_expr (i->asynchronous);
|
show_expr (i->asynchronous);
|
}
|
}
|
if (i->decimal)
|
if (i->decimal)
|
{
|
{
|
fputs (" DECIMAL=", dumpfile);
|
fputs (" DECIMAL=", dumpfile);
|
show_expr (i->decimal);
|
show_expr (i->decimal);
|
}
|
}
|
if (i->encoding)
|
if (i->encoding)
|
{
|
{
|
fputs (" ENCODING=", dumpfile);
|
fputs (" ENCODING=", dumpfile);
|
show_expr (i->encoding);
|
show_expr (i->encoding);
|
}
|
}
|
if (i->pending)
|
if (i->pending)
|
{
|
{
|
fputs (" PENDING=", dumpfile);
|
fputs (" PENDING=", dumpfile);
|
show_expr (i->pending);
|
show_expr (i->pending);
|
}
|
}
|
if (i->round)
|
if (i->round)
|
{
|
{
|
fputs (" ROUND=", dumpfile);
|
fputs (" ROUND=", dumpfile);
|
show_expr (i->round);
|
show_expr (i->round);
|
}
|
}
|
if (i->sign)
|
if (i->sign)
|
{
|
{
|
fputs (" SIGN=", dumpfile);
|
fputs (" SIGN=", dumpfile);
|
show_expr (i->sign);
|
show_expr (i->sign);
|
}
|
}
|
if (i->size)
|
if (i->size)
|
{
|
{
|
fputs (" SIZE=", dumpfile);
|
fputs (" SIZE=", dumpfile);
|
show_expr (i->size);
|
show_expr (i->size);
|
}
|
}
|
if (i->id)
|
if (i->id)
|
{
|
{
|
fputs (" ID=", dumpfile);
|
fputs (" ID=", dumpfile);
|
show_expr (i->id);
|
show_expr (i->id);
|
}
|
}
|
|
|
if (i->err != NULL)
|
if (i->err != NULL)
|
fprintf (dumpfile, " ERR=%d", i->err->value);
|
fprintf (dumpfile, " ERR=%d", i->err->value);
|
break;
|
break;
|
|
|
case EXEC_IOLENGTH:
|
case EXEC_IOLENGTH:
|
fputs ("IOLENGTH ", dumpfile);
|
fputs ("IOLENGTH ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
goto show_dt_code;
|
goto show_dt_code;
|
break;
|
break;
|
|
|
case EXEC_READ:
|
case EXEC_READ:
|
fputs ("READ", dumpfile);
|
fputs ("READ", dumpfile);
|
goto show_dt;
|
goto show_dt;
|
|
|
case EXEC_WRITE:
|
case EXEC_WRITE:
|
fputs ("WRITE", dumpfile);
|
fputs ("WRITE", dumpfile);
|
|
|
show_dt:
|
show_dt:
|
dt = c->ext.dt;
|
dt = c->ext.dt;
|
if (dt->io_unit)
|
if (dt->io_unit)
|
{
|
{
|
fputs (" UNIT=", dumpfile);
|
fputs (" UNIT=", dumpfile);
|
show_expr (dt->io_unit);
|
show_expr (dt->io_unit);
|
}
|
}
|
|
|
if (dt->format_expr)
|
if (dt->format_expr)
|
{
|
{
|
fputs (" FMT=", dumpfile);
|
fputs (" FMT=", dumpfile);
|
show_expr (dt->format_expr);
|
show_expr (dt->format_expr);
|
}
|
}
|
|
|
if (dt->format_label != NULL)
|
if (dt->format_label != NULL)
|
fprintf (dumpfile, " FMT=%d", dt->format_label->value);
|
fprintf (dumpfile, " FMT=%d", dt->format_label->value);
|
if (dt->namelist)
|
if (dt->namelist)
|
fprintf (dumpfile, " NML=%s", dt->namelist->name);
|
fprintf (dumpfile, " NML=%s", dt->namelist->name);
|
|
|
if (dt->iomsg)
|
if (dt->iomsg)
|
{
|
{
|
fputs (" IOMSG=", dumpfile);
|
fputs (" IOMSG=", dumpfile);
|
show_expr (dt->iomsg);
|
show_expr (dt->iomsg);
|
}
|
}
|
if (dt->iostat)
|
if (dt->iostat)
|
{
|
{
|
fputs (" IOSTAT=", dumpfile);
|
fputs (" IOSTAT=", dumpfile);
|
show_expr (dt->iostat);
|
show_expr (dt->iostat);
|
}
|
}
|
if (dt->size)
|
if (dt->size)
|
{
|
{
|
fputs (" SIZE=", dumpfile);
|
fputs (" SIZE=", dumpfile);
|
show_expr (dt->size);
|
show_expr (dt->size);
|
}
|
}
|
if (dt->rec)
|
if (dt->rec)
|
{
|
{
|
fputs (" REC=", dumpfile);
|
fputs (" REC=", dumpfile);
|
show_expr (dt->rec);
|
show_expr (dt->rec);
|
}
|
}
|
if (dt->advance)
|
if (dt->advance)
|
{
|
{
|
fputs (" ADVANCE=", dumpfile);
|
fputs (" ADVANCE=", dumpfile);
|
show_expr (dt->advance);
|
show_expr (dt->advance);
|
}
|
}
|
if (dt->id)
|
if (dt->id)
|
{
|
{
|
fputs (" ID=", dumpfile);
|
fputs (" ID=", dumpfile);
|
show_expr (dt->id);
|
show_expr (dt->id);
|
}
|
}
|
if (dt->pos)
|
if (dt->pos)
|
{
|
{
|
fputs (" POS=", dumpfile);
|
fputs (" POS=", dumpfile);
|
show_expr (dt->pos);
|
show_expr (dt->pos);
|
}
|
}
|
if (dt->asynchronous)
|
if (dt->asynchronous)
|
{
|
{
|
fputs (" ASYNCHRONOUS=", dumpfile);
|
fputs (" ASYNCHRONOUS=", dumpfile);
|
show_expr (dt->asynchronous);
|
show_expr (dt->asynchronous);
|
}
|
}
|
if (dt->blank)
|
if (dt->blank)
|
{
|
{
|
fputs (" BLANK=", dumpfile);
|
fputs (" BLANK=", dumpfile);
|
show_expr (dt->blank);
|
show_expr (dt->blank);
|
}
|
}
|
if (dt->decimal)
|
if (dt->decimal)
|
{
|
{
|
fputs (" DECIMAL=", dumpfile);
|
fputs (" DECIMAL=", dumpfile);
|
show_expr (dt->decimal);
|
show_expr (dt->decimal);
|
}
|
}
|
if (dt->delim)
|
if (dt->delim)
|
{
|
{
|
fputs (" DELIM=", dumpfile);
|
fputs (" DELIM=", dumpfile);
|
show_expr (dt->delim);
|
show_expr (dt->delim);
|
}
|
}
|
if (dt->pad)
|
if (dt->pad)
|
{
|
{
|
fputs (" PAD=", dumpfile);
|
fputs (" PAD=", dumpfile);
|
show_expr (dt->pad);
|
show_expr (dt->pad);
|
}
|
}
|
if (dt->round)
|
if (dt->round)
|
{
|
{
|
fputs (" ROUND=", dumpfile);
|
fputs (" ROUND=", dumpfile);
|
show_expr (dt->round);
|
show_expr (dt->round);
|
}
|
}
|
if (dt->sign)
|
if (dt->sign)
|
{
|
{
|
fputs (" SIGN=", dumpfile);
|
fputs (" SIGN=", dumpfile);
|
show_expr (dt->sign);
|
show_expr (dt->sign);
|
}
|
}
|
|
|
show_dt_code:
|
show_dt_code:
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
for (c = c->block->next; c; c = c->next)
|
for (c = c->block->next; c; c = c->next)
|
show_code_node (level + (c->next != NULL), c);
|
show_code_node (level + (c->next != NULL), c);
|
return;
|
return;
|
|
|
case EXEC_TRANSFER:
|
case EXEC_TRANSFER:
|
fputs ("TRANSFER ", dumpfile);
|
fputs ("TRANSFER ", dumpfile);
|
show_expr (c->expr1);
|
show_expr (c->expr1);
|
break;
|
break;
|
|
|
case EXEC_DT_END:
|
case EXEC_DT_END:
|
fputs ("DT_END", dumpfile);
|
fputs ("DT_END", dumpfile);
|
dt = c->ext.dt;
|
dt = c->ext.dt;
|
|
|
if (dt->err != NULL)
|
if (dt->err != NULL)
|
fprintf (dumpfile, " ERR=%d", dt->err->value);
|
fprintf (dumpfile, " ERR=%d", dt->err->value);
|
if (dt->end != NULL)
|
if (dt->end != NULL)
|
fprintf (dumpfile, " END=%d", dt->end->value);
|
fprintf (dumpfile, " END=%d", dt->end->value);
|
if (dt->eor != NULL)
|
if (dt->eor != NULL)
|
fprintf (dumpfile, " EOR=%d", dt->eor->value);
|
fprintf (dumpfile, " EOR=%d", dt->eor->value);
|
break;
|
break;
|
|
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_ATOMIC:
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_BARRIER:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_CRITICAL:
|
case EXEC_OMP_FLUSH:
|
case EXEC_OMP_FLUSH:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_DO:
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_MASTER:
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_ORDERED:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_DO:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_SECTIONS:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_PARALLEL_WORKSHARE:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SECTIONS:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_SINGLE:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASK:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_TASKWAIT:
|
case EXEC_OMP_WORKSHARE:
|
case EXEC_OMP_WORKSHARE:
|
show_omp_node (level, c);
|
show_omp_node (level, c);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("show_code_node(): Bad statement code");
|
gfc_internal_error ("show_code_node(): Bad statement code");
|
}
|
}
|
|
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
}
|
}
|
|
|
|
|
/* Show an equivalence chain. */
|
/* Show an equivalence chain. */
|
|
|
static void
|
static void
|
show_equiv (gfc_equiv *eq)
|
show_equiv (gfc_equiv *eq)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("Equivalence: ", dumpfile);
|
fputs ("Equivalence: ", dumpfile);
|
while (eq)
|
while (eq)
|
{
|
{
|
show_expr (eq->expr);
|
show_expr (eq->expr);
|
eq = eq->eq;
|
eq = eq->eq;
|
if (eq)
|
if (eq)
|
fputs (", ", dumpfile);
|
fputs (", ", dumpfile);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Show a freakin' whole namespace. */
|
/* Show a freakin' whole namespace. */
|
|
|
static void
|
static void
|
show_namespace (gfc_namespace *ns)
|
show_namespace (gfc_namespace *ns)
|
{
|
{
|
gfc_interface *intr;
|
gfc_interface *intr;
|
gfc_namespace *save;
|
gfc_namespace *save;
|
int op;
|
int op;
|
gfc_equiv *eq;
|
gfc_equiv *eq;
|
int i;
|
int i;
|
|
|
save = gfc_current_ns;
|
save = gfc_current_ns;
|
show_level++;
|
show_level++;
|
|
|
show_indent ();
|
show_indent ();
|
fputs ("Namespace:", dumpfile);
|
fputs ("Namespace:", dumpfile);
|
|
|
if (ns != NULL)
|
if (ns != NULL)
|
{
|
{
|
i = 0;
|
i = 0;
|
do
|
do
|
{
|
{
|
int l = i;
|
int l = i;
|
while (i < GFC_LETTERS - 1
|
while (i < GFC_LETTERS - 1
|
&& gfc_compare_types(&ns->default_type[i+1],
|
&& gfc_compare_types(&ns->default_type[i+1],
|
&ns->default_type[l]))
|
&ns->default_type[l]))
|
i++;
|
i++;
|
|
|
if (i > l)
|
if (i > l)
|
fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
|
fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
|
else
|
else
|
fprintf (dumpfile, " %c: ", l+'A');
|
fprintf (dumpfile, " %c: ", l+'A');
|
|
|
show_typespec(&ns->default_type[l]);
|
show_typespec(&ns->default_type[l]);
|
i++;
|
i++;
|
} while (i < GFC_LETTERS);
|
} while (i < GFC_LETTERS);
|
|
|
if (ns->proc_name != NULL)
|
if (ns->proc_name != NULL)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
|
fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
|
}
|
}
|
|
|
gfc_current_ns = ns;
|
gfc_current_ns = ns;
|
gfc_traverse_symtree (ns->common_root, show_common);
|
gfc_traverse_symtree (ns->common_root, show_common);
|
|
|
gfc_traverse_symtree (ns->sym_root, show_symtree);
|
gfc_traverse_symtree (ns->sym_root, show_symtree);
|
|
|
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
|
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
|
{
|
{
|
/* User operator interfaces */
|
/* User operator interfaces */
|
intr = ns->op[op];
|
intr = ns->op[op];
|
if (intr == NULL)
|
if (intr == NULL)
|
continue;
|
continue;
|
|
|
show_indent ();
|
show_indent ();
|
fprintf (dumpfile, "Operator interfaces for %s:",
|
fprintf (dumpfile, "Operator interfaces for %s:",
|
gfc_op2string ((gfc_intrinsic_op) op));
|
gfc_op2string ((gfc_intrinsic_op) op));
|
|
|
for (; intr; intr = intr->next)
|
for (; intr; intr = intr->next)
|
fprintf (dumpfile, " %s", intr->sym->name);
|
fprintf (dumpfile, " %s", intr->sym->name);
|
}
|
}
|
|
|
if (ns->uop_root != NULL)
|
if (ns->uop_root != NULL)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("User operators:\n", dumpfile);
|
fputs ("User operators:\n", dumpfile);
|
gfc_traverse_user_op (ns, show_uop);
|
gfc_traverse_user_op (ns, show_uop);
|
}
|
}
|
}
|
}
|
|
|
for (eq = ns->equiv; eq; eq = eq->next)
|
for (eq = ns->equiv; eq; eq = eq->next)
|
show_equiv (eq);
|
show_equiv (eq);
|
|
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
|
|
show_code (0, ns->code);
|
show_code (0, ns->code);
|
|
|
for (ns = ns->contained; ns; ns = ns->sibling)
|
for (ns = ns->contained; ns; ns = ns->sibling)
|
{
|
{
|
show_indent ();
|
show_indent ();
|
fputs ("CONTAINS\n", dumpfile);
|
fputs ("CONTAINS\n", dumpfile);
|
show_namespace (ns);
|
show_namespace (ns);
|
}
|
}
|
|
|
show_level--;
|
show_level--;
|
fputc ('\n', dumpfile);
|
fputc ('\n', dumpfile);
|
gfc_current_ns = save;
|
gfc_current_ns = save;
|
}
|
}
|
|
|
|
|
/* Main function for dumping a parse tree. */
|
/* Main function for dumping a parse tree. */
|
|
|
void
|
void
|
gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
|
gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
|
{
|
{
|
dumpfile = file;
|
dumpfile = file;
|
show_namespace (ns);
|
show_namespace (ns);
|
}
|
}
|
|
|
