static inline void
show_indent (void)
{
fputc ('\n', dumpfile);
code_indent (show_level, NULL);
}
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");
}
}
static void
show_omp_node (int level, gfc_code *c)
{
gfc_omp_clauses *omp_clauses = NULL;
const char *name = NULL;
switch (c->op)
{
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
case EXEC_OMP_DO: name = "DO"; break;
case EXEC_OMP_MASTER: name = "MASTER"; break;
case EXEC_OMP_ORDERED: name = "ORDERED"; break;
case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
case EXEC_OMP_SINGLE: name = "SINGLE"; break;
case EXEC_OMP_TASK: name = "TASK"; break;
case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
default:
gcc_unreachable ();
}
fprintf (dumpfile, "!$OMP %s", name);
switch (c->op)
{
case EXEC_OMP_DO:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_TASK:
omp_clauses = c->ext.omp_clauses;
break;
case EXEC_OMP_CRITICAL:
if (c->ext.omp_name)
fprintf (dumpfile, " (%s)", c->ext.omp_name);
break;
case EXEC_OMP_FLUSH:
if (c->ext.omp_namelist)
{
fputs (" (", dumpfile);
show_namelist (c->ext.omp_namelist);
fputc (')', dumpfile);
}
return;
case EXEC_OMP_BARRIER:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
return;
default:
break;
}
if (omp_clauses)
{
int list_type;
if (omp_clauses->if_expr)
{
fputs (" IF(", dumpfile);
show_expr (omp_clauses->if_expr);
fputc (')', dumpfile);
}
if (omp_clauses->final_expr)
{
fputs (" FINAL(", dumpfile);
show_expr (omp_clauses->final_expr);
fputc (')', dumpfile);
}
if (omp_clauses->num_threads)
{
fputs (" NUM_THREADS(", dumpfile);
show_expr (omp_clauses->num_threads);
fputc (')', dumpfile);
}
if (omp_clauses->sched_kind != OMP_SCHED_NONE)
{
const char *type;
switch (omp_clauses->sched_kind)
{
case OMP_SCHED_STATIC: type = "STATIC"; break;
case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
case OMP_SCHED_GUIDED: type = "GUIDED"; break;
case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
case OMP_SCHED_AUTO: type = "AUTO"; break;
default:
gcc_unreachable ();
}
fprintf (dumpfile, " SCHEDULE (%s", type);
if (omp_clauses->chunk_size)
{
fputc (',', dumpfile);
show_expr (omp_clauses->chunk_size);
}
fputc (')', dumpfile);
}
if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
{
const char *type;
switch (omp_clauses->default_sharing)
{
case OMP_DEFAULT_NONE: type = "NONE"; break;
case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
case OMP_DEFAULT_SHARED: type = "SHARED"; break;
case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
default:
gcc_unreachable ();
}
fprintf (dumpfile, " DEFAULT(%s)", type);
}
if (omp_clauses->ordered)
fputs (" ORDERED", dumpfile);
if (omp_clauses->untied)
fputs (" UNTIED", dumpfile);
if (omp_clauses->mergeable)
fputs (" MERGEABLE", dumpfile);
if (omp_clauses->collapse)
fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
if (omp_clauses->lists[list_type] != NULL
&& list_type != OMP_LIST_COPYPRIVATE)
{
const char *type;
if (list_type >= OMP_LIST_REDUCTION_FIRST)
{
switch (list_type)
{
case OMP_LIST_PLUS: type = "+"; break;
case OMP_LIST_MULT: type = "*"; break;
case OMP_LIST_SUB: type = "-"; break;
case OMP_LIST_AND: type = ".AND."; break;
case OMP_LIST_OR: type = ".OR."; break;
case OMP_LIST_EQV: type = ".EQV."; break;
case OMP_LIST_NEQV: type = ".NEQV."; break;
case OMP_LIST_MAX: type = "MAX"; break;
case OMP_LIST_MIN: type = "MIN"; break;
case OMP_LIST_IAND: type = "IAND"; break;
case OMP_LIST_IOR: type = "IOR"; break;
case OMP_LIST_IEOR: type = "IEOR"; break;
default:
gcc_unreachable ();
}
fprintf (dumpfile, " REDUCTION(%s:", type);
}
else
{
switch (list_type)
{
case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
case OMP_LIST_SHARED: type = "SHARED"; break;
case OMP_LIST_COPYIN: type = "COPYIN"; break;
default:
gcc_unreachable ();
}
fprintf (dumpfile, " %s(", type);
}
show_namelist (omp_clauses->lists[list_type]);
fputc (')', dumpfile);
}
}
fputc ('\n', dumpfile);
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
{
gfc_code *d = c->block;
while (d != NULL)
{
show_code (level + 1, d->next);
if (d->block == NULL)
break;
code_indent (level, 0);
fputs ("!$OMP SECTION\n", dumpfile);
d = d->block;
}
}
else
show_code (level + 1, c->block->next);
if (c->op == EXEC_OMP_ATOMIC)
return;
code_indent (level, 0);
fprintf (dumpfile, "!$OMP END %s", name);
if (omp_clauses != NULL)
{
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
{
fputs (" COPYPRIVATE(", dumpfile);
show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
fputc (')', dumpfile);
}
else if (omp_clauses->nowait)
fputs (" NOWAIT", dumpfile);
}
else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
fprintf (dumpfile, " (%s)", c->ext.omp_name);
}
static void
gfc_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;
code_indent (level, c->here);
switch (c->op)
{
case EXEC_NOP:
gfc_status ("NOP");
break;
case EXEC_CONTINUE:
gfc_status ("CONTINUE");
break;
case EXEC_ENTRY:
gfc_status ("ENTRY %s", c->ext.entry->sym->name);
break;
case EXEC_INIT_ASSIGN:
case EXEC_ASSIGN:
gfc_status ("ASSIGN ");
gfc_show_expr (c->expr);
gfc_status_char (' ');
gfc_show_expr (c->expr2);
break;
case EXEC_LABEL_ASSIGN:
gfc_status ("LABEL ASSIGN ");
gfc_show_expr (c->expr);
gfc_status (" %d", c->label->value);
break;
case EXEC_POINTER_ASSIGN:
gfc_status ("POINTER ASSIGN ");
gfc_show_expr (c->expr);
gfc_status_char (' ');
gfc_show_expr (c->expr2);
break;
case EXEC_GOTO:
gfc_status ("GOTO ");
if (c->label)
gfc_status ("%d", c->label->value);
else
{
gfc_show_expr (c->expr);
d = c->block;
if (d != NULL)
{
gfc_status (", (");
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
gfc_status_char (',');
else
gfc_status_char (')');
}
}
}
break;
case EXEC_CALL:
if (c->resolved_sym)
gfc_status ("CALL %s ", c->resolved_sym->name);
else if (c->symtree)
gfc_status ("CALL %s ", c->symtree->name);
else
gfc_status ("CALL ?? ");
gfc_show_actual_arglist (c->ext.actual);
break;
case EXEC_RETURN:
gfc_status ("RETURN ");
if (c->expr)
gfc_show_expr (c->expr);
break;
case EXEC_PAUSE:
gfc_status ("PAUSE ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
break;
case EXEC_STOP:
gfc_status ("STOP ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
break;
case EXEC_ARITHMETIC_IF:
gfc_status ("IF ");
gfc_show_expr (c->expr);
gfc_status (" %d, %d, %d",
c->label->value, c->label2->value, c->label3->value);
break;
case EXEC_IF:
d = c->block;
gfc_status ("IF ");
gfc_show_expr (d->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
d = d->block;
for (; d; d = d->block)
{
code_indent (level, 0);
if (d->expr == NULL)
gfc_status ("ELSE\n");
else
{
gfc_status ("ELSE IF ");
gfc_show_expr (d->expr);
gfc_status_char ('\n');
}
gfc_show_code (level + 1, d->next);
}
code_indent (level, c->label);
gfc_status ("ENDIF");
break;
case EXEC_SELECT:
d = c->block;
gfc_status ("SELECT CASE ");
gfc_show_expr (c->expr);
gfc_status_char ('\n');
for (; d; d = d->block)
{
code_indent (level, 0);
gfc_status ("CASE ");
for (cp = d->ext.case_list; cp; cp = cp->next)
{
gfc_status_char ('(');
gfc_show_expr (cp->low);
gfc_status_char (' ');
gfc_show_expr (cp->high);
gfc_status_char (')');
gfc_status_char (' ');
}
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
}
code_indent (level, c->label);
gfc_status ("END SELECT");
break;
case EXEC_WHERE:
gfc_status ("WHERE ");
d = c->block;
gfc_show_expr (d->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
for (d = d->block; d; d = d->block)
{
code_indent (level, 0);
gfc_status ("ELSE WHERE ");
gfc_show_expr (d->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
}
code_indent (level, 0);
gfc_status ("END WHERE");
break;
case EXEC_FORALL:
gfc_status ("FORALL ");
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
{
gfc_show_expr (fa->var);
gfc_status_char (' ');
gfc_show_expr (fa->start);
gfc_status_char (':');
gfc_show_expr (fa->end);
gfc_status_char (':');
gfc_show_expr (fa->stride);
if (fa->next != NULL)
gfc_status_char (',');
}
if (c->expr != NULL)
{
gfc_status_char (',');
gfc_show_expr (c->expr);
}
gfc_status_char ('\n');
gfc_show_code (level + 1, c->block->next);
code_indent (level, 0);
gfc_status ("END FORALL");
break;
case EXEC_DO:
gfc_status ("DO ");
gfc_show_expr (c->ext.iterator->var);
gfc_status_char ('=');
gfc_show_expr (c->ext.iterator->start);
gfc_status_char (' ');
gfc_show_expr (c->ext.iterator->end);
gfc_status_char (' ');
gfc_show_expr (c->ext.iterator->step);
gfc_status_char ('\n');
gfc_show_code (level + 1, c->block->next);
code_indent (level, 0);
gfc_status ("END DO");
break;
case EXEC_DO_WHILE:
gfc_status ("DO WHILE ");
gfc_show_expr (c->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, c->block->next);
code_indent (level, c->label);
gfc_status ("END DO");
break;
case EXEC_CYCLE:
gfc_status ("CYCLE");
if (c->symtree)
gfc_status (" %s", c->symtree->n.sym->name);
break;
case EXEC_EXIT:
gfc_status ("EXIT");
if (c->symtree)
gfc_status (" %s", c->symtree->n.sym->name);
break;
case EXEC_ALLOCATE:
gfc_status ("ALLOCATE ");
if (c->expr)
{
gfc_status (" STAT=");
gfc_show_expr (c->expr);
}
for (a = c->ext.alloc_list; a; a = a->next)
{
gfc_status_char (' ');
gfc_show_expr (a->expr);
}
break;
case EXEC_DEALLOCATE:
gfc_status ("DEALLOCATE ");
if (c->expr)
{
gfc_status (" STAT=");
gfc_show_expr (c->expr);
}
for (a = c->ext.alloc_list; a; a = a->next)
{
gfc_status_char (' ');
gfc_show_expr (a->expr);
}
break;
case EXEC_OPEN:
gfc_status ("OPEN");
open = c->ext.open;
if (open->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (open->unit);
}
if (open->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (open->iomsg);
}
if (open->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (open->iostat);
}
if (open->file)
{
gfc_status (" FILE=");
gfc_show_expr (open->file);
}
if (open->status)
{
gfc_status (" STATUS=");
gfc_show_expr (open->status);
}
if (open->access)
{
gfc_status (" ACCESS=");
gfc_show_expr (open->access);
}
if (open->form)
{
gfc_status (" FORM=");
gfc_show_expr (open->form);
}
if (open->recl)
{
gfc_status (" RECL=");
gfc_show_expr (open->recl);
}
if (open->blank)
{
gfc_status (" BLANK=");
gfc_show_expr (open->blank);
}
if (open->position)
{
gfc_status (" POSITION=");
gfc_show_expr (open->position);
}
if (open->action)
{
gfc_status (" ACTION=");
gfc_show_expr (open->action);
}
if (open->delim)
{
gfc_status (" DELIM=");
gfc_show_expr (open->delim);
}
if (open->pad)
{
gfc_status (" PAD=");
gfc_show_expr (open->pad);
}
if (open->convert)
{
gfc_status (" CONVERT=");
gfc_show_expr (open->convert);
}
if (open->err != NULL)
gfc_status (" ERR=%d", open->err->value);
break;
case EXEC_CLOSE:
gfc_status ("CLOSE");
close = c->ext.close;
if (close->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (close->unit);
}
if (close->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (close->iomsg);
}
if (close->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (close->iostat);
}
if (close->status)
{
gfc_status (" STATUS=");
gfc_show_expr (close->status);
}
if (close->err != NULL)
gfc_status (" ERR=%d", close->err->value);
break;
case EXEC_BACKSPACE:
gfc_status ("BACKSPACE");
goto show_filepos;
case EXEC_ENDFILE:
gfc_status ("ENDFILE");
goto show_filepos;
case EXEC_REWIND:
gfc_status ("REWIND");
goto show_filepos;
case EXEC_FLUSH:
gfc_status ("FLUSH");
show_filepos:
fp = c->ext.filepos;
if (fp->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (fp->unit);
}
if (fp->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (fp->iomsg);
}
if (fp->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (fp->iostat);
}
if (fp->err != NULL)
gfc_status (" ERR=%d", fp->err->value);
break;
case EXEC_INQUIRE:
gfc_status ("INQUIRE");
i = c->ext.inquire;
if (i->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (i->unit);
}
if (i->file)
{
gfc_status (" FILE=");
gfc_show_expr (i->file);
}
if (i->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (i->iomsg);
}
if (i->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (i->iostat);
}
if (i->exist)
{
gfc_status (" EXIST=");
gfc_show_expr (i->exist);
}
if (i->opened)
{
gfc_status (" OPENED=");
gfc_show_expr (i->opened);
}
if (i->number)
{
gfc_status (" NUMBER=");
gfc_show_expr (i->number);
}
if (i->named)
{
gfc_status (" NAMED=");
gfc_show_expr (i->named);
}
if (i->name)
{
gfc_status (" NAME=");
gfc_show_expr (i->name);
}
if (i->access)
{
gfc_status (" ACCESS=");
gfc_show_expr (i->access);
}
if (i->sequential)
{
gfc_status (" SEQUENTIAL=");
gfc_show_expr (i->sequential);
}
if (i->direct)
{
gfc_status (" DIRECT=");
gfc_show_expr (i->direct);
}
if (i->form)
{
gfc_status (" FORM=");
gfc_show_expr (i->form);
}
if (i->formatted)
{
gfc_status (" FORMATTED");
gfc_show_expr (i->formatted);
}
if (i->unformatted)
{
gfc_status (" UNFORMATTED=");
gfc_show_expr (i->unformatted);
}
if (i->recl)
{
gfc_status (" RECL=");
gfc_show_expr (i->recl);
}
if (i->nextrec)
{
gfc_status (" NEXTREC=");
gfc_show_expr (i->nextrec);
}
if (i->blank)
{
gfc_status (" BLANK=");
gfc_show_expr (i->blank);
}
if (i->position)
{
gfc_status (" POSITION=");
gfc_show_expr (i->position);
}
if (i->action)
{
gfc_status (" ACTION=");
gfc_show_expr (i->action);
}
if (i->read)
{
gfc_status (" READ=");
gfc_show_expr (i->read);
}
if (i->write)
{
gfc_status (" WRITE=");
gfc_show_expr (i->write);
}
if (i->readwrite)
{
gfc_status (" READWRITE=");
gfc_show_expr (i->readwrite);
}
if (i->delim)
{
gfc_status (" DELIM=");
gfc_show_expr (i->delim);
}
if (i->pad)
{
gfc_status (" PAD=");
gfc_show_expr (i->pad);
}
if (i->convert)
{
gfc_status (" CONVERT=");
gfc_show_expr (i->convert);
}
if (i->err != NULL)
gfc_status (" ERR=%d", i->err->value);
break;
case EXEC_IOLENGTH:
gfc_status ("IOLENGTH ");
gfc_show_expr (c->expr);
goto show_dt_code;
break;
case EXEC_READ:
gfc_status ("READ");
goto show_dt;
case EXEC_WRITE:
gfc_status ("WRITE");
show_dt:
dt = c->ext.dt;
if (dt->io_unit)
{
gfc_status (" UNIT=");
gfc_show_expr (dt->io_unit);
}
if (dt->format_expr)
{
gfc_status (" FMT=");
gfc_show_expr (dt->format_expr);
}
if (dt->format_label != NULL)
gfc_status (" FMT=%d", dt->format_label->value);
if (dt->namelist)
gfc_status (" NML=%s", dt->namelist->name);
if (dt->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (dt->iomsg);
}
if (dt->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (dt->iostat);
}
if (dt->size)
{
gfc_status (" SIZE=");
gfc_show_expr (dt->size);
}
if (dt->rec)
{
gfc_status (" REC=");
gfc_show_expr (dt->rec);
}
if (dt->advance)
{
gfc_status (" ADVANCE=");
gfc_show_expr (dt->advance);
}
show_dt_code:
gfc_status_char ('\n');
for (c = c->block->next; c; c = c->next)
gfc_show_code_node (level + (c->next != NULL), c);
return;
case EXEC_TRANSFER:
gfc_status ("TRANSFER ");
gfc_show_expr (c->expr);
break;
case EXEC_DT_END:
gfc_status ("DT_END");
dt = c->ext.dt;
if (dt->err != NULL)
gfc_status (" ERR=%d", dt->err->value);
if (dt->end != NULL)
gfc_status (" END=%d", dt->end->value);
if (dt->eor != NULL)
gfc_status (" EOR=%d", dt->eor->value);
break;
default:
gfc_internal_error ("gfc_show_code_node(): Bad statement code");
}
gfc_status_char ('\n');
}
static inline void
show_indent (void)
{
gfc_status ("\n");
code_indent (show_level, NULL);
}
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');
}
