static void
show_expr (gfc_expr *p)
{
const char *c;
int i;
if (p == NULL)
{
fputs ("()", dumpfile);
return;
}
switch (p->expr_type)
{
case EXPR_SUBSTRING:
show_char_const (p->value.character.string, p->value.character.length);
show_ref (p->ref);
break;
case EXPR_STRUCTURE:
fprintf (dumpfile, "%s(", p->ts.u.derived->name);
show_constructor (p->value.constructor);
fputc (')', dumpfile);
break;
case EXPR_ARRAY:
fputs ("(/ ", dumpfile);
show_constructor (p->value.constructor);
fputs (" /)", dumpfile);
show_ref (p->ref);
break;
case EXPR_NULL:
fputs ("NULL()", dumpfile);
break;
case EXPR_CONSTANT:
switch (p->ts.type)
{
case BT_INTEGER:
mpz_out_str (stdout, 10, p->value.integer);
if (p->ts.kind != gfc_default_integer_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
break;
case BT_LOGICAL:
if (p->value.logical)
fputs (".true.", dumpfile);
else
fputs (".false.", dumpfile);
break;
case BT_REAL:
mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
if (p->ts.kind != gfc_default_real_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
break;
case BT_CHARACTER:
show_char_const (p->value.character.string,
p->value.character.length);
break;
case BT_COMPLEX:
fputs ("(complex ", dumpfile);
mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
fputc (' ', dumpfile);
mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
fputc (')', dumpfile);
break;
case BT_HOLLERITH:
fprintf (dumpfile, "%dH", p->representation.length);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
fputc (*c, dumpfile);
}
break;
default:
fputs ("???", dumpfile);
break;
}
if (p->representation.string)
{
fputs (" {", dumpfile);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
fprintf (dumpfile, "%.2x", (unsigned int) *c);
if (i < p->representation.length - 1)
fputc (',', dumpfile);
}
fputc ('}', dumpfile);
}
break;
case EXPR_VARIABLE:
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->name);
show_ref (p->ref);
break;
case EXPR_OP:
fputc ('(', dumpfile);
switch (p->value.op.op)
{
case INTRINSIC_UPLUS:
fputs ("U+ ", dumpfile);
break;
case INTRINSIC_UMINUS:
fputs ("U- ", dumpfile);
break;
case INTRINSIC_PLUS:
fputs ("+ ", dumpfile);
break;
case INTRINSIC_MINUS:
fputs ("- ", dumpfile);
break;
case INTRINSIC_TIMES:
fputs ("* ", dumpfile);
break;
case INTRINSIC_DIVIDE:
fputs ("/ ", dumpfile);
break;
case INTRINSIC_POWER:
fputs ("** ", dumpfile);
break;
case INTRINSIC_CONCAT:
fputs ("// ", dumpfile);
break;
case INTRINSIC_AND:
fputs ("AND ", dumpfile);
break;
case INTRINSIC_OR:
fputs ("OR ", dumpfile);
break;
case INTRINSIC_EQV:
fputs ("EQV ", dumpfile);
break;
case INTRINSIC_NEQV:
fputs ("NEQV ", dumpfile);
break;
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
fputs ("= ", dumpfile);
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
fputs ("/= ", dumpfile);
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
fputs ("> ", dumpfile);
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
fputs (">= ", dumpfile);
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
fputs ("< ", dumpfile);
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
fputs ("<= ", dumpfile);
break;
case INTRINSIC_NOT:
fputs ("NOT ", dumpfile);
break;
case INTRINSIC_PARENTHESES:
fputs ("parens ", dumpfile);
break;
default:
gfc_internal_error
("show_expr(): Bad intrinsic in expression!");
}
show_expr (p->value.op.op1);
if (p->value.op.op2)
{
fputc (' ', dumpfile);
show_expr (p->value.op.op2);
}
fputc (')', dumpfile);
break;
case EXPR_FUNCTION:
if (p->value.function.name == NULL)
{
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
if (gfc_is_proc_ptr_comp (p))
show_ref (p->ref);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
fputc (']', dumpfile);
}
else
{
fprintf (dumpfile, "%s", p->value.function.name);
if (gfc_is_proc_ptr_comp (p))
show_ref (p->ref);
fputc ('[', dumpfile);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
fputc (']', dumpfile);
fputc (']', dumpfile);
}
break;
case EXPR_COMPCALL:
show_compcall (p);
break;
default:
gfc_internal_error ("show_expr(): Don't know how to show expr");
}
}
void g95_show_expr(g95_expr *p) {
g95_symbol *sym;
if (p == NULL) {
g95_status("expr()");
return;
}
/* Show expression */
switch(p->type) {
case EXPR_SUBSTRING:
g95_status("substr(");
show_string_constant(p->value.character.string,
p->value.character.length);
g95_status(", start=");
g95_show_expr(p->ref->u.ss.start);
g95_status(", end=");
g95_show_expr(p->ref->u.ss.end);
break;
case EXPR_STRUCTURE:
g95_status("scons('%s', cons=", p->symbol->name);
show_constructor(p->value.constructor.c);
break;
case EXPR_ARRAY:
g95_status("acons(cons=");
show_constructor(p->value.constructor.c);
if (p->ref != NULL) {
g95_status(", ref=");
show_refs(p->ref);
}
break;
case EXPR_NULL:
g95_status("null()");
break;
case EXPR_CONSTANT:
g95_status("const(");
show_constant(p);
break;
case EXPR_VARIABLE:
g95_status("var(");
sym = p->symbol;
if (sym->ns->proc_name != NULL && sym->ns->proc_name->name != NULL)
g95_status("'%s:%s'", sym->ns->proc_name->name, sym->name);
else
g95_status("'%s'", sym->name);
if (p->ref != NULL) {
g95_status(", ref=");
show_refs(p->ref);
}
break;
case EXPR_OP:
g95_status("op(");
switch(p->value.op.operator) {
case INTRINSIC_UPLUS: g95_status("'U+'"); break;
case INTRINSIC_UMINUS: g95_status("'U-'"); break;
case INTRINSIC_PLUS: g95_status("'+'"); break;
case INTRINSIC_MINUS: g95_status("'-'"); break;
case INTRINSIC_TIMES: g95_status("'*'"); break;
case INTRINSIC_DIVIDE: g95_status("'/'"); break;
case INTRINSIC_POWER: g95_status("'**'"); break;
case INTRINSIC_CONCAT: g95_status("'//'"); break;
case INTRINSIC_AND: g95_status("'AND'"); break;
case INTRINSIC_OR: g95_status("'OR'"); break;
case INTRINSIC_EQV: g95_status("'EQV'"); break;
case INTRINSIC_NEQV: g95_status("'NEQV'"); break;
case INTRINSIC_EQ: g95_status("'='"); break;
case INTRINSIC_NE: g95_status("'<>'"); break;
case INTRINSIC_GT: g95_status("'>'"); break;
case INTRINSIC_GE: g95_status("'>='"); break;
case INTRINSIC_LT: g95_status("'<'"); break;
case INTRINSIC_LE: g95_status("'<='"); break;
case INTRINSIC_NOT: g95_status("'NOT'"); break;
case INTRINSIC_PAREN: g95_status("()"); break;
default:
g95_internal_error("g95_show_expr(): "
"Bad intrinsic in expression!");
}
g95_status(", op1=");
g95_show_expr(p->value.op.op1);
if (p->value.op.op2) {
g95_status(", op2=");
g95_show_expr(p->value.op.op2);
}
break;
case EXPR_FUNCTION:
g95_status("func(");
if (p->value.function.isym == NULL)
g95_status("'%s:%s'", p->symbol->module, p->symbol->name);
else
g95_status("'%s'", p->value.function.iname);
g95_status(", arg=");
show_actual_arglist(p->value.function.actual);
break;
case EXPR_UNKNOWN:
g95_status("unknown('%s'", p->symbol->name);
break;
default:
g95_internal_error("g95_show_expr(): Bad type");
break;
}
g95_status_char(')');
}
