static
void dump_graph(const GoughGraph &g, const string &base, const Grey &grey) {
stringstream ss;
ss << grey.dumpPath << "gough_" << base << ".dot";
FILE *f = fopen(ss.str().c_str(), "w");
fprintf(f, "digraph NFA {\n");
fprintf(f, "rankdir=LR;\n");
fprintf(f, "size=\"11.5,8\"\n");
fprintf(f, "node [ shape = circle ];\n");
fprintf(f, "START [style=invis];\n");
for (auto v : vertices_range(g)) {
fprintf(f, "%s [ width = 1, fixedsize = true, fontsize = 12, ",
dump_name(g[v]).c_str());
if (!g[v].reports.empty() || !g[v].reports_eod.empty()) {
fprintf(f, "shape = doublecircle ");
}
fprintf(f, "label = \"%u\"];\n", g[v].state_id);
}
for (const auto &e : edges_range(g)) {
GoughVertex s = source(e, g);
GoughVertex t = target(e, g);
fprintf(f, "%s -> %s\n",
dump_name(g[s]).c_str(), dump_name(g[t]).c_str());
}
fprintf(f, "}\n");
fclose(f);
}
static
void gather_vars(const GoughGraph &g, vector<const GoughSSAVar *> *vars,
map<const GoughSSAVar *, string> *names,
map<const GoughSSAVar *, string> *src_label,
set<const GoughSSAVar *> *reporters) {
for (auto v : vertices_range(g)) {
for (const auto &r : g[v].reports) {
reporters->insert(r.second);
}
for (const auto &r : g[v].reports_eod) {
reporters->insert(r.second);
}
for (u32 i = 0; i < g[v].vars.size(); i++) {
const GoughSSAVar *vp = g[v].vars[i].get();
stringstream ss;
ss << dump_name(g[v]) << "_" << i;
vars->push_back(vp);
names->insert(make_pair(vp, ss.str()));
src_label->insert(make_pair(vp, dump_name(g[v])));
}
}
for (const auto &e : edges_range(g)) {
for (u32 i = 0; i < g[e].vars.size(); i++) {
const GoughSSAVar *vp = g[e].vars[i].get();
stringstream ss;
ss << dump_name(g, e) << "_" << i;
vars->push_back(vp);
names->insert(make_pair(vp, ss.str()));
src_label->insert(make_pair(vp, dump_name(g, e)));
}
}
}
static
void dump_var_mapping(const GoughGraph &g, const string &base,
const Grey &grey) {
stringstream ss;
ss << grey.dumpPath << "gough_" << base << "_vars.txt";
FILE *f = fopen(ss.str().c_str(), "w");
for (auto v : vertices_range(g)) {
set<const GoughSSAVar *> used = uses(g[v]);
if (g[v].vars.empty() && used.empty()) {
continue;
}
fprintf(f, "%s\n", dump_name(g[v]).c_str());
for (u32 i = 0; i < g[v].vars.size(); i++) {
const GoughSSAVar *vp = g[v].vars[i].get();
fprintf(f, "\t%u: slot %u\n", i, vp->slot);
}
if (!used.empty()) {
fprintf(f, "\tuses:");
vector<u32> used_id;
for (const GoughSSAVar *var : used) {
used_id.push_back(var->slot);
}
for (const u32 &id : used_id) {
fprintf(f, " %u", id);
}
fprintf(f, "\n");
}
}
for (const auto &e : edges_range(g)) {
set<const GoughSSAVar *> used = uses(g[e]);
if (g[e].vars.empty() && used.empty()) {
continue;
}
fprintf(f, "%s\n", dump_name(g, e).c_str());
for (u32 i = 0; i < g[e].vars.size(); i++) {
const GoughSSAVar *vp = g[e].vars[i].get();
fprintf(f, "\t%u: slot %u\n", i, vp->slot);
}
if (!used.empty()) {
fprintf(f, "\tuses:");
vector<u32> used_id;
for (const GoughSSAVar *var : used) {
used_id.push_back(var->slot);
}
for (const u32 &id : used_id) {
fprintf(f, " %u", id);
}
fprintf(f, "\n");
}
}
fclose(f);
}
/*
* dump_hll_sstModules - dump HLL sstModules at 'offset' from 'base'
*/
static void dump_hll_sstModules( unsigned_32 base, unsigned_32 offset )
/*********************************************************************/
{
hll_module mod;
hll_seginfo seg;
bool first = true;
Wlseek( base + offset );
Wdputs( "==== sstModules at offset " );
Puthex( offset, 8 );
Wdputslc( "\n" );
Wread( &mod, offsetof( hll_module, name_len ) );
Dump_header( &mod, hll_sstModules_msg );
hll_level = mod.Version >> 8;
Wdputs( " module name: \"" );
dump_name( 0 );
Wdputslc( "\"\n" );
if( mod.cSeg ) {
while( --mod.cSeg ) {
if( !first ) {
Wdputslc( " ====\n" );
}
Wread( &seg, sizeof( seg ) );
Dump_header( &seg, hll_seg_msg );
first = false;
}
}
Wdputslc( "\n" );
}
/*
* dump_cv_sstModules - dump CV sstModules at 'offset' from 'base'
*/
static void dump_cv_sstModules( unsigned_32 base, unsigned_32 offset )
/********************************************************************/
{
cv3_module_16 mod;
cv3_seginfo_16 seg;
bool first = true;
Wlseek( base + offset );
Wdputs( "==== sstModules at offset " );
Puthex( offset, 8 );
Wdputslc( "\n" );
Wread( &mod, offsetof( cv3_module_16, name_len ) );
Dump_header( &mod, cv_sstModules_msg );
Wdputs( " module name: \"" );
dump_name( 0 );
Wdputslc( "\"\n" );
if( mod.cSeg ) {
while( --mod.cSeg ) {
if( !first ) {
Wdputslc( " ====\n" );
}
Wread( &seg, sizeof( seg ) );
Dump_header( &seg, cv_seg_msg );
first = false;
}
}
Wdputslc( "\n" );
}
static
void dump_block(FILE *f, const gough_edge_id &e,
const vector<gough_ins> &block) {
fprintf(f, "%s:\n", dump_name(e).c_str());
for (const gough_ins &ins : block) {
fprintf(f, "\t");
switch (ins.op) {
case GOUGH_INS_END:
fprintf(f, "END");
break;
case GOUGH_INS_MOV:
fprintf(f, "MOV %u %u", ins.dest, ins.src);
break;
case GOUGH_INS_NEW:
fprintf(f, "NEW %u (+%u)", ins.dest, ins.src);
break;
case GOUGH_INS_MIN:
fprintf(f, "MIN %u %u", ins.dest, ins.src);
break;
default:
fprintf(f, "<UNKNOWN>");
break;
}
fprintf(f, "\n");
}
}
void del_client(client_t *c, int mode)
{
client_t *p;
XGrabServer(dpy);
XSetErrorHandler(ignore_xerror);
#ifdef DEBUG
dump_name(c, "removing", 'r');
dump_removal(c, mode);
#endif
if (mode == DEL_WITHDRAW) {
set_wm_state(c, WithdrawnState);
} else /* mode == DEL_REMAP */ {
if (c->zoomed) {
c->geom.x = c->save.x;
c->geom.y = c->save.y;
c->geom.w = c->save.w;
c->geom.h = c->save.h;
XResizeWindow(dpy, c->win, c->geom.w, c->geom.h);
}
XMapWindow(dpy, c->win);
}
remove_atom(root, net_client_list, XA_WINDOW, c->win);
remove_atom(root, net_client_stack, XA_WINDOW, c->win);
XSetWindowBorderWidth(dpy, c->win, c->old_bw);
#ifdef XFT
if (c->xftdraw)
XftDrawDestroy(c->xftdraw);
#endif
XReparentWindow(dpy, c->win, root, c->geom.x, c->geom.y);
XRemoveFromSaveSet(dpy, c->win);
XDestroyWindow(dpy, c->frame);
if (head == c)
head = c->next;
else for (p = head; p && p->next; p = p->next)
if (p->next == c)
p->next = c->next;
if (c->name) XFree(c->name);
free(c);
XSync(dpy, False);
XSetErrorHandler(handle_xerror);
XUngrabServer(dpy);
}
/*
* dump_cv_sstSrcLnSeg - dump sstSrcLnSeg at 'offset' from 'base'
*/
static void dump_cv_sstSrcLnSeg( unsigned_32 base, unsigned_32 offset )
/*********************************************************************/
{
cv_linnum_seg src_ln;
cv3_linnum_entry_16 lo_16;
Wlseek( base + offset );
Wdputs( "==== sstSrcLnSeg at offset " );
Puthex( offset, 8 );
Wdputslc( "\n" );
Wdputs( " source file: \"" );
dump_name( 2 );
Wdputslc( "\"\n" );
Wread( &src_ln, sizeof( src_ln ) );
Dump_header( &src_ln, cv_sstSrcLnSeg_msg );
while( src_ln.cPair-- ) {
Wread( &lo_16, sizeof( lo_16 ) );
Dump_header( &lo_16, cv_lnoff16_msg );
}
Wdputslc( "\n" );
}
/*
* dump_cv_sstLibraries - dump CV sstLibraries at 'offset'
* from 'base' containing 'size' bytes
*/
static void dump_cv_sstLibraries( unsigned_32 base, unsigned_32 offset,
unsigned_32 size )
/*********************************************************************/
{
unsigned index = 0;
unsigned_32 read = 0;
Wlseek( base + offset );
Wdputs( "==== sstLibraries at offset " );
Puthex( offset, 8 );
Wdputslc( "\n" );
while( read < size ) {
Wdputs( " index: " );
Puthex( index, 4 );
Wdputs( "H name: \"" );
read += dump_name( 0 );
Wdputslc( "\"\n" );
++index;
}
Wdputslc( "\n" );
}
/*
* dump_hll_sstHLLSrc - dump HLL sstHLLSrc at 'offset' from 'base'
* containing 'size' bytes
*/
static void dump_hll_sstHLLSrc( unsigned_32 base, unsigned_32 offset,
unsigned_32 size )
/*******************************************************************/
{
Wlseek( base + offset );
Wdputs( "==== sstHLLSrc at offset " );
Puthex( offset, 8 );
Wdputslc( "\n" );
#if 0/* FIXME: structure changes broke this. */
if( hll_level >= 0x04 ) {
hl4_linnum_first_lines first_entry;
unsigned_32 count = 0;
while( count < size ) {
Wread( &first_entry, sizeof( first_entry ) );
Dump_header( &first_entry, hl4_linnum_first_msg );
count += sizeof( first_entry );
if( first_entry.core.entry_type == 0x03 ) {
hl4_filetab_entry ftab_entry;
unsigned_32 index;
Wread( &ftab_entry, sizeof( ftab_entry ) );
Dump_header( &ftab_entry, hl4_filetab_entry_msg );
count += sizeof( ftab_entry );
for( index = 0; index < ftab_entry.numFiles; ++index ) {
Wdputs( " file index: " );
Puthex( index, 4 );
Wdputs( "H name: \"" );
count += dump_name( 0 );
Wdputslc( "\"\n" );
}
Wdputslc( "\n" );
} else if( first_entry.core.entry_type == 0x00 ) {
hl3_linnum_entry lnum_entry;
unsigned_32 index;
for( index = 0; index < first_entry.num_line_entries; ++index ) {
Wread( &lnum_entry, sizeof( lnum_entry ) );
count += sizeof( lnum_entry );
Dump_header( &lnum_entry, hll_linnum_entry_msg );
}
Wdputslc( "\n" );
} else {
Wdputslc( "unsupported linnum table entry format\n" );
}
}
} else {
hl2_linnum_first first_entry;
unsigned_32 index;
Wread( &first_entry, sizeof( first_entry ) );
Dump_header( &first_entry, hl3_linnum_first_msg );
if( first_entry.entry_type == 0x00 ) {
hl3_filetab_entry ftab_entry;
hl3_linnum_entry lnum_entry;
for( index = 0; index < first_entry.num_entries; ++index ) {
Wread( &lnum_entry, sizeof( lnum_entry ) );
Dump_header( &lnum_entry, hll_linnum_entry_msg );
}
Wread( &ftab_entry, sizeof( ftab_entry ) );
Dump_header( &ftab_entry, hl3_filetab_entry_msg );
for( index = 0; index < ftab_entry.numFiles; ++index ) {
Wdputs( " file index: " );
Puthex( index, 4 );
Wdputs( "H name: \"" );
dump_name( 0 );
Wdputslc( "\"\n" );
}
Wdputslc( "\n" );
} else {
Wdputslc( "unsupported linnum table entry format\n" );
}
}
#endif
}
client_t *new_client(Window w)
{
client_t *c;
XWindowAttributes attr;
XColor exact;
long supplied;
Atom win_type;
c = malloc(sizeof *c);
c->next = head;
head = c;
c->name = get_wm_name(w);
c->win = w;
c->frame = None;
c->size.flags = 0;
c->ignore_unmap = 0;
#ifdef SHAPE
c->shaped = 0;
#endif
c->shaded = 0;
c->zoomed = 0;
c->decor = 1;
XGetWMNormalHints(dpy, c->win, &c->size, &supplied);
XGetTransientForHint(dpy, c->win, &c->trans);
XGetWindowAttributes(dpy, c->win, &attr);
c->geom.x = attr.x;
c->geom.y = attr.y;
c->geom.w = attr.width;
c->geom.h = attr.height;
c->cmap = attr.colormap;
c->old_bw = attr.border_width;
#ifdef DEBUG
dump_name(c, "creating", 'w');
dump_geom(c, "initial");
#endif
XAllocNamedColor(dpy, c->cmap, opt_fg, &fg, &exact);
XAllocNamedColor(dpy, c->cmap, opt_bg, &bg, &exact);
XAllocNamedColor(dpy, c->cmap, opt_bd, &bd, &exact);
if (get_atoms(c->win, net_wm_wintype, XA_ATOM, 0, &win_type, 1, NULL))
c->decor = HAS_DECOR(win_type);
if (get_atoms(c->win, net_wm_desk, XA_CARDINAL, 0, &c->desk, 1, NULL)) {
if (c->desk == -1) c->desk = DESK_ALL; /* FIXME */
if (c->desk >= ndesks && c->desk != DESK_ALL)
c->desk = cur_desk;
} else {
set_atoms(c->win, net_wm_desk, XA_CARDINAL, &cur_desk, 1);
c->desk = cur_desk;
}
#ifdef DEBUG
dump_info(c);
#endif
check_states(c);
/* We are not actually keeping the stack one in order. However, every
* fancy panel uses it and nothing else, no matter what the spec says.
* (I'm not sure why, as rearranging the list every time the stacking
* changes would be distracting. GNOME's window list applet doesn't.) */
append_atoms(root, net_client_list, XA_WINDOW, &c->win, 1);
append_atoms(root, net_client_stack, XA_WINDOW, &c->win, 1);
return c;
}
static void
process_name (char * name_string, int line_num, int name_num)
{
bt_name * name;
bt_name_format * format;
printf ("original name = %s\n", name_string);
name = bt_split_name (name_string, "stdin", line_num, name_num);
if (! (name && name->tokens))
{
fprintf (stderr, "empty name\n");
return;
}
dump_name (name);
/* First "vljf", unabbreviated first name. */
format = bt_create_name_format ("vljf", FALSE);
show_formatted_name ("fname 1", format, name);
/* Now abbreviate first name stupidly (ie. with no post-token text) */
bt_set_format_options (format, BTN_FIRST, TRUE, BTJ_MAYTIE, BTJ_SPACE);
show_formatted_name ("fname 2", format, name);
/* Add those missing post-token periods */
bt_set_format_text (format, BTN_FIRST, NULL, NULL, NULL, ".");
show_formatted_name ("fname 3", format, name);
/* Drop the periods and force no space between first-name tokens */
bt_set_format_text (format, BTN_FIRST, NULL, NULL, NULL, "");
bt_set_format_options (format, BTN_FIRST, TRUE, BTJ_NOTHING, BTJ_SPACE);
show_formatted_name ("fname 4", format, name);
/* Finish with this format, and create a new one: "fvlj", abbreviated. */
bt_free_name_format (format);
format = bt_create_name_format ("fvlj", TRUE);
show_formatted_name ("fname 5", format, name);
/* Degenerate to "no periods, no spaces" abbrev again */
bt_set_format_text (format, BTN_FIRST, NULL, NULL, NULL, "");
bt_set_format_options (format, BTN_FIRST, TRUE, BTJ_NOTHING, BTJ_SPACE);
show_formatted_name ("fname 6", format, name);
/* OK, let's play at something a little more "custom": kindergarten-
* style names (full first name, abbreviated last name, forget about
* 'von' and 'jr'.
*/
bt_free_name_format (format);
format = bt_create_name_format ("fl", FALSE);
bt_set_format_text (format, BTN_LAST, NULL, NULL, NULL, ".");
bt_set_format_options (format, BTN_LAST, TRUE, BTJ_MAYTIE, BTJ_SPACE);
show_formatted_name ("fname 7", format, name);
/* 'von' and 'last' only, abbreviated with no periods or spaces */
bt_free_name_format (format);
format = bt_create_name_format ("vl", FALSE);
bt_set_format_options (format, BTN_VON, TRUE, BTJ_NOTHING, BTJ_NOTHING);
bt_set_format_options (format, BTN_LAST, TRUE, BTJ_NOTHING, BTJ_NOTHING);
show_formatted_name ("fname 8", format, name);
bt_free_name_format (format);
bt_free_name (name);
} /* process_name () */
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 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");
}
}
