static void show_compcall (gfc_expr* p) { gcc_assert (p->expr_type == EXPR_COMPCALL); fprintf (dumpfile, "%s", p->symtree->n.sym->name); show_ref (p->ref); fprintf (dumpfile, "%s", p->value.compcall.name); show_actual_arglist (p->value.compcall.actual); }
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"); } }
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'); }
static void show_code_node (int level, gfc_code *c) { gfc_forall_iterator *fa; gfc_open *open; gfc_case *cp; gfc_alloc *a; gfc_code *d; gfc_close *close; gfc_filepos *fp; gfc_inquire *i; gfc_dt *dt; gfc_namespace *ns; if (c->here) { fputc ('\n', dumpfile); code_indent (level, c->here); } else show_indent (); switch (c->op) { case EXEC_END_PROCEDURE: break; case EXEC_NOP: fputs ("NOP", dumpfile); break; case EXEC_CONTINUE: fputs ("CONTINUE", dumpfile); break; case EXEC_ENTRY: fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name); break; case EXEC_INIT_ASSIGN: case EXEC_ASSIGN: fputs ("ASSIGN ", dumpfile); show_expr (c->expr1); fputc (' ', dumpfile); show_expr (c->expr2); break; case EXEC_LABEL_ASSIGN: fputs ("LABEL ASSIGN ", dumpfile); show_expr (c->expr1); fprintf (dumpfile, " %d", c->label1->value); break; case EXEC_POINTER_ASSIGN: fputs ("POINTER ASSIGN ", dumpfile); show_expr (c->expr1); fputc (' ', dumpfile); show_expr (c->expr2); break; case EXEC_GOTO: fputs ("GOTO ", dumpfile); if (c->label1) fprintf (dumpfile, "%d", c->label1->value); else { show_expr (c->expr1); d = c->block; if (d != NULL) { fputs (", (", dumpfile); for (; d; d = d ->block) { code_indent (level, d->label1); if (d->block != NULL) fputc (',', dumpfile); else fputc (')', dumpfile); } } } break; case EXEC_CALL: case EXEC_ASSIGN_CALL: if (c->resolved_sym) fprintf (dumpfile, "CALL %s ", c->resolved_sym->name); else if (c->symtree) fprintf (dumpfile, "CALL %s ", c->symtree->name); else fputs ("CALL ?? ", dumpfile); show_actual_arglist (c->ext.actual); break; case EXEC_COMPCALL: fputs ("CALL ", dumpfile); show_compcall (c->expr1); break; case EXEC_CALL_PPC: fputs ("CALL ", dumpfile); show_expr (c->expr1); show_actual_arglist (c->ext.actual); break; case EXEC_RETURN: fputs ("RETURN ", dumpfile); if (c->expr1) show_expr (c->expr1); break; case EXEC_PAUSE: fputs ("PAUSE ", dumpfile); if (c->expr1 != NULL) show_expr (c->expr1); else fprintf (dumpfile, "%d", c->ext.stop_code); break; case EXEC_ERROR_STOP: fputs ("ERROR ", dumpfile); /* Fall through. */ case EXEC_STOP: fputs ("STOP ", dumpfile); if (c->expr1 != NULL) show_expr (c->expr1); else fprintf (dumpfile, "%d", c->ext.stop_code); break; case EXEC_SYNC_ALL: fputs ("SYNC ALL ", dumpfile); if (c->expr2 != NULL) { fputs (" stat=", dumpfile); show_expr (c->expr2); } if (c->expr3 != NULL) { fputs (" errmsg=", dumpfile); show_expr (c->expr3); } break; case EXEC_SYNC_MEMORY: fputs ("SYNC MEMORY ", dumpfile); if (c->expr2 != NULL) { fputs (" stat=", dumpfile); show_expr (c->expr2); } if (c->expr3 != NULL) { fputs (" errmsg=", dumpfile); show_expr (c->expr3); } break; case EXEC_SYNC_IMAGES: fputs ("SYNC IMAGES image-set=", dumpfile); if (c->expr1 != NULL) show_expr (c->expr1); else fputs ("* ", dumpfile); if (c->expr2 != NULL) { fputs (" stat=", dumpfile); show_expr (c->expr2); } if (c->expr3 != NULL) { fputs (" errmsg=", dumpfile); show_expr (c->expr3); } break; case EXEC_LOCK: case EXEC_UNLOCK: if (c->op == EXEC_LOCK) fputs ("LOCK ", dumpfile); else fputs ("UNLOCK ", dumpfile); fputs ("lock-variable=", dumpfile); if (c->expr1 != NULL) show_expr (c->expr1); if (c->expr4 != NULL) { fputs (" acquired_lock=", dumpfile); show_expr (c->expr4); } if (c->expr2 != NULL) { fputs (" stat=", dumpfile); show_expr (c->expr2); } if (c->expr3 != NULL) { fputs (" errmsg=", dumpfile); show_expr (c->expr3); } break; case EXEC_ARITHMETIC_IF: fputs ("IF ", dumpfile); show_expr (c->expr1); fprintf (dumpfile, " %d, %d, %d", c->label1->value, c->label2->value, c->label3->value); break; case EXEC_IF: d = c->block; fputs ("IF ", dumpfile); show_expr (d->expr1); ++show_level; show_code (level + 1, d->next); --show_level; d = d->block; for (; d; d = d->block) { code_indent (level, 0); if (d->expr1 == NULL) fputs ("ELSE", dumpfile); else { fputs ("ELSE IF ", dumpfile); show_expr (d->expr1); } ++show_level; show_code (level + 1, d->next); --show_level; } if (c->label1) code_indent (level, c->label1); else show_indent (); fputs ("ENDIF", dumpfile); break; case EXEC_BLOCK: { const char* blocktype; gfc_namespace *saved_ns; if (c->ext.block.assoc) blocktype = "ASSOCIATE"; else blocktype = "BLOCK"; show_indent (); fprintf (dumpfile, "%s ", blocktype); ++show_level; ns = c->ext.block.ns; saved_ns = gfc_current_ns; gfc_current_ns = ns; gfc_traverse_symtree (ns->sym_root, show_symtree); gfc_current_ns = saved_ns; show_code (show_level, ns->code); --show_level; show_indent (); fprintf (dumpfile, "END %s ", blocktype); break; } case EXEC_SELECT: d = c->block; fputs ("SELECT CASE ", dumpfile); show_expr (c->expr1); fputc ('\n', dumpfile); for (; d; d = d->block) { code_indent (level, 0); fputs ("CASE ", dumpfile); for (cp = d->ext.block.case_list; cp; cp = cp->next) { fputc ('(', dumpfile); show_expr (cp->low); fputc (' ', dumpfile); show_expr (cp->high); fputc (')', dumpfile); fputc (' ', dumpfile); } fputc ('\n', dumpfile); show_code (level + 1, d->next); } code_indent (level, c->label1); fputs ("END SELECT", dumpfile); break; case EXEC_WHERE: fputs ("WHERE ", dumpfile); d = c->block; show_expr (d->expr1); fputc ('\n', dumpfile); show_code (level + 1, d->next); for (d = d->block; d; d = d->block) { code_indent (level, 0); fputs ("ELSE WHERE ", dumpfile); show_expr (d->expr1); fputc ('\n', dumpfile); show_code (level + 1, d->next); } code_indent (level, 0); fputs ("END WHERE", dumpfile); break; case EXEC_FORALL: fputs ("FORALL ", dumpfile); for (fa = c->ext.forall_iterator; fa; fa = fa->next) { show_expr (fa->var); fputc (' ', dumpfile); show_expr (fa->start); fputc (':', dumpfile); show_expr (fa->end); fputc (':', dumpfile); show_expr (fa->stride); if (fa->next != NULL) fputc (',', dumpfile); } if (c->expr1 != NULL) { fputc (',', dumpfile); show_expr (c->expr1); } fputc ('\n', dumpfile); show_code (level + 1, c->block->next); code_indent (level, 0); fputs ("END FORALL", dumpfile); break; case EXEC_CRITICAL: fputs ("CRITICAL\n", dumpfile); show_code (level + 1, c->block->next); code_indent (level, 0); fputs ("END CRITICAL", dumpfile); break; case EXEC_DO: fputs ("DO ", dumpfile); if (c->label1) fprintf (dumpfile, " %-5d ", c->label1->value); show_expr (c->ext.iterator->var); fputc ('=', dumpfile); show_expr (c->ext.iterator->start); fputc (' ', dumpfile); show_expr (c->ext.iterator->end); fputc (' ', dumpfile); show_expr (c->ext.iterator->step); ++show_level; show_code (level + 1, c->block->next); --show_level; if (c->label1) break; show_indent (); fputs ("END DO", dumpfile); break; case EXEC_DO_CONCURRENT: fputs ("DO CONCURRENT ", dumpfile); for (fa = c->ext.forall_iterator; fa; fa = fa->next) { show_expr (fa->var); fputc (' ', dumpfile); show_expr (fa->start); fputc (':', dumpfile); show_expr (fa->end); fputc (':', dumpfile); show_expr (fa->stride); if (fa->next != NULL) fputc (',', dumpfile); } show_expr (c->expr1); show_code (level + 1, c->block->next); code_indent (level, c->label1); fputs ("END DO", dumpfile); break; case EXEC_DO_WHILE: fputs ("DO WHILE ", dumpfile); show_expr (c->expr1); fputc ('\n', dumpfile); show_code (level + 1, c->block->next); code_indent (level, c->label1); fputs ("END DO", dumpfile); break; case EXEC_CYCLE: fputs ("CYCLE", dumpfile); if (c->symtree) fprintf (dumpfile, " %s", c->symtree->n.sym->name); break; case EXEC_EXIT: fputs ("EXIT", dumpfile); if (c->symtree) fprintf (dumpfile, " %s", c->symtree->n.sym->name); break; case EXEC_ALLOCATE: fputs ("ALLOCATE ", dumpfile); if (c->expr1) { fputs (" STAT=", dumpfile); show_expr (c->expr1); } if (c->expr2) { fputs (" ERRMSG=", dumpfile); show_expr (c->expr2); } if (c->expr3) { if (c->expr3->mold) fputs (" MOLD=", dumpfile); else fputs (" SOURCE=", dumpfile); show_expr (c->expr3); } for (a = c->ext.alloc.list; a; a = a->next) { fputc (' ', dumpfile); show_expr (a->expr); } break; case EXEC_DEALLOCATE: fputs ("DEALLOCATE ", dumpfile); if (c->expr1) { fputs (" STAT=", dumpfile); show_expr (c->expr1); } if (c->expr2) { fputs (" ERRMSG=", dumpfile); show_expr (c->expr2); } for (a = c->ext.alloc.list; a; a = a->next) { fputc (' ', dumpfile); show_expr (a->expr); } break; case EXEC_OPEN: fputs ("OPEN", dumpfile); open = c->ext.open; if (open->unit) { fputs (" UNIT=", dumpfile); show_expr (open->unit); } if (open->iomsg) { fputs (" IOMSG=", dumpfile); show_expr (open->iomsg); } if (open->iostat) { fputs (" IOSTAT=", dumpfile); show_expr (open->iostat); } if (open->file) { fputs (" FILE=", dumpfile); show_expr (open->file); } if (open->status) { fputs (" STATUS=", dumpfile); show_expr (open->status); } if (open->access) { fputs (" ACCESS=", dumpfile); show_expr (open->access); } if (open->form) { fputs (" FORM=", dumpfile); show_expr (open->form); } if (open->recl) { fputs (" RECL=", dumpfile); show_expr (open->recl); } if (open->blank) { fputs (" BLANK=", dumpfile); show_expr (open->blank); } if (open->position) { fputs (" POSITION=", dumpfile); show_expr (open->position); } if (open->action) { fputs (" ACTION=", dumpfile); show_expr (open->action); } if (open->delim) { fputs (" DELIM=", dumpfile); show_expr (open->delim); } if (open->pad) { fputs (" PAD=", dumpfile); show_expr (open->pad); } if (open->decimal) { fputs (" DECIMAL=", dumpfile); show_expr (open->decimal); } if (open->encoding) { fputs (" ENCODING=", dumpfile); show_expr (open->encoding); } if (open->round) { fputs (" ROUND=", dumpfile); show_expr (open->round); } if (open->sign) { fputs (" SIGN=", dumpfile); show_expr (open->sign); } if (open->convert) { fputs (" CONVERT=", dumpfile); show_expr (open->convert); } if (open->asynchronous) { fputs (" ASYNCHRONOUS=", dumpfile); show_expr (open->asynchronous); } if (open->err != NULL) fprintf (dumpfile, " ERR=%d", open->err->value); break; case EXEC_CLOSE: fputs ("CLOSE", dumpfile); close = c->ext.close; if (close->unit) { fputs (" UNIT=", dumpfile); show_expr (close->unit); } if (close->iomsg) { fputs (" IOMSG=", dumpfile); show_expr (close->iomsg); } if (close->iostat) { fputs (" IOSTAT=", dumpfile); show_expr (close->iostat); } if (close->status) { fputs (" STATUS=", dumpfile); show_expr (close->status); } if (close->err != NULL) fprintf (dumpfile, " ERR=%d", close->err->value); break; case EXEC_BACKSPACE: fputs ("BACKSPACE", dumpfile); goto show_filepos; case EXEC_ENDFILE: fputs ("ENDFILE", dumpfile); goto show_filepos; case EXEC_REWIND: fputs ("REWIND", dumpfile); goto show_filepos; case EXEC_FLUSH: fputs ("FLUSH", dumpfile); show_filepos: fp = c->ext.filepos; if (fp->unit) { fputs (" UNIT=", dumpfile); show_expr (fp->unit); } if (fp->iomsg) { fputs (" IOMSG=", dumpfile); show_expr (fp->iomsg); } if (fp->iostat) { fputs (" IOSTAT=", dumpfile); show_expr (fp->iostat); } if (fp->err != NULL) fprintf (dumpfile, " ERR=%d", fp->err->value); break; case EXEC_INQUIRE: fputs ("INQUIRE", dumpfile); i = c->ext.inquire; if (i->unit) { fputs (" UNIT=", dumpfile); show_expr (i->unit); } if (i->file) { fputs (" FILE=", dumpfile); show_expr (i->file); } if (i->iomsg) { fputs (" IOMSG=", dumpfile); show_expr (i->iomsg); } if (i->iostat) { fputs (" IOSTAT=", dumpfile); show_expr (i->iostat); } if (i->exist) { fputs (" EXIST=", dumpfile); show_expr (i->exist); } if (i->opened) { fputs (" OPENED=", dumpfile); show_expr (i->opened); } if (i->number) { fputs (" NUMBER=", dumpfile); show_expr (i->number); } if (i->named) { fputs (" NAMED=", dumpfile); show_expr (i->named); } if (i->name) { fputs (" NAME=", dumpfile); show_expr (i->name); } if (i->access) { fputs (" ACCESS=", dumpfile); show_expr (i->access); } if (i->sequential) { fputs (" SEQUENTIAL=", dumpfile); show_expr (i->sequential); } if (i->direct) { fputs (" DIRECT=", dumpfile); show_expr (i->direct); } if (i->form) { fputs (" FORM=", dumpfile); show_expr (i->form); } if (i->formatted) { fputs (" FORMATTED", dumpfile); show_expr (i->formatted); } if (i->unformatted) { fputs (" UNFORMATTED=", dumpfile); show_expr (i->unformatted); } if (i->recl) { fputs (" RECL=", dumpfile); show_expr (i->recl); } if (i->nextrec) { fputs (" NEXTREC=", dumpfile); show_expr (i->nextrec); } if (i->blank) { fputs (" BLANK=", dumpfile); show_expr (i->blank); } if (i->position) { fputs (" POSITION=", dumpfile); show_expr (i->position); } if (i->action) { fputs (" ACTION=", dumpfile); show_expr (i->action); } if (i->read) { fputs (" READ=", dumpfile); show_expr (i->read); } if (i->write) { fputs (" WRITE=", dumpfile); show_expr (i->write); } if (i->readwrite) { fputs (" READWRITE=", dumpfile); show_expr (i->readwrite); } if (i->delim) { fputs (" DELIM=", dumpfile); show_expr (i->delim); } if (i->pad) { fputs (" PAD=", dumpfile); show_expr (i->pad); } if (i->convert) { fputs (" CONVERT=", dumpfile); show_expr (i->convert); } if (i->asynchronous) { fputs (" ASYNCHRONOUS=", dumpfile); show_expr (i->asynchronous); } if (i->decimal) { fputs (" DECIMAL=", dumpfile); show_expr (i->decimal); } if (i->encoding) { fputs (" ENCODING=", dumpfile); show_expr (i->encoding); } if (i->pending) { fputs (" PENDING=", dumpfile); show_expr (i->pending); } if (i->round) { fputs (" ROUND=", dumpfile); show_expr (i->round); } if (i->sign) { fputs (" SIGN=", dumpfile); show_expr (i->sign); } if (i->size) { fputs (" SIZE=", dumpfile); show_expr (i->size); } if (i->id) { fputs (" ID=", dumpfile); show_expr (i->id); } if (i->err != NULL) fprintf (dumpfile, " ERR=%d", i->err->value); break; case EXEC_IOLENGTH: fputs ("IOLENGTH ", dumpfile); show_expr (c->expr1); goto show_dt_code; break; case EXEC_READ: fputs ("READ", dumpfile); goto show_dt; case EXEC_WRITE: fputs ("WRITE", dumpfile); show_dt: dt = c->ext.dt; if (dt->io_unit) { fputs (" UNIT=", dumpfile); show_expr (dt->io_unit); } if (dt->format_expr) { fputs (" FMT=", dumpfile); show_expr (dt->format_expr); } if (dt->format_label != NULL) fprintf (dumpfile, " FMT=%d", dt->format_label->value); if (dt->namelist) fprintf (dumpfile, " NML=%s", dt->namelist->name); if (dt->iomsg) { fputs (" IOMSG=", dumpfile); show_expr (dt->iomsg); } if (dt->iostat) { fputs (" IOSTAT=", dumpfile); show_expr (dt->iostat); } if (dt->size) { fputs (" SIZE=", dumpfile); show_expr (dt->size); } if (dt->rec) { fputs (" REC=", dumpfile); show_expr (dt->rec); } if (dt->advance) { fputs (" ADVANCE=", dumpfile); show_expr (dt->advance); } if (dt->id) { fputs (" ID=", dumpfile); show_expr (dt->id); } if (dt->pos) { fputs (" POS=", dumpfile); show_expr (dt->pos); } if (dt->asynchronous) { fputs (" ASYNCHRONOUS=", dumpfile); show_expr (dt->asynchronous); } if (dt->blank) { fputs (" BLANK=", dumpfile); show_expr (dt->blank); } if (dt->decimal) { fputs (" DECIMAL=", dumpfile); show_expr (dt->decimal); } if (dt->delim) { fputs (" DELIM=", dumpfile); show_expr (dt->delim); } if (dt->pad) { fputs (" PAD=", dumpfile); show_expr (dt->pad); } if (dt->round) { fputs (" ROUND=", dumpfile); show_expr (dt->round); } if (dt->sign) { fputs (" SIGN=", dumpfile); show_expr (dt->sign); } show_dt_code: for (c = c->block->next; c; c = c->next) show_code_node (level + (c->next != NULL), c); return; case EXEC_TRANSFER: fputs ("TRANSFER ", dumpfile); show_expr (c->expr1); break; case EXEC_DT_END: fputs ("DT_END", dumpfile); dt = c->ext.dt; if (dt->err != NULL) fprintf (dumpfile, " ERR=%d", dt->err->value); if (dt->end != NULL) fprintf (dumpfile, " END=%d", dt->end->value); if (dt->eor != NULL) fprintf (dumpfile, " EOR=%d", dt->eor->value); break; case EXEC_OMP_ATOMIC: case EXEC_OMP_BARRIER: case EXEC_OMP_CRITICAL: case EXEC_OMP_FLUSH: case EXEC_OMP_DO: case EXEC_OMP_MASTER: case EXEC_OMP_ORDERED: case EXEC_OMP_PARALLEL: case EXEC_OMP_PARALLEL_DO: case EXEC_OMP_PARALLEL_SECTIONS: case EXEC_OMP_PARALLEL_WORKSHARE: case EXEC_OMP_SECTIONS: case EXEC_OMP_SINGLE: case EXEC_OMP_TASK: case EXEC_OMP_TASKWAIT: case EXEC_OMP_TASKYIELD: case EXEC_OMP_WORKSHARE: show_omp_node (level, c); break; default: gfc_internal_error ("show_code_node(): Bad statement code"); } }
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(')'); }