static void
show_components (gfc_symbol *sym)
{
gfc_component *c;
for (c = sym->components; c; c = c->next)
{
fprintf (dumpfile, "(%s ", c->name);
show_typespec (&c->ts);
if (c->attr.allocatable)
fputs (" ALLOCATABLE", dumpfile);
if (c->attr.pointer)
fputs (" POINTER", dumpfile);
if (c->attr.proc_pointer)
fputs (" PPC", dumpfile);
if (c->attr.dimension)
fputs (" DIMENSION", dumpfile);
fputc (' ', dumpfile);
show_array_spec (c->as);
if (c->attr.access)
fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
fputc (')', dumpfile);
if (c->next != NULL)
fputc (' ', dumpfile);
}
}
static void show_component(g95_component *c) {
g95_status("comp(%s, ts=", c->name);
show_typespec(&c->ts);
if (c->pointer)
g95_status(", pointer=1");
if (c->dimension)
g95_status(", dimension=1");
if (c->allocatable)
g95_status(", allocatable=1");
if (c->as != NULL) {
g95_status(", as=");
show_array_spec(c->as);
}
g95_status(")");
}
static void
show_symbol (gfc_symbol *sym)
{
gfc_formal_arglist *formal;
gfc_interface *intr;
int i,len;
if (sym == NULL)
return;
fprintf (dumpfile, "|| symbol: '%s' ", sym->name);
len = strlen (sym->name);
for (i=len; i<12; i++)
fputc(' ', dumpfile);
++show_level;
show_indent ();
fputs ("type spec : ", dumpfile);
show_typespec (&sym->ts);
show_indent ();
fputs ("attributes: ", dumpfile);
show_attr (&sym->attr, sym->module);
if (sym->value)
{
show_indent ();
fputs ("value: ", dumpfile);
show_expr (sym->value);
}
if (sym->as)
{
show_indent ();
fputs ("Array spec:", dumpfile);
show_array_spec (sym->as);
}
if (sym->generic)
{
show_indent ();
fputs ("Generic interfaces:", dumpfile);
for (intr = sym->generic; intr; intr = intr->next)
fprintf (dumpfile, " %s", intr->sym->name);
}
if (sym->result)
{
show_indent ();
fprintf (dumpfile, "result: %s", sym->result->name);
}
if (sym->components)
{
show_indent ();
fputs ("components: ", dumpfile);
show_components (sym);
}
if (sym->f2k_derived)
{
show_indent ();
if (sym->hash_value)
fprintf (dumpfile, "hash: %d", sym->hash_value);
show_f2k_derived (sym->f2k_derived);
}
if (sym->formal)
{
show_indent ();
fputs ("Formal arglist:", dumpfile);
for (formal = sym->formal; formal; formal = formal->next)
{
if (formal->sym != NULL)
fprintf (dumpfile, " %s", formal->sym->name);
else
fputs (" [Alt Return]", dumpfile);
}
}
if (sym->formal_ns && (sym->formal_ns->proc_name != sym)
&& sym->attr.proc != PROC_ST_FUNCTION
&& !sym->attr.entry)
{
show_indent ();
fputs ("Formal namespace", dumpfile);
show_namespace (sym->formal_ns);
}
--show_level;
}
static void
show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
int op;
gfc_equiv *eq;
int i;
gcc_assert (ns);
save = gfc_current_ns;
show_indent ();
fputs ("Namespace:", dumpfile);
i = 0;
do
{
int l = i;
while (i < GFC_LETTERS - 1
&& gfc_compare_types (&ns->default_type[i+1],
&ns->default_type[l]))
i++;
if (i > l)
fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
else
fprintf (dumpfile, " %c: ", l+'A');
show_typespec(&ns->default_type[l]);
i++;
} while (i < GFC_LETTERS);
if (ns->proc_name != NULL)
{
show_indent ();
fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
}
++show_level;
gfc_current_ns = ns;
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++)
{
/* User operator interfaces */
intr = ns->op[op];
if (intr == NULL)
continue;
show_indent ();
fprintf (dumpfile, "Operator interfaces for %s:",
gfc_op2string ((gfc_intrinsic_op) op));
for (; intr; intr = intr->next)
fprintf (dumpfile, " %s", intr->sym->name);
}
if (ns->uop_root != NULL)
{
show_indent ();
fputs ("User operators:\n", dumpfile);
gfc_traverse_user_op (ns, show_uop);
}
for (eq = ns->equiv; eq; eq = eq->next)
show_equiv (eq);
fputc ('\n', dumpfile);
show_indent ();
fputs ("code:", dumpfile);
show_code (show_level, ns->code);
--show_level;
for (ns = ns->contained; ns; ns = ns->sibling)
{
fputs ("\nCONTAINS\n", dumpfile);
++show_level;
show_namespace (ns);
--show_level;
}
fputc ('\n', dumpfile);
gfc_current_ns = save;
}
void g95_show_namespace(g95_namespace *ns) {
g95_interface *intr;
g95_namespace *save;
int i;
if (ns == NULL)
return;
save = g95_current_ns;
show_indent();
g95_status("ns(");
for(i=0; i<G95_LETTERS; i++) {
g95_status("%c=", i+'A');
show_typespec(&ns->default_type[i]);
if (i != G95_LETTERS-1)
g95_status_char(',');
g95_status_char((i % 3 == 2) ? '\n' : ' ');
}
if (ns->proc_name != NULL)
g95_status(", name='%s'", ns->proc_name->name);
g95_status(")\n");
for(i=0; i<G95_INTRINSIC_OPS; i++) { /* User operator interfaces */
intr = ns->operator[i];
if (intr == NULL)
continue;
g95_status("operator('%s', [", g95_op2string(i));
for(; intr; intr=intr->next)
g95_status(" '%s',", intr->sym->name);
g95_status("])\n");
}
g95_traverse_user_op(ns, show_uop);
g95_traverse_symtree(ns, g95_clear_sym_mark);
g95_current_ns = ns;
g95_traverse_symtree(ns, show_symtree);
g95_status("\n\n");
show_code(0, ns->code);
show_level++;
for(ns=ns->contained; ns; ns=ns->sibling) {
g95_status("# Contains\n");
g95_show_namespace(ns);
}
show_level--;
g95_status_char('\n');
g95_current_ns = save;
}
static void show_symbol(g95_symbol *sym) {
g95_formal_arglist *formal;
symbol_attribute *attr;
g95_component *c;
if (sym == NULL)
return;
show_indent();
g95_status("symbol(%s, ts=", g95_symbol_name(sym));
show_typespec(&sym->ts);
attr = &sym->attr;
g95_status(", flavor='%s'", g95_flavor_string(attr->flavor));
if (attr->intent != INTENT_UNKNOWN)
g95_status(", intent='%s'", g95_intent_string(attr->intent));
if (attr->access != ACCESS_UNKNOWN)
g95_status(", access='%s'", g95_access_string(attr->access));
if (attr->proc != PROC_UNKNOWN)
g95_status(", proc='%s'", g95_procedure_string(attr->proc));
if (attr->allocatable)
g95_status(", allocatable=1");
if (attr->dimension)
g95_status(", dimension=1");
if (attr->external)
g95_status(", external=1");
if (attr->intrinsic)
g95_status(", intrinsic=1");
if (attr->optional)
g95_status(", optional=1");
if (attr->pointer)
g95_status(", pointer=1");
if (attr->save)
g95_status(", save=1");
if (attr->target)
g95_status(", target=1");
if (attr->dummy)
g95_status(", dummy=1");
if (attr->result_var)
g95_status(", result=1");
if (attr->entry)
g95_status(", entry=1");
if (attr->data)
g95_status(", data=1");
if (attr->use_assoc)
g95_status(", use_assoc=1");
if (attr->in_namelist)
g95_status(", in_namelist=1");
if (attr->in_common)
g95_status(", in_common=1");
if (attr->function)
g95_status(", function=1");
if (attr->subroutine)
g95_status(", subroutine=1");
if (attr->sequence)
g95_status(", sequence=1");
if (attr->elemental)
g95_status(", elemental=1");
if (attr->pure)
g95_status(", pure=1");
if (attr->recursive)
g95_status(", recursive=1");
if (attr->artificial)
g95_status(", artificial=1");
if (sym->value) {
g95_status(", value=");
g95_show_expr(sym->value);
}
if (sym->as != NULL) {
g95_status(", as=");
show_array_spec(sym->as);
}
if (sym->result)
g95_status(", result=%s", g95_symbol_name(sym->result));
if (sym->components) {
g95_status(", components=[");
for(c=sym->components; c; c=c->next)
show_component(c);
g95_status("]");
}
if (sym->formal) {
show_indent();
g95_status("formal=[");
for(formal=sym->formal; formal; formal=formal->next)
if (formal->sym == NULL)
g95_status("*");
else
g95_status("'%s', ", formal->sym->name);
g95_status("]");
}
g95_status(")\n");
}