static void dump_constant(g95_expr *e) {
switch(e->ts.type) {
case BT_INTEGER:
dumpf("integer(%L,%s)", &e->where, bi_to_string(e->value.integer));
break;
case BT_REAL:
dumpf("real(%L,'%s')", &e->where, bg_to_string(e->value.real));
break;
case BT_COMPLEX:
dumpf("complex(%L,'%s','%s')", &e->where,
bg_to_string(e->value.complex.r),
bg_to_string(e->value.complex.i));
break;
case BT_LOGICAL:
dumpf("logical(%L,%d)", &e->where, e->value.logical);
break;
case BT_CHARACTER:
dumpf("char(%L, %S)", &e->where, e->value.character.string);
break;
default:
g95_internal_error("dump_constant(): Bad constant");
}
}
static void show_typespec(g95_typespec *ts) {
switch(ts->type) {
case BT_INTEGER: g95_status("ts('INTEGER', kind=%d)", ts->kind); break;
case BT_REAL: g95_status("ts('REAL', kind=%d)", ts->kind); break;
case BT_COMPLEX: g95_status("ts('COMPLEX', kind=%d", ts->kind); break;
case BT_LOGICAL: g95_status("ts('LOGICAL', kind=%d", ts->kind); break;
case BT_PROCEDURE: g95_status("ts('PROCEDURE')"); break;
case BT_UNKNOWN: g95_status("ts('UNKNOWN')"); break;
case BT_DERIVED: g95_status("ts('DERIVED', derived=%s",
g95_symbol_name(ts->derived)); break;
case BT_CHARACTER: g95_status("ts('CHARACTER', kind=%d, len=", ts->kind);
if (ts->cl == &g95_unknown_charlen)
g95_status("None");
else if (ts->cl == NULL)
g95_status("'*'");
else
g95_show_expr(ts->cl->length);
g95_status(")");
break;
default:
g95_internal_error("show_typespec(): Undefined type");
}
}
static void dump_name(g95_symbol *sym, g95_intrinsic_sym *isym) {
if (isym == NULL)
dumpf("%p", sym);
else if (isym->name[0] != '\0')
dumpf("%S", isym->name);
else /* Nameless intrinsics */
switch(isym->id) {
case G95_ISYM_ABS: dumpf("'abs'"); break;
case G95_ISYM_ACOS: dumpf("'acos'"); break;
case G95_ISYM_AIMAG: dumpf("'aimag'"); break;
case G95_ISYM_ASIN: dumpf("'asin'"); break;
case G95_ISYM_ATAN: dumpf("'atan'"); break;
case G95_ISYM_ATAN2: dumpf("'atan2'"); break;
case G95_ISYM_CONJG: dumpf("'conjg'"); break;
case G95_ISYM_COS: dumpf("'cos'"); break;
case G95_ISYM_COSH: dumpf("'cosh'"); break;
case G95_ISYM_EXP: dumpf("'exp'"); break;
case G95_ISYM_LOG: dumpf("'log'"); break;
case G95_ISYM_LOG10: dumpf("'log10'"); break;
case G95_ISYM_MOD: dumpf("'mod'"); break;
case G95_ISYM_SIN: dumpf("'sin'"); break;
case G95_ISYM_SINH: dumpf("'sinh'"); break;
case G95_ISYM_SQRT: dumpf("'sqrt'"); break;
case G95_ISYM_TAN: dumpf("'tan'"); break;
case G95_ISYM_TANH: dumpf("'tanh'"); break;
default:
g95_internal_error("dump_name(): Nameless intrinsic!");
}
}
char *g95_code2string(mstring *c, int codep) {
while(c->string != NULL) {
if (c->tag == codep) return c->string;
c++;
}
g95_internal_error("g95_code2string(): Bad code");
return NULL;
}
static void show_constant(g95_expr *p) {
switch(p->ts.type) {
case BT_INTEGER:
g95_status_char('\'');
fputs(bi_to_string(p->value.integer), stdout);
if (p->ts.kind != g95_default_integer_kind(0))
g95_status("_%d", p->ts.kind);
g95_status_char('\'');
break;
case BT_LOGICAL:
g95_status(p->value.logical ? "'.true.'" : "'.false.'");
break;
case BT_REAL:
g95_status_char('\'');
fputs(bg_to_string(p->value.real), stdout);
if (p->ts.kind != g95_default_real_kind(1))
g95_status("_%d", p->ts.kind);
g95_status_char('\'');
break;
case BT_CHARACTER:
show_string_constant(p->value.character.string,
p->value.character.length);
break;
case BT_COMPLEX:
g95_status_char('\'');
fputs(bg_to_string(p->value.complex.r), stdout);
if (p->ts.kind != g95_default_complex_kind())
g95_status("_%d", p->ts.kind);
g95_status_char(' ');
fputs(bg_to_string(p->value.complex.i), stdout);
if (p->ts.kind != g95_default_complex_kind())
g95_status("_%d", p->ts.kind);
g95_status_char('\'');
break;
default:
g95_internal_error("show_constant(): Bad type");
break;
}
}
static void show_array_ref(g95_array_ref *ar) {
int i;
switch(ar->type) {
case AR_FULL:
g95_status("full()");
break;
case AR_SECTION:
g95_status("section(");
for(i=0; i<ar->dimen; i++) {
g95_status_char('(');
g95_show_expr(ar->start[i]);
if (ar->end[i] != NULL) {
g95_status(", ");
g95_show_expr(ar->end[i]);
}
if (ar->stride[i] != NULL) {
g95_status(", ");
g95_show_expr(ar->stride[i]);
}
g95_status_char(')');
if (i != ar->dimen-1)
g95_status(", ");
}
g95_status_char(')');
break;
case AR_ELEMENT:
g95_status("element(");
for(i=0; i<ar->dimen; i++) {
g95_show_expr(ar->start[i]);
if (i != ar->dimen - 1)
g95_status(", ");
}
g95_status_char(')');
break;
case AR_UNKNOWN:
g95_status("UNKNOWN");
break;
default:
g95_internal_error("g95_show_array_ref(): Unknown array reference");
}
}
static int find_mask_symbol(g95_expr *j, g95_symbol *target) {
g95_actual_arglist *ap;
g95_ref *r;
int retval;
if (j == NULL) return 0;
retval = 0;
switch(j->type) {
case EXPR_OP:
retval = find_mask_symbol(j->op1, target) ||
find_mask_symbol(j->op2, target);
break;
case EXPR_CONSTANT:
case EXPR_NULL:
break;
case EXPR_FUNCTION:
for(ap=j->value.function.actual; ap; ap=ap->next)
if (find_mask_symbol(ap->u.expr, target)) {
retval = 1;
break;
}
break;
case EXPR_VARIABLE:
if (j->symbol == target) {
retval = 1;
break;
}
for(r=j->ref; r; r=r->next)
retval |= find_mask_ref(r, target);
break;
case EXPR_SUBSTRING:
retval = find_mask_ref(j->ref, target);
break;
case EXPR_STRUCTURE:
case EXPR_ARRAY:
retval = find_mask_constructor(j->value.constructor, target);
break;
default:
g95_internal_error("find_mask_symbol(): Bad expression");
}
return retval;
}
char *g95_basic_typename(bt type) {
char *v;
switch(type) {
case BT_INTEGER: v = "INTEGER"; break;
case BT_REAL: v = "REAL"; break;
case BT_COMPLEX: v = "COMPLEX"; break;
case BT_LOGICAL: v = "LOGICAL"; break;
case BT_CHARACTER: v = "CHARACTER"; break;
case BT_DERIVED: v = "DERIVED"; break;
case BT_PROCEDURE: v = "PROCEDURE"; break;
case BT_UNKNOWN: v = "UNKNOWN"; break;
default:
g95_internal_error("g95_basic_typename(): Undefined type");
}
return v;
}
static void dump_intrinsic(g95_expr *e) {
char *name;
int binary;
binary = 1;
switch(e->value.op.operator) {
case INTRINSIC_UPLUS: name = "uplus"; binary = 0; break;
case INTRINSIC_NOT: name = "unot"; binary = 0; break;
case INTRINSIC_UMINUS: name = "uminus"; binary = 0; break;
case INTRINSIC_PLUS: name = "plus"; break;
case INTRINSIC_MINUS: name = "minus"; break;
case INTRINSIC_TIMES: name = "times"; break;
case INTRINSIC_DIVIDE: name = "divide"; break;
case INTRINSIC_POWER: name = "power"; break;
case INTRINSIC_CONCAT: name = "concat"; break;
case INTRINSIC_AND: name = "logical_and"; break;
case INTRINSIC_OR: name = "logical_or"; break;
case INTRINSIC_EQV: name = "logical_eqv"; break;
case INTRINSIC_NEQV: name = "logical_neqv"; break;
case INTRINSIC_EQ: name = "cmp_eq"; break;
case INTRINSIC_NE: name = "cmp_ne"; break;
case INTRINSIC_GT: name = "cmp_gt"; break;
case INTRINSIC_GE: name = "cmp_ge"; break;
case INTRINSIC_LT: name = "cmp_lt"; break;
case INTRINSIC_LE: name = "cmp_le"; break;
case INTRINSIC_PAREN:
dump_expr(e->value.op.op1);
return;
default:
g95_internal_error("dump_intrinsic(): Bad intrinsic");
}
dumpf("%s(%L,", name, &e->where);
dump_expr(e->value.op.op1);
if (binary) {
dump_char(',');
dump_expr(e->value.op.op2);
}
dump_char(')');
}
static int compare_expr(g95_expr *a, g95_expr *b) {
int rc;
switch(a->ts.type) {
case BT_INTEGER:
rc = bi_compare(a->value.integer, b->value.integer);
break;
case BT_CHARACTER:
rc = g95_compare_string(a, b, NULL);
break;
case BT_LOGICAL:
rc = a->value.logical != b->value.logical;
break;
default:
g95_internal_error("compare_expr(): Bad type");
}
return rc;
}
static void show_ref(g95_ref *p) {
int i;
switch(p->type) {
case REF_ARRAY:
show_array_ref(&p->u.ar);
break;
case REF_COMPONENT:
g95_status("comp('%s')", p->u.c.component->name);
break;
case REF_SUBSTRING:
g95_status("substr(start=");
g95_show_expr(p->u.ss.start);
g95_status(", end=");
g95_show_expr(p->u.ss.end);
g95_status_char(')');
break;
case REF_COARRAY:
g95_status("coarray(");
for(i=0; i<p->u.car.dimen; i++) {
g95_show_expr(p->u.car.element[i]);
if (i != p->u.car.dimen - 1)
g95_status_char(',');
}
g95_status_char(')');
break;
default:
g95_internal_error("show_ref(): Bad component code");
}
}
char *g95_typename(g95_typespec *typ) {
static char buffer1[60], buffer2[60];
static int flag = 0;
char *buffer;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
switch(typ->type) {
case BT_INTEGER: sprintf(buffer, "INTEGER(%d)", typ->kind); break;
case BT_REAL: sprintf(buffer, "REAL(%d)", typ->kind); break;
case BT_COMPLEX: sprintf(buffer, "COMPLEX(%d)", typ->kind); break;
case BT_LOGICAL: sprintf(buffer, "LOGICAL(%d)", typ->kind); break;
case BT_CHARACTER: sprintf(buffer, "CHARACTER(%d)", typ->kind); break;
case BT_DERIVED: sprintf(buffer, "TYPE(%s)", typ->derived->name); break;
case BT_PROCEDURE: strcpy(buffer, "PROCEDURE"); break;
case BT_UNKNOWN: strcpy(buffer, "UNKNOWN"); break;
default:
g95_internal_error("g95_typespec(): Undefined type");
}
return buffer;
}
static void dump_ns(g95_namespace *ns) {
g95_symbol *sym, *result;
g95_namespace *p, *save;
g95_locus *where;
g95_annot *a;
int m, rank;
save = g95_current_ns;
g95_current_ns = ns;
where = &ns->declared_at;
sym = ns->proc_name;
switch(ns->state) {
case COMP_PROGRAM:
if (ns->unit_name == NULL)
dumpf("program(None, %L)\n", where);
else
dumpf("program(%S,%L)\n", ns->unit_name, where);
break;
case COMP_MODULE:
dumpf("module(%S,%L,%L)\n", sym->name, where,
&ns->proc_name->declared_at);
break;
case COMP_SUBROUTINE:
dumpf("subroutine(%S,%S,%L,", sym->name, sym->module,
&ns->proc_name->declared_at);
dump_formal(ns->proc_name);
dumpf(")\n");
break;
case COMP_FUNCTION:
result = sym->result;
rank = (result->as == NULL) ? 0 : result->as->rank;
dumpf("function(%S,%S,%L,%S,%d,%d,", sym->name, sym->module,
&ns->proc_name->declared_at, g95_typename(&result->ts), rank,
result->attr.pointer);
dump_formal(ns->proc_name);
dumpf(")\n");
break;
case COMP_BLOCK_DATA:
if (ns->proc_name->name == NULL)
dumpf("block_data(None,%L)\n", where);
else
dumpf("block_data(%S,%L)\n", sym->name, where);
break;
case COMP_NONE:
return;
default:
g95_internal_error("dump_ns(): Bad state");
}
g95_traverse_symtree(ns, g95_clear_sym_mark);
g95_traverse_symtree(ns, dump_symtree);
dump_common(ns->common_root);
for(a=ns->annotation; a; a=a->next)
switch(a->type) {
case ANNOT_PARAMETER:
dumpf("parameter_use(%p,%L)\n", a->u.sym, &a->where);
break;
case ANNOT_DERIVED:
dumpf("derived_use(%p,%L)\n", a->u.sym, &a->where);
break;
case ANNOT_LABEL:
dumpf("label_use(%p,%L)\n", a->u.sym, &a->where);
break;
case ANNOT_OPERATOR:
dumpf("operator_use(%p,%L)\n", a->u.sym, &a->where);
break;
default:
g95_internal_error("init_dump(): Bad type");
}
m = dump_code(ns->code);
dumpf("add_code(%C)\n", m);
if (m != 0)
dumpf("del %C\n", m);
for(p=ns->contained; p; p=p->sibling)
dump_ns(p);
dumpf("end()\n");
g95_current_ns = save;
}
static int dump_code(g95_code *c) {
int m, n, list_size, *list, node[2];
g95_forall_iterator *f;
g95_filepos *filepos;
g95_inquire *inquire;
g95_close *close;
g95_flush *flush;
g95_alloc *alloc;
g95_open *open;
g95_wait *wait;
g95_case *sel;
g95_code *d;
g95_dt *dt;
if (c == NULL)
return 0;
n = st_n++;
list = NULL;
list_size = 0;
dumpf("%C = []\n", n);
for(; c; c=c->next) {
switch(c->type) {
case EXEC_CONTINUE:
case EXEC_NOP:
case EXEC_DT_END:
dumpf("%C.append(st_nop(%L", n, &c->where);
break;
case EXEC_ASSIGN:
dumpf("%C.append(st_assign(%L,", n, &c->where);
dump_expr(c->expr);
dump_char(',');
dump_expr(c->expr2);
break;
case EXEC_POINTER_ASSIGN:
dumpf("%C.append(st_ptr_assign(%L,", n, &c->where);
dump_expr(c->expr);
dump_char(',');
dump_expr(c->expr2);
break;
case EXEC_GOTO:
dumpf("%C.append(st_goto(%L, %d", n, &c->where, c->label->value);
break;
case EXEC_PAUSE:
dumpf("%C.append(st_pause(%L", n, &c->where);
break;
case EXEC_STOP:
dumpf("%C.append(st_stop(%L", n, &c->where);
break;
case EXEC_RETURN:
dumpf("%C.append(st_return(%L", n, &c->where);
if (c->expr != NULL) {
dumpf(",rc=");
dump_expr(c->expr);
}
break;
case EXEC_IF:
node[0] = dump_code(c->block);
node[1] = dump_code(c->ext.block);
list = node;
list_size = 2;
dumpf("%C.append(st_if(%L,", n, &c->where);
dump_expr(c->expr);
dumpf(",%C,%C", node[0], node[1]);
break;
case EXEC_DO_WHILE:
node[0] = dump_code(c->block);
list = node;
list_size = 1;
dumpf("%C.append(st_do_while(%L,", n, &c->where, node[0]);
dump_expr(c->expr);
dumpf(",%C", node[0]);
if (c->sym != NULL)
dumpf(",label='%s'", c->sym->name);
break;
case EXEC_DO:
node[0] = dump_code(c->block);
list = node;
list_size = 1;
dumpf("%C.append(st_do(%L, ", n, &c->where);
dump_expr(c->ext.iterator->var);
dump_char(',');
dump_expr(c->ext.iterator->start);
dump_char(',');
dump_expr(c->ext.iterator->end);
dump_char(',');
dump_expr(c->ext.iterator->step);
dumpf(",%C", node[0]);
if (c->sym != NULL)
dumpf(",label='%s'", c->sym->name);
break;
case EXEC_OPEN:
open = c->ext.open;
dumpf("%C.append(st_open(%L", n, &c->where);
if (open->unit != NULL) {
dumpf(",unit=");
dump_expr(open->unit);
}
if (open->file != NULL) {
dumpf(",file=");
dump_expr(open->file);
}
if (open->status != NULL) {
dumpf(",status=");
dump_expr(open->status);
}
if (open->access != NULL) {
dumpf(",access=");
dump_expr(open->access);
}
if (open->form != NULL) {
dumpf(",form=");
dump_expr(open->form);
}
if (open->recl != NULL) {
dumpf(",recl=");
dump_expr(open->recl);
}
if (open->decimal != NULL) {
dumpf(",decimal=");
dump_expr(open->decimal);
}
if (open->blank != NULL) {
dumpf(",blank=");
dump_expr(open->position);
}
if (open->position != NULL) {
dumpf(",position=");
dump_expr(open->position);
}
if (open->action != NULL) {
dumpf(",action=");
dump_expr(open->action);
}
if (open->delim != NULL) {
dumpf(",delim=");
dump_expr(open->delim);
}
if (open->pad != NULL) {
dumpf(",pad=");
dump_expr(open->pad);
}
if (open->iostat != NULL) {
dumpf(",iostat=");
dump_expr(open->iostat);
}
if (open->err != NULL)
dumpf(",err=%d", open->err->value);
break;
case EXEC_CLOSE:
close = c->ext.close;
dumpf("%C.append(st_close(%L", n, &c->where);
if (close->unit != NULL) {
dumpf(",unit=");
dump_expr(close->unit);
}
if (close->status != NULL) {
dumpf(",status=");
dump_expr(close->status);
}
if (close->iostat != NULL) {
dumpf(",iostat=");
dump_expr(close->iostat);
}
if (close->err != NULL)
dumpf(",err=%d", close->err->value);
break;
case EXEC_BACKSPACE:
dumpf("%C.append(st_backspace(%L", n, &c->where);
goto show_filepos;
case EXEC_ENDFILE:
dumpf("%C.append(st_endfile(%L", n, &c->where);
goto show_filepos;
case EXEC_REWIND:
dumpf("%C.append(st_rewind(%L", n, &c->where);
show_filepos:
filepos = c->ext.filepos;
if (filepos->unit != NULL) {
dumpf(",unit=");
dump_expr(filepos->unit);
}
if (filepos->iostat != NULL) {
dumpf(",iostat=");
dump_expr(filepos->iostat);
}
if (filepos->err != NULL)
dumpf(",err=%d", filepos->err->value);
break;
case EXEC_INQUIRE:
dumpf("%C.append(st_inquire(%L", n, &c->where);
inquire = c->ext.inquire;
if (inquire->unit != NULL) {
dumpf(",unit=");
dump_expr(inquire->unit);
}
if (inquire->file != NULL) {
dumpf(",file=");
dump_expr(inquire->file);
}
if (inquire->iostat != NULL) {
dumpf(",iostat=");
dump_expr(inquire->iostat);
}
if (inquire->exist != NULL) {
dumpf(",exist=");
dump_expr(inquire->exist);
}
if (inquire->opened != NULL) {
dumpf(",opened=");
dump_expr(inquire->opened);
}
if (inquire->number != NULL) {
dumpf(",number=");
dump_expr(inquire->number);
}
if (inquire->named != NULL) {
dumpf(",named=");
dump_expr(inquire->named);
}
if (inquire->name != NULL) {
dumpf(",name=");
dump_expr(inquire->name);
}
if (inquire->access != NULL) {
dumpf(",access=");
dump_expr(inquire->access);
}
if (inquire->sequential != NULL) {
dumpf(",sequential=");
dump_expr(inquire->sequential);
}
if (inquire->direct != NULL) {
dumpf(",direct=");
dump_expr(inquire->direct);
}
if (inquire->form != NULL) {
dumpf(",form=");
dump_expr(inquire->form);
}
if (inquire->formatted != NULL) {
dumpf(",formatted=");
dump_expr(inquire->formatted);
}
if (inquire->unformatted != NULL) {
dumpf(",unformatted=");
dump_expr(inquire->unformatted);
}
if (inquire->recl != NULL) {
dumpf(",recl=");
dump_expr(inquire->recl);
}
if (inquire->nextrec != NULL) {
dumpf(",nextrec=");
dump_expr(inquire->nextrec);
}
if (inquire->blank != NULL) {
dumpf(",blank=");
dump_expr(inquire->blank);
}
if (inquire->position != NULL) {
dumpf(",position=");
dump_expr(inquire->position);
}
if (inquire->action != NULL) {
dumpf(",action=");
dump_expr(inquire->action);
}
if (inquire->read != NULL) {
dumpf(",read=");
dump_expr(inquire->read);
}
if (inquire->write != NULL) {
dumpf(",write=");
dump_expr(inquire->write);
}
if (inquire->readwrite != NULL) {
dumpf(",readwrite=");
dump_expr(inquire->readwrite);
}
if (inquire->delim != NULL) {
dumpf(",delim=");
dump_expr(inquire->delim);
}
if (inquire->pad != NULL) {
dumpf(",pad=");
dump_expr(inquire->pad);
}
if (inquire->pos != NULL) {
dumpf(",pos=");
dump_expr(inquire->pos);
}
if (inquire->iolength != NULL) {
dumpf(",iolength=");
dump_expr(inquire->iolength);
}
if (inquire->size != NULL) {
dumpf(",size=");
dump_expr(inquire->size);
}
if (inquire->err != NULL)
dumpf(",err=%d", inquire->err->value);
break;
case EXEC_FLUSH:
dumpf("%C.append(st_flush(%L", n, &c->where);
flush = c->ext.flush;
if (flush->unit != NULL) {
dumpf(",unit=");
dump_expr(flush->unit);
}
if (flush->iostat != NULL) {
dumpf(",iostat=");
dump_expr(flush->iostat);
}
if (flush->iomsg != NULL) {
dumpf(",iomsg=");
dump_expr(flush->iomsg);
}
if (flush->err != NULL)
dumpf(",err=%d", flush->err->value);
break;
case EXEC_WAIT:
dumpf("%C.append(st_wait(%L", n, &c->where);
wait = c->ext.wait;
if (wait->unit != NULL) {
dumpf(",unit=");
dump_expr(wait->unit);
}
if (wait->id != NULL) {
dumpf(",id=");
dump_expr(wait->id);
}
if (wait->iostat != NULL) {
dumpf(",iostat=");
dump_expr(wait->iostat);
}
if (wait->iomsg != NULL) {
dumpf(",iomsg=");
dump_expr(wait->iomsg);
}
if (wait->err != NULL)
dumpf(",err=%d", wait->err->value);
if (wait->end != NULL)
dumpf(",end=%d", wait->end->value);
if (wait->eor != NULL)
dumpf(",eof=%d", wait->eor->value);
break;
case EXEC_IOLENGTH:
dumpf("%C.append(st_iolength(%L,", n, &c->where);
dump_expr(c->expr);
break;
case EXEC_WRITE:
dumpf("%C.append(st_write(%L", n, &c->where);
goto show_dt;
case EXEC_READ:
dumpf("%C.append(st_read(%L", n, &c->where);
show_dt:
dt = c->ext.dt;
if (dt->io_unit->ts.type == BT_INTEGER)
dumpf(",unit=");
else
dumpf(",internal_unit=");
dump_expr(dt->io_unit);
if (dt->format_expr != NULL) {
dumpf(",format_expr=");
dump_expr(dt->format_expr);
}
if (dt->rec != NULL) {
dumpf(",rec=");
dump_expr(dt->rec);
}
if (dt->advance != NULL) {
dumpf(",advance=");
dump_expr(dt->advance);
}
if (dt->iostat != NULL) {
dumpf(",iostat=");
dump_expr(dt->iostat);
}
if (dt->size != NULL) {
dumpf(",size=");
dump_expr(dt->size);
}
if (dt->pos != NULL) {
dumpf(",pos=");
dump_expr(dt->pos);
}
if (dt->decimal != NULL) {
dumpf(",decimal=");
dump_expr(dt->decimal);
}
if (dt->namelist != NULL)
dumpf(",namelist=(%S,%L)", dt->namelist->name,
&dt->namelist_where);
if (dt->format_label != NULL)
dumpf(",format_label=%d", dt->format_label->value);
if (dt->err != NULL)
dumpf(",err=%d", dt->err->value);
if (dt->end != NULL)
dumpf(",end=%d", dt->end->value);
if (dt->eor != NULL)
dumpf(",eof=%d", dt->eor->value);
break;
case EXEC_TRANSFER:
dumpf("%C.append(st_transfer(%L,%d,", n, &c->expr->where,
c->ext.transfer == M_READ);
dump_expr(c->expr);
break;
case EXEC_ALLOCATE:
dumpf("%C.append(st_allocate(%L,", n, &c->where);
goto show_alloc;
case EXEC_DEALLOCATE:
dumpf("%C.append(st_deallocate(%L,", n, &c->where);
show_alloc:
dumpf("[");
alloc = c->ext.alloc_list;
while(alloc != NULL) {
dump_expr(alloc->expr);
if (alloc->next != NULL)
dump_char(',');
alloc = alloc->next;
}
dumpf("]");
if (c->expr != NULL) {
dumpf(",stat=");
dump_expr(c->expr);
}
break;
case EXEC_ARITHMETIC_IF:
dumpf("%C.append(st_arith_if(%L,", n, &c->where);
dump_expr(c->expr);
dumpf(", %d, %d, %d", c->label->value, c->label2->value,
c->label3->value);
break;
case EXEC_LABEL_ASSIGN:
dumpf("%C.append(st_label_assign(%L,", n, &c->where);
dump_expr(c->expr);
dumpf(", %d", c->label->value);
break;
case EXEC_SELECT:
for(d=c->block; d; d=d->block)
list_size++;
list = g95_getmem(list_size * sizeof(int));
m = 0;
for(d=c->block; d; d=d->block)
list[m++] = dump_code(d->next);
dumpf("%C.append(st_select(%L, ", n, &c->where);
dump_expr(c->expr);
dumpf(",[");
m = 0;
for(d=c->block; d; d=d->next) {
dumpf("[");
for(sel=d->ext.case_list; sel; sel=sel->next) {
dump_char('(');
if (sel->low == NULL)
dumpf("None");
else
dump_expr(sel->low);
dumpf(",");
if (sel->high == NULL)
dumpf("None");
else
dump_expr(sel->high);
}
dumpf("],%C,", list[m++]);
}
dump_char(']');
break;
case EXEC_CYCLE:
dumpf("%C.append(st_cycle(%L", n, &c->where);
if (c->sym != NULL)
dumpf(",label=%p", c->sym);
break;
case EXEC_EXIT:
dumpf("%C.append(st_exit(%L", n, &c->where);
if (c->sym != NULL)
dumpf(",label=%p", c->sym);
break;
case EXEC_ENTRY:
dumpf("%C.append(st_entry(%L,'%s',", n, &c->where, c->sym->name);
dump_formal(c->sym);
break;
case EXEC_WHERE:
for(d=c->block; d; d=d->block)
list_size++;
list = g95_getmem(list_size * sizeof(int));
m = 0;
for(d=c->block; d; d=d->block)
list[m++] = dump_code(d->next);
dumpf("%C.append(st_where(%L, [", n, &c->where);
m = 0;
for(d=c->block; d; d=d->block) {
dump_char('(');
if (d->expr == NULL)
dumpf("None");
else
dump_expr(d->expr);
dumpf(",%C),", list[m++]);
}
dump_char(']');
break;
case EXEC_FORALL:
node[0] = dump_code(c->block);
list = node;
list_size = 1;
dumpf("%C.append(st_forall(%L, [", n, &c->where);
for(f=c->ext.forall_iterator; f; f=f->next) {
dump_char('(');
dump_expr(f->var);
dump_char(',');
dump_expr(f->start);
dump_char(',');
dump_expr(f->end);
dump_char(',');
dump_expr(f->stride);
dump_char(')');
if (f->next != NULL)
dump_char(',');
}
dumpf("], %C", node[0]);
if (c->expr != NULL) {
dumpf(", mask=");
dump_expr(c->expr);
}
break;
case EXEC_CALL:
dumpf("%C.append(st_call(%L,", n, &c->where);
dump_name(c->sym, c->ext.sub.isym);
dump_char(',');
dump_actual(c->ext.sub.actual);
break;
default:
g95_internal_error("dump_code(): Bad code");
break;
}
if (c->here != NULL)
dumpf(",here=%d", c->here->value);
dumpf("))\n");
for(m=0; m<list_size; m++)
if (list[m] != 0)
dumpf("del %C\n", list[m]);
list_size = 0;
if (list != NULL && list != node)
g95_free(list);
}
return n;
}
static void dumpf(char *format, ...) {
char *p, c, buffer[100];
g95_locus *where;
va_list ap;
long ptr;
int m;
va_start(ap, format);
for(;;) {
c = *format++;
if (c == '\0')
break;
if (c != '%') {
dump_char(c);
continue;
}
switch(*format++) {
case 'd':
sprintf(buffer, "%d", va_arg(ap, int));
p = buffer;
while(*p != '\0')
dump_char(*p++);
break;
case 's':
p = va_arg(ap, char *);
while(*p != '\0')
dump_char(*p++);
break;
case 'p':
ptr = va_arg(ap, long);
dump_char('"');
dump_char(':');
do {
dump_char('A' + (ptr & 0x0F));
ptr >>= 4;
} while(ptr != 0);
dump_char('"');
break;
case 'S':
dump_char('\'');
p = va_arg(ap, char *);
if (p != NULL)
while(*p) {
c = *p++;
switch(c) {
case '\'':
case '\\':
dump_char('\\');
/* Fall through */
default:
dump_char(c);
break;
}
}
dump_char('\'');
break;
case 'L':
where = va_arg(ap, g95_locus *);
if (where == NULL)
p = "None";
else {
sprintf(buffer, "loc(%d,%d)", where->lb->linenum,
where->column);
p = buffer;
}
while(*p != '\0')
dump_char(*p++);
break;
case 'C': /* Statement lists. Zero is the null list. */
m = va_arg(ap, int);
if (m == 0) {
dump_char('[');
dump_char(']');
} else {
sprintf(buffer, "st%d", m);
p = buffer;
while(*p != '\0')
dump_char(*p++);
}
break;
case '%':
dump_char('%');
break;
default:
g95_internal_error("dumpf(): Bad %-code");
break;
}
}
va_end(ap);
}
static void dump_symtree(g95_symtree *st) {
g95_symbol *sym, *result;
char *module, *name;
sym_flavor flavor;
int rank;
if (st == NULL)
return;
dump_symtree(st->left);
dump_symtree(st->right);
sym = st->n.sym;
if (sym->mark)
return;
sym->mark = 1;
flavor = sym->attr.flavor;
module = sym->module;
if (module == NULL && sym->ns->state == COMP_MODULE)
module = sym->ns->proc_name->name;
if (g95_current_ns->proc_name == sym && sym->attr.function &&
sym->result == sym)
sym->attr.flavor = FL_VARIABLE;
switch(sym->attr.flavor) {
case FL_PROGRAM:
case FL_BLOCK_DATA:
case FL_MODULE:
break;
case FL_VARIABLE:
rank = (sym->as == NULL) ? 0 : sym->as->rank;
if (sym->attr.result_var)
name = "sym_result1";
else if (sym->attr.function && sym->result == sym)
name = "sym_result2";
else
name = "sym_variable";
dumpf("%s(%p, %S, %S, %L, %d, %S, %d, %d, %d, %d)\n",
name, sym, sym->name, module, &sym->declared_at,
sym->attr.use_assoc, g95_typename(&sym->ts), rank,
sym->attr.dummy, sym->attr.pointer, sym->attr.in_common);
break;
case FL_PARAMETER:
rank = (sym->as == NULL) ? 0 : sym->as->rank;
dumpf("sym_parameter(%p, %S, %S, %L, %S, %d)\n",
sym, sym->name, sym->module, &sym->declared_at,
g95_typename(&sym->ts), rank);
break;
case FL_LABEL:
dumpf("sym_label(%p, %S, %L)\n", sym, sym->name, &sym->declared_at);
break;
case FL_PROCEDURE:
switch(sym->attr.proc) {
case PROC_INTRINSIC:
break;
case PROC_ST_FUNCTION:
dumpf("sym_st_function(%p, %S, %L, %S)\n", sym, sym->name,
&sym->declared_at, g95_typename(&sym->ts));
break;
case PROC_MODULE:
case PROC_INTERNAL:
case PROC_DUMMY:
case PROC_EXTERNAL:
case PROC_UNKNOWN:
if (sym == g95_current_ns->proc_name)
break;
if (!sym->attr.function && !sym->attr.subroutine)
dumpf("sym_procedure(%p, %S, %L)\n", sym, sym->name,
&sym->declared_at);
else if (sym->attr.subroutine)
dumpf("sym_subroutine(%p, %S, %S, %L, %d, %d)\n",
sym, sym->name, sym->module, &sym->declared_at,
sym->attr.use_assoc, sym->attr.proc == PROC_INTERNAL);
else {
result = sym->result;
rank = (result->as == NULL) ? 0 : result->as->rank;
dumpf("sym_function(%p, %S, %S, %L, %d, %d, %S, %d, %d)\n",
sym, sym->name, sym->module, &sym->declared_at,
sym->attr.use_assoc, sym->attr.proc == PROC_INTERNAL,
g95_typename(&result->ts), rank, result->attr.pointer,
result->attr.pointer);
}
break;
default:
g95_internal_error("dump_symtree(): Bad procedure\n");
break;
}
break;
case FL_DERIVED:
dumpf("sym_derived(%p, %S, %S, %d, %L)\n", sym, sym->name, sym->module,
sym->attr.use_assoc, &sym->declared_at);
break;
case FL_NAMELIST:
dumpf("sym_namelist(%S, %L)\n", sym->name, &sym->declared_at);
break;
default:
g95_internal_error("dump_symtree(): Bad flavor");
break;
}
sym->attr.flavor = flavor;
}
static void dump_variable(g95_expr *e) {
g95_ref *ref;
int i;
dumpf("var(%L,%p,[", &e->where, e->symbol);
for(ref=e->ref; ref; ref=ref->next) {
switch(ref->type) {
case REF_ARRAY:
switch(ref->u.ar.type) {
case AR_FULL:
dumpf("ar_full()");
break;
case AR_ELEMENT:
dumpf("ar_element([");
for(i=0; i<ref->u.ar.dimen; i++) {
dump_expr(ref->u.ar.start[i]);
if (i < ref->u.ar.dimen-1)
dump_char(',');
}
dumpf("])");
break;
case AR_SECTION:
dumpf("ar_section([");
for(i=0; i<ref->u.ar.dimen; i++) {
switch(ref->u.ar.dimen_type[i]) {
case DIMEN_ELEMENT:
case DIMEN_VECTOR:
dump_expr(ref->u.ar.start[i]);
break;
case DIMEN_RANGE:
dump_char('(');
dump_expr(ref->u.ar.start[i]);
dump_char(',');
dump_expr(ref->u.ar.end[i]);
dump_char(',');
dump_expr(ref->u.ar.stride[i]);
dump_char(')');
break;
default:
g95_internal_error("dump_variable(): Bad dimen");
}
if (i < ref->u.ar.dimen-1)
dump_char(',');
}
dumpf("])");
break;
default:
g95_internal_error("dump_variable(): Bad array ref");
}
break;
case REF_COARRAY:
dumpf("coarray([");
for(i=0; i<ref->u.car.dimen; i++) {
dump_expr(ref->u.car.element[i]);
dump_char(',');
}
dumpf("])");
break;
case REF_COMPONENT:
dumpf("component(%S)", ref->u.c.name);
break;
case REF_SUBSTRING:
dumpf("substring(");
dump_expr(ref->u.ss.start);
dump_char(',');
dump_expr(ref->u.ss.end);
dump_char(')');
break;
default:
g95_internal_error("dump_variable(): Bad ref");
}
if (ref->next != NULL)
dump_char(',');
}
dump_char(']');
dump_char(')');
}
static void show_code0(int level, g95_code *c) {
g95_forall_iterator *fa;
char *module, *name;
g95_close *close;
g95_filepos *fp;
g95_inquire *i;
g95_open *open;
int m, comma;
g95_case *cp;
g95_alloc *a;
g95_code *d;
g95_dt *dt;
code_indent(level, c->here);
switch(c->type) {
case EXEC_NOP:
g95_status("nop(");
comma = 0;
break;
case EXEC_CONTINUE:
g95_status("cont(");
comma = 0;
break;
case EXEC_AC_START:
g95_status("ac_start(sym='%s'", c->sym->name);
comma = 1;
break;
case EXEC_AC_ASSIGN:
g95_status("ac_assign(sym='%s', expr=", c->sym->name);
g95_show_expr(c->expr);
break;
case EXEC_ASSIGN:
g95_status("assign(lhs=");
g95_show_expr(c->expr);
g95_status(", rhs=");
g95_show_expr(c->expr2);
comma = 1;
break;
case EXEC_WHERE_ASSIGN:
g95_status("where_assign(lhs=");
g95_show_expr(c->expr);
g95_status(", rhs=");
g95_show_expr(c->expr2);
comma = 1;
break;
case EXEC_POINTER_ASSIGN:
g95_status("ptr_assign(lhs=");
g95_show_expr(c->expr);
g95_status(", rhs=");
g95_show_expr(c->expr2);
comma = 1;
break;
case EXEC_GOTO:
if (c->label != NULL)
g95_status("goto(label=%d", c->label->value);
else
g95_status("goto(var='%s'", c->sym->name);
comma = 1;
break;
case EXEC_CALL:
if (c->sym == NULL)
module = name = "";
else {
module = c->sym->module;
name = c->sym->name;
}
g95_status("call(name='%s:%s', sub='%s', arg=",
module, name, c->ext.sub.sub_name);
show_actual_arglist(c->ext.sub.actual);
comma = 1;
break;
case EXEC_RETURN:
g95_status("ret(");
comma = 0;
if (c->expr) {
g95_status("value=");
g95_show_expr(c->expr);
comma = 1;
}
break;
case EXEC_STOP:
g95_status("stop(");
if (c->expr != NULL) {
g95_status("expr=");
g95_show_expr(c->expr);
} else
g95_status("code=%d", c->ext.stop_code);
comma = 1;
break;
case EXEC_PAUSE:
g95_status("pause(");
if (c->expr != NULL) {
g95_status("expr=");
g95_show_expr(c->expr);
} else
g95_status("code=%d", c->ext.stop_code);
comma = 1;
break;
case EXEC_ARITHMETIC_IF:
g95_status("arith_if(expr=");
g95_show_expr(c->expr);
g95_status(", lt0=%d, eq0=%d, gt0=%d",
c->label->value, c->label2->value, c->label3->value);
comma = 1;
break;
case EXEC_IF:
g95_status("log_if(expr=");
g95_show_expr(c->expr);
g95_status(", true=\n");
show_code(level+1, c->block);
if (c->ext.block != NULL) {
code_indent(level, 0);
g95_status(", else=\n");
show_code(level+1, c->ext.block);
}
code_indent(level, c->label);
g95_status(") # ENDIF\n");
break;
case EXEC_SELECT:
d = c->block;
g95_status("select(expr=");
g95_show_expr((c->expr != NULL) ? c->expr : c->expr2);
g95_status(", cases=[\n");
for(;d ;d=d->block) {
code_indent(level, 0);
g95_status("case(");
for(cp=d->ext.case_list; cp; cp=cp->next) {
g95_status_char('(');
g95_show_expr(cp->low);
g95_status_char(' ');
g95_show_expr(cp->high);
g95_status_char(')');
g95_status_char(' ');
}
g95_status_char('\n');
show_code(level+1, d->next);
}
code_indent(level, c->label);
g95_status("END SELECT");
break;
case EXEC_WHERE:
g95_status("WHERE ");
d = c->block;
g95_show_expr(d->expr);
g95_status_char('\n');
show_code(level+1, d->next);
for(d=d->block; d; d=d->block) {
code_indent(level, 0);
g95_status("ELSE WHERE ");
g95_show_expr(d->expr);
g95_status_char('\n');
show_code(level+1, d->next);
}
code_indent(level, 0);
g95_status("END WHERE");
break;
case EXEC_FORALL:
g95_status("FORALL ");
for(fa=c->ext.forall_iterator; fa; fa=fa->next) {
g95_show_expr(fa->var);
g95_status_char(' ');
g95_show_expr(fa->start);
g95_status_char(':');
g95_show_expr(fa->end);
g95_status_char(':');
g95_show_expr(fa->stride);
if (fa->next != NULL)
g95_status_char(',');
}
if (c->expr != NULL) {
g95_status_char(',');
g95_show_expr(c->expr);
}
g95_status_char('\n');
show_code(level+1, c->block);
code_indent(level, 0);
g95_status("END FORALL");
break;
case EXEC_DO:
g95_status("do(var=");
g95_show_expr(c->ext.iterator->var);
g95_status(", start=");
g95_show_expr(c->ext.iterator->start);
g95_status(", end=");
g95_show_expr(c->ext.iterator->end);
g95_status(", step=");
g95_show_expr(c->ext.iterator->step);
g95_status(", body=\n");
show_code(level+1, c->block);
code_indent(level, 0);
comma = 1;
break;
case EXEC_DO_WHILE:
g95_status("do_while(expr=");
g95_show_expr(c->expr);
g95_status(", body=");
show_code(level+1, c->block);
code_indent(level, c->label);
break;
case EXEC_CYCLE:
g95_status("cycle(");
comma = 0;
if (c->sym) {
g95_status("label='%s'", c->sym->name);
comma = 1;
}
break;
case EXEC_EXIT:
g95_status("exit(");
comma = 0;
if (c->sym) {
g95_status("label='%s'", c->sym->name);
comma = 1;
}
break;
case EXEC_ALLOCATE:
g95_status("allocate(");
comma = 0;
if (c->expr) {
g95_status("stat=");
g95_show_expr(c->expr);
comma = 1;
}
if (comma)
g95_status(", ");
g95_status("alloc=[");
for(a=c->ext.alloc_list; a; a=a->next) {
g95_show_expr(a->expr);
g95_status_char('(');
for(m=0; m < a->rank+a->corank; m++) {
g95_show_expr(a->lower[m]);
g95_status_char(':');
g95_show_expr(a->upper[m]);
if (m != a->rank + a->corank - 1)
g95_status_char(',');
}
g95_status_char(')');
if (a->next != NULL)
g95_status(", ");
}
g95_status_char(']');
comma = 1;
break;
case EXEC_DEALLOCATE:
g95_status("deallocate(");
comma = 0;
if (c->expr) {
g95_status("stat=");
g95_show_expr(c->expr);
comma = 1;
}
if (comma)
g95_status(", ");
g95_status("alloc=[");
for(a=c->ext.alloc_list; a; a=a->next) {
g95_show_expr(a->expr);
if (a->next != NULL)
g95_status(", ");
}
g95_status_char(']');
comma = 1;
break;
case EXEC_OPEN:
g95_status("open_(");
open = c->ext.open;
comma = 0;
if (open->unit) {
if (comma)
g95_status(", ");
g95_status("unit=");
g95_show_expr(open->unit);
comma = 1;
}
if (open->iostat) {
if (comma)
g95_status(", ");
g95_status("iostat=");
g95_show_expr(open->iostat);
comma = 1;
}
if (open->file) {
if (comma)
g95_status(", ");
g95_status("file=");
g95_show_expr(open->file);
comma = 1;
}
if (open->status) {
if (comma)
g95_status(", ");
g95_status("status=");
g95_show_expr(open->status);
comma = 1;
}
if (open->access) {
if (comma)
g95_status(", ");
g95_status("access=");
g95_show_expr(open->access);
comma = 1;
}
if (open->form) {
if (comma)
g95_status(", ");
g95_status("form=");
g95_show_expr(open->form);
comma = 1;
}
if (open->recl) {
if (comma)
g95_status(", ");
g95_status("recl=");
g95_show_expr(open->recl);
comma = 1;
}
if (open->blank) {
if (comma)
g95_status(", ");
g95_status("blank=");
g95_show_expr(open->blank);
comma = 1;
}
if (open->position) {
if (comma)
g95_status(", ");
g95_status("position=");
g95_show_expr(open->position);
comma = 1;
}
if (open->action) {
if (comma)
g95_status(", ");
g95_status("action=");
g95_show_expr(open->action);
comma = 1;
}
if (open->delim) {
if (comma)
g95_status(", ");
g95_status("delim=");
g95_show_expr(open->delim);
comma = 1;
}
if (open->pad) {
if (comma)
g95_status(", ");
g95_status("pad=");
g95_show_expr(open->pad);
comma = 1;
}
if (open->err != NULL) {
if (comma)
g95_status(", ");
g95_status("err=%d", open->err->value);
comma = 1;
}
break;
case EXEC_CLOSE:
g95_status("close(");
close = c->ext.close;
comma = 0;
if (close->unit) {
if (comma)
g95_status(", ");
g95_status("unit=");
g95_show_expr(close->unit);
comma = 1;
}
if (close->iostat) {
if (comma)
g95_status(", ");
g95_status("iostat=");
g95_show_expr(close->iostat);
comma = 1;
}
if (close->status) {
if (comma)
g95_status(", ");
g95_status("status=");
g95_show_expr(close->status);
comma = 1;
}
if (close->err != NULL) {
if (comma)
g95_status(", ");
g95_status("err=%d", close->err->value);
comma = 1;
}
break;
case EXEC_BACKSPACE:
g95_status("backspace(");
goto show_filepos;
case EXEC_ENDFILE:
g95_status("endfile(");
goto show_filepos;
case EXEC_REWIND:
g95_status("rewind(");
show_filepos:
fp = c->ext.filepos;
comma = 0;
if (fp->unit) {
if (comma)
g95_status(", ");
g95_status("unit=");
g95_show_expr(fp->unit);
comma = 1;
}
if (fp->iostat) {
if (comma)
g95_status(", ");
g95_status("iostat=");
g95_show_expr(fp->iostat);
comma = 1;
}
if (fp->err != NULL) {
if (comma)
g95_status(", ");
g95_status("err=%d", fp->err->value);
comma = 1;
}
break;
case EXEC_INQUIRE:
g95_status("inquire(");
i = c->ext.inquire;
comma = 0;
if (i->unit) {
if (comma)
g95_status(", ");
g95_status("unit=");
g95_show_expr(i->unit);
comma = 1;
}
if (i->file) {
if (comma)
g95_status(", ");
g95_status("file=");
g95_show_expr(i->file);
comma = 1;
}
if (i->iostat) {
if (comma)
g95_status(", ");
g95_status("iostat=");
g95_show_expr(i->iostat);
comma = 1;
}
if (i->exist) {
if (comma)
g95_status(", ");
g95_status("exist=");
g95_show_expr(i->exist);
comma = 1;
}
if (i->opened) {
if (comma)
g95_status(", ");
g95_status("opened=");
g95_show_expr(i->opened);
comma = 1;
}
if (i->number) {
if (comma)
g95_status(", ");
g95_status("number=");
g95_show_expr(i->number);
comma = 1;
}
if (i->named) {
if (comma)
g95_status(", ");
g95_status("named=");
g95_show_expr(i->named);
comma = 1;
}
if (i->name) {
if (comma)
g95_status(", ");
g95_status("name=");
g95_show_expr(i->name);
comma = 1;
}
if (i->access) {
if (comma)
g95_status(", ");
g95_status("access=");
g95_show_expr(i->access);
comma = 1;
}
if (i->sequential) {
if (comma)
g95_status(", ");
g95_status("sequential=");
g95_show_expr(i->sequential);
comma = 1;
}
if (i->direct) {
if (comma)
g95_status(", ");
g95_status("direct=");
g95_show_expr(i->direct);
comma = 1;
}
if (i->form) {
if (comma)
g95_status(", ");
g95_status("form=");
g95_show_expr(i->form);
comma = 1;
}
if (i->formatted) {
if (comma)
g95_status(", ");
g95_status("formatted=");
g95_show_expr(i->formatted);
comma = 1;
}
if (i->unformatted) {
if (comma)
g95_status(", ");
g95_status("unformatted=");
g95_show_expr(i->unformatted);
comma = 1;
}
if (i->recl) {
if (comma)
g95_status(", ");
g95_status("recl=");
g95_show_expr(i->recl);
comma = 1;
}
if (i->nextrec) {
if (comma)
g95_status(", ");
g95_status("nextrec=");
g95_show_expr(i->nextrec);
comma = 1;
}
if (i->blank) {
if (comma)
g95_status(", ");
g95_status("blank=");
g95_show_expr(i->blank);
comma = 1;
}
if (i->position) {
if (comma)
g95_status(", ");
g95_status("position=");
g95_show_expr(i->position);
comma = 1;
}
if (i->action) {
if (comma)
g95_status(", ");
g95_status("action=");
g95_show_expr(i->action);
comma = 1;
}
if (i->read) {
if (comma)
g95_status(", ");
g95_status("read=");
g95_show_expr(i->read);
comma = 1;
}
if (i->write) {
if (comma)
g95_status(", ");
g95_status("write=");
g95_show_expr(i->write);
comma = 1;
}
if (i->readwrite) {
if (comma)
g95_status(", ");
g95_status("readwrite=");
g95_show_expr(i->readwrite);
comma = 1;
}
if (i->delim) {
if (comma)
g95_status(", ");
g95_status("delim=");
g95_show_expr(i->delim);
comma = 1;
}
if (i->stream != NULL) {
if (comma)
g95_status(", ");
g95_status("stream=");
g95_show_expr(i->stream);
comma = 1;
}
if (i->pad) {
if (comma)
g95_status(", ");
g95_status("pad=");
g95_show_expr(i->pad);
comma = 1;
}
if (i->err != NULL) {
if (comma)
g95_status(", ");
g95_status("err=%d", i->err->value);
comma = 1;
}
break;
case EXEC_IOLENGTH:
g95_status("iolength(expr=");
g95_show_expr(c->expr);
comma = 0;
break;
case EXEC_READ:
g95_status("read(expr=");
goto show_dt;
case EXEC_WRITE:
g95_status("write(expr=");
show_dt:
dt = c->ext.dt;
comma = 0;
if (dt->io_unit) {
if (comma)
g95_status(", ");
g95_status("unit=");
g95_show_expr(dt->io_unit);
comma = 1;
}
if (dt->format_expr) {
if (comma)
g95_status(", ");
g95_status("format_expr=");
g95_show_expr(dt->format_expr);
comma = 1;
}
if (dt->format_label != NULL) {
if (comma)
g95_status(", ");
g95_status("format_label=%d", dt->format_label->value);
comma = 1;
}
if (dt->namelist != NULL) {
if (comma)
g95_status(", ");
g95_status("nml=%s", dt->namelist->name);
comma = 1;
}
if (dt->iostat != NULL) {
if (comma)
g95_status(", ");
g95_status("iostat=");
g95_show_expr(dt->iostat);
comma = 1;
}
if (dt->size != NULL) {
if (comma)
g95_status(", ");
g95_status("size=");
g95_show_expr(dt->size);
comma = 1;
}
if (dt->rec != NULL) {
if (comma)
g95_status(", ");
g95_status("rec=");
g95_show_expr(dt->rec);
comma = 1;
}
if (dt->advance) {
if (comma)
g95_status(", ");
g95_status("advance=");
g95_show_expr(dt->advance);
comma = 1;
}
break;
case EXEC_TRANSFER:
g95_status("transfer(expr=");
g95_show_expr(c->expr);
comma = 1;
break;
case EXEC_DT_END:
g95_status("dt_end(");
comma = 0;
dt = c->ext.dt;
if (dt != NULL) {
if (dt->err != NULL) {
if (comma)
g95_status(", ");
g95_status("err=%d", dt->err->value);
comma = 1;
}
if (dt->end != NULL) {
if (comma)
g95_status(", ");
g95_status("end=%d", dt->end->value);
comma = 1;
}
if (dt->eor != NULL) {
if (comma)
g95_status(", ");
g95_status("eor=%d", dt->eor->value);
comma = 1;
}
}
break;
case EXEC_ENTRY:
g95_status("entry(name='%s'", c->sym->name);
comma = 1;
break;
case EXEC_LABEL_ASSIGN:
g95_status("assign_label(expr=");
g95_show_expr(c->expr);
g95_status(", label=%d", c->label->value);
comma = 1;
break;
case EXEC_ERROR_STOP:
g95_status("ERROR STOP(");
break;
case EXEC_SYNC_ALL:
g95_status("SYNC ALL(");
break;
case EXEC_SYNC_MEMORY:
g95_status("SYNC MEMORY(");
break;
case EXEC_SYNC_IMAGES:
g95_status("SYNC IMAGES(");
if (c->expr == NULL)
g95_status_char('*');
else
g95_show_expr(c->expr);
break;
case EXEC_SYNC_TEAM:
g95_status("SYNC TEAM(");
if (c->expr == NULL)
g95_status_char('*');
else
g95_show_expr(c->expr);
break;
case EXEC_CRITICAL:
g95_status("CRITICAL\n");
show_code(level+1, c->block);
code_indent(level, 0);
g95_status("END CRITICAL");
break;
default:
g95_internal_error("show_code0(): Bad statement code");
}
g95_status_char(')');
g95_status_char('\n');
}
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(')');
}
static void dump_expr(g95_expr *e) {
if (e == NULL) {
dumpf("None");
return;
}
switch(e->type) {
case EXPR_NULL:
dumpf("null(%L,%S,%d)", &e->where, g95_typename(&e->ts), e->rank);
break;
case EXPR_OP:
dump_intrinsic(e);
break;
case EXPR_CONSTANT:
dump_constant(e);
break;
case EXPR_VARIABLE:
dump_variable(e);
break;
case EXPR_FUNCTION:
if (e->value.function.isym != NULL &&
e->value.function.isym->id == G95_ISYM_CONVERSION)
dump_expr(e->value.function.actual->u.expr);
else {
dumpf("fcall(%L,", &e->where);
dump_name(e->symbol, e->value.function.isym);
dumpf(",%S,%d,", g95_typename(&e->ts), e->rank);
dump_actual(e->value.function.actual);
dump_char(')');
}
break;
case EXPR_PROCEDURE:
dumpf("procedure(%L,", &e->where);
dump_name(e->symbol, NULL);
dump_char(')');
break;
case EXPR_STRUCTURE:
dump_cons("scons", e);
break;
case EXPR_ARRAY:
dump_cons("acons", e);
break;
case EXPR_SUBSTRING:
dumpf("substring_exp(%L,", &e->where);
dump_constant(e);
dump_char(',');
dump_expr(e->ref->u.ss.start);
dump_char(',');
dump_expr(e->ref->u.ss.end);
dump_char(')');
break;
default:
g95_internal_error("dump_expr(): Bad expression");
}
}
static void forall_body(g95_forall_iterator *m, int msk, g95_code *c) {
g95_ref *re, *alloc_ref;
g95_expr *e, *mask_expr;
g95_forall_iterator *p;
g95_symbol *v;
g95_code *r;
int k, rank;
if (!msk)
mask_expr = NULL;
else {
mask_expr = g95_build_funcall(NULL, NULL);
mask_expr->value.function.isym = &forall_get;
mask_expr->value.function.name = PREFIX "forall_get";
mask_expr->ts.type = BT_INTEGER;
mask_expr->ts.kind = g95_default_integer_kind();
}
switch(c->type) {
case EXEC_FORALL:
g95_expand_forall(c);
r = build_loops(m, mask_expr, c);
insert_post(r);
return;
case EXEC_WHERE:
g95_expand_where(&c);
r = build_loops(m, mask_expr, c);
insert_post(c);
return;
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
break;
default:
g95_internal_error("g95_expand_forall(): Bad code node");
}
if (!find_mask_symbol(c->expr2, c->expr->symbol)) {
r = build_loops(m, mask_expr, c);
insert_post(r);
} else {
rank = 0;
for(p=m; p; p=p->next)
rank++;
v = g95_get_temporary(&c->expr->ts, rank);
r = g95_get_code();
r->type = EXEC_ALLOCATE;
r->where = c->expr->where;
r->ext.alloc_list = g95_get_alloc();
r->ext.alloc_list->expr = e = g95_get_expr();
e->type = EXPR_VARIABLE;
e->where = current_node->where;
e->ts = v->ts;
e->symbol = v;
e->ref = alloc_ref = g95_get_ref();
e->where = current_node->where;
alloc_ref->type = REF_ARRAY;
alloc_ref->u.ar.type = AR_SECTION;
p = m;
for(k=0; k<rank; k++) {
forall_temp_array(&alloc_ref->u.ar, k, p);
p = p->next;
}
alloc_ref->u.ar.dimen = rank;
insert_post(r);
e = c->expr;
c->expr = forall_temp_expr(v, m);
r = build_loops(m, g95_copy_expr(mask_expr), c);
insert_post(r);
/* Copy temp back */
r = g95_get_code();
r->type = EXEC_ASSIGN;
r->where = current_node->where;
r->expr = e;
r->expr2 = forall_temp_expr(v, m);
r = build_loops(m, g95_copy_expr(mask_expr), r);
insert_post(r);
r = g95_get_code();
r->type = EXEC_DEALLOCATE;
r->where = c->where;
r->ext.alloc_list = g95_get_alloc();
r->ext.alloc_list->expr = e = g95_get_expr();
e->type = EXPR_VARIABLE;
e->where = current_node->where;
e->ts = v->ts;
e->symbol = v;
e->ref = re = g95_get_ref();
e->rank = rank;
e->where = c->where;
re->type = REF_ARRAY;
re->u.ar.type = AR_FULL;
insert_post(r);
}
}
