int eval_expr (int Sharp, int Complain)
{
char c;
char d;
int rv;
sharp = Sharp;
complain = Complain;
expr = read_expr_();
if (sharp)
{
c = getnonhspace();
d = '\n';
}
else
{
c = getnonspace();
d = ')';
}
if (c != d)
{
if (complain)
{
err_head();
fprintf(stderr, "expression syntax error -- junk after expression\n");
}
while (Get() != d)
;
}
#ifdef DEBUG_EXPR
if (debugging)
{
outputc('<');
dump_expr(expr);
outputc('=');
rv = exec_free(expr);
outputd(rv);
outputc('>');
}
else
{
rv = exec_free(expr);
}
return (rv);
#else
return (exec_free(expr));
#endif
}
void dump_object( FILE *fp, char *filename )
{
long obj_start = ftell(fp) - 8; /* before signature */
int org = -1;
long fp_modname, fp_expr, fp_names, fp_extern, fp_code;
if ( file_version >= 8 )
; /* no object ORG - ORG is now per section */
else if ( file_version >= 5 )
org = (int) xfread_long( fp, filename );
else
org = xfread_word( fp, filename );
fp_modname = xfread_long( fp, filename );
fp_expr = xfread_long( fp, filename );
fp_names = xfread_long( fp, filename );
fp_extern = xfread_long( fp, filename );
fp_code = xfread_long( fp, filename );
/* module name */
fseek( fp, obj_start + fp_modname, SEEK_SET );
printf(" Name: %s\n", xfread_string( fp, filename ) );
/* org */
if ( org >= 0 )
printf(" Org: $%04X\n", org );
/* names */
if ( fp_names >= 0 )
dump_names( fp, filename,
obj_start + fp_names,
obj_start + END( fp_extern, fp_modname ) );
/* extern */
if ( fp_extern >= 0 )
dump_extern( fp, filename,
obj_start + fp_extern,
obj_start + fp_modname );
/* expressions */
if ( fp_expr >= 0 && opt_showexpr )
dump_expr( fp, filename,
obj_start + fp_expr,
obj_start + END( fp_names, END( fp_extern, fp_modname ) ) );
/* code */
if ( fp_code >= 0 && opt_dump_code )
dump_code( fp, filename, obj_start + fp_code );
}
static void dump_plist(struct plist *plist)
{
if (plist) {
struct property *p;
int nprops = 0;
for (p = plist->head; p != NULL; p = p->next)
nprops++;
dump_integer(nprops);
for (p = plist->head; p != NULL; p = p->next) {
dump_symbol(p->keyword);
dump_expr(p->expr);
}
}
else
dump_integer(0);
}
/* Dumps av_set AV. */
void
dump_av_set (av_set_t av)
{
av_set_iterator i;
expr_t expr;
if (!sched_dump_to_dot_p)
sel_print ("{");
FOR_EACH_EXPR (expr, i, av)
{
dump_expr (expr);
if (!sched_dump_to_dot_p)
sel_print (" ");
else
sel_print ("\n");
}
static void dump_actual(g95_actual_arglist *actual) {
dump_char('[');
while(actual != NULL) {
if (actual->type == ARG_ALT_RETURN)
dumpf("%d", actual->u.label->value);
else if (actual->u.expr == NULL)
dumpf("None");
else
dump_expr(actual->u.expr);
actual = actual->next;
if (actual != NULL)
dump_char(',');
}
dump_char(']');
}
void dump_init(dump *ctx, decl_init *dinit)
{
if(dinit == DYNARRAY_NULL){
dump_printf(ctx, "<null init>\n");
return;
}
switch(dinit->type){
case decl_init_scalar:
{
dump_expr(dinit->bits.expr, ctx);
break;
}
case decl_init_brace:
{
decl_init **i;
dump_desc(ctx, "brace init", dinit, &dinit->where);
dump_inc(ctx);
for(i = dinit->bits.ar.inits; i && *i; i++)
dump_init(ctx, *i);
dump_dec(ctx);
break;
}
case decl_init_copy:
{
struct init_cpy *cpy = *dinit->bits.range_copy;
dump_init(ctx, cpy->range_init);
break;
}
}
}
void Parser::dump_expr(FILE *f, ExprNode *node)
{
if(node->op == OP_FIRST)
fprintf(f, "[");
else
fprintf(f, "(");
fflush(f);
for(ExprNode *i = node; i != NULL; i = i->next)
{
switch(i->op)
{
case OP_CONSTANT:
fprintf(f, "%f", (float)(i->number));
break;
case OP_VARIABLE:
fprintf(f, "%s", i->variable);
break;
case OP_DOT:
fprintf(f, ".");
break;
case OP_MEMBER:
fprintf(f, "%s", i->variable);
break;
case OP_CALL:
fprintf(f, "fn%d", (int)(i->call.fn));
break;
case OP_CMP_EQ:
fprintf(f, " == ");
break;
case OP_CMP_NE:
fprintf(f, " != ");
break;
case OP_CMP_LT:
fprintf(f, " < ");
break;
case OP_CMP_LE:
fprintf(f, " <= ");
break;
case OP_CMP_GT:
fprintf(f, " > ");
break;
case OP_CMP_GE:
fprintf(f, " >= ");
break;
case OP_ADD:
fprintf(f, " + ");
break;
case OP_SUB:
fprintf(f, " - ");
break;
case OP_OR:
fprintf(f, " | ");
break;
case OP_MUL:
fprintf(f, " * ");
break;
case OP_DIV:
fprintf(f, " / ");
break;
case OP_AND:
fprintf(f, " & ");
break;
case OP_POW:
fprintf(f, " ^ ");
break;
case OP_NEG:
fprintf(f, " -");
break;
case OP_NOT:
fprintf(f, " !");
break;
default:
break;
}
fflush(f);
if(i->child != NULL)
dump_expr(f, i->child);
}
if(node->op == OP_FIRST)
fprintf(f, "]");
else
fprintf(f, ")");
fflush(f);
}
static void dump_defclass_constituent(struct defclass_constituent *c)
{
struct superclass *super;
struct slot_spec *slot;
struct initarg_spec *initarg;
struct inherited_spec *inherited;
int n;
dump_op(fop_DEFINE_CLASS);
n = 0;
for (super = c->supers; super != NULL; super = super->next)
n++;
dump_integer(n);
for (super = c->supers; super != NULL; super = super->next)
dump_expr(super->expr);
n = 0;
for (slot = c->slots; slot != NULL; slot = slot->next)
n++;
dump_integer(n);
for (slot = c->slots; slot != NULL; slot = slot->next) {
switch (slot->alloc) {
case alloc_INSTANCE:
dump_symbol(sym_Instance);
break;
case alloc_CLASS:
dump_symbol(sym_Class);
break;
case alloc_EACH_SUBCLASS:
dump_symbol(sym_Each_Subclass);
break;
case alloc_VIRTUAL:
dump_symbol(sym_Virtual);
break;
default:
lose("strange slot allocation");
}
if (slot->name)
dump_id(slot->name);
else
dump_op(fop_FALSE);
if (slot->type)
dump_expr(slot->type);
else
dump_op(fop_FALSE);
dump_plist(slot->plist);
}
n = 0;
for (initarg = c->initargs; initarg != NULL; initarg = initarg->next)
n++;
dump_integer(n);
for (initarg = c->initargs; initarg != NULL; initarg = initarg->next) {
dump_symbol(initarg->keyword);
dump_plist(initarg->plist);
}
n = 0;
for (inherited = c->inheriteds; inherited != NULL;
inherited = inherited->next)
n++;
dump_integer(n);
for (inherited = c->inheriteds; inherited != NULL;
inherited = inherited->next) {
dump_id(inherited->name);
dump_plist(inherited->plist);
}
}
static void dump_varset_expr(struct varset_expr *expr)
{
dump_op(fop_VARSET_EXPR);
dump_id(expr->var);
dump_expr(expr->value);
}
static void dump_dot_expr(struct dot_expr *expr)
{
dump_op(fop_DOT_EXPR);
dump_expr(expr->arg);
dump_expr(expr->func);
}
static void dump_bindings(struct bindings *bindings)
{
dump_param_list(bindings->params);
dump_expr(bindings->expr);
}
static lisp_obj *apply(lisp_expr_application *app, lisp_env *env, lisp_err *err)
{
lisp_obj *callable = FORCE_VALUE(app->proc, env, err);
if (! callable){
return NULL;
}
lisp_obj *res = NIL;
/* Internal procedure */
if (callable->type == PROC){
/* Eval args */
lisp_obj **args = calloc(app->nparams, sizeof(lisp_obj*));
for (size_t i=0; i<app->nparams; i++){
lisp_obj *arg = FORCE_VALUE(app->params[i], env, err);
if (! arg){
for (size_t j=0; j<i; j++){
release(args[j]);
}
free(args);
return NULL;
}
args[i] = arg;
}
/* Eval internal */
res = callable->value.p(app->nparams, args);
/* Free args */
for (size_t i=0; i<app->nparams; i++){
release(args[i]);
}
free(args);
}
/* Lisp func */
else if (callable->type == LAMBDA){
lisp_lambda *lambda = &(callable->value.l);
lisp_expr_lambda *lambda_expr = &(lambda->declaration->value.mklambda);
/* Check arity */
if (app->nparams != lambda_expr->nparams){
raise_error(err, WRONG_ARITY, "Arity error ! Expected %d params, got %d",
lambda_expr->nparams, app->nparams);
return NULL;
}
/* Extend env */
lisp_env *locals = create_env(lambda->context);
for (size_t i=0; i<lambda_expr->nparams; i++){
lisp_obj *param = eval_expression(app->params[i], env, err);
if (! param){
release_env(locals);
return NULL;
}
DEBUG("Extend env with %s", lambda_expr->param_names[i]);
release(set_env(locals, lambda_expr->param_names[i], param));
}
if (enable_debug){
printf("\033[1mCALL\033[0m ");
dump_expr(lambda_expr->body);
printf(" with env\n");
dump_env(locals);
}
/* Wrap in thunk for trampoline */
res = make_thunk(lambda_expr->body, locals);
release_env(locals);
}
else {
lisp_print(callable);
raise_error(err, NOT_CALLABLE, "CANNOT CALL obj %p", callable);
return NULL;
}
release(callable);
return res;
}
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");
}
}
static void dump_variable(g95_expr *e) {
g95_ref *ref;
int i;
dumpf("var(%L,%p,[", &e->where, e->symbol);
for(ref=e->ref; ref; ref=ref->next) {
switch(ref->type) {
case REF_ARRAY:
switch(ref->u.ar.type) {
case AR_FULL:
dumpf("ar_full()");
break;
case AR_ELEMENT:
dumpf("ar_element([");
for(i=0; i<ref->u.ar.dimen; i++) {
dump_expr(ref->u.ar.start[i]);
if (i < ref->u.ar.dimen-1)
dump_char(',');
}
dumpf("])");
break;
case AR_SECTION:
dumpf("ar_section([");
for(i=0; i<ref->u.ar.dimen; i++) {
switch(ref->u.ar.dimen_type[i]) {
case DIMEN_ELEMENT:
case DIMEN_VECTOR:
dump_expr(ref->u.ar.start[i]);
break;
case DIMEN_RANGE:
dump_char('(');
dump_expr(ref->u.ar.start[i]);
dump_char(',');
dump_expr(ref->u.ar.end[i]);
dump_char(',');
dump_expr(ref->u.ar.stride[i]);
dump_char(')');
break;
default:
g95_internal_error("dump_variable(): Bad dimen");
}
if (i < ref->u.ar.dimen-1)
dump_char(',');
}
dumpf("])");
break;
default:
g95_internal_error("dump_variable(): Bad array ref");
}
break;
case REF_COARRAY:
dumpf("coarray([");
for(i=0; i<ref->u.car.dimen; i++) {
dump_expr(ref->u.car.element[i]);
dump_char(',');
}
dumpf("])");
break;
case REF_COMPONENT:
dumpf("component(%S)", ref->u.c.name);
break;
case REF_SUBSTRING:
dumpf("substring(");
dump_expr(ref->u.ss.start);
dump_char(',');
dump_expr(ref->u.ss.end);
dump_char(')');
break;
default:
g95_internal_error("dump_variable(): Bad ref");
}
if (ref->next != NULL)
dump_char(',');
}
dump_char(']');
dump_char(')');
}
void dump_decl(decl *d, dump *ctx, const char *desc)
{
const int is_func = !!type_is(d->ref, type_func);
type *ty;
if(!desc){
if(d->spel){
desc = is_func ? "function" : "variable";
}else{
desc = "type";
}
}
dump_desc_colour_newline(ctx, desc, d, &d->where,
maybe_colour(ctx->fout, col_desc_decl), 0);
if(d->proto)
dump_printf_indent(ctx, 0, " prev %p", (void *)d->proto);
if(d->spel)
dump_printf_indent(ctx, 0, " %s", d->spel);
dump_type(ctx, d->ref);
if(d->store)
dump_printf_indent(ctx, 0, " %s", decl_store_to_str(d->store));
dump_printf_indent(ctx, 0, "\n");
if(!is_func){
type *tof = type_skip_non_tdefs(d->ref);
if(tof->type == type_tdef && !tof->bits.tdef.decl){
/* show typeof expr */
dump_inc(ctx);
dump_expr(tof->bits.tdef.type_of, ctx);
dump_dec(ctx);
}
if(d->bits.var.field_width){
dump_inc(ctx);
dump_expr(d->bits.var.field_width, ctx);
dump_dec(ctx);
}
if(!d->spel){
dump_sue(ctx, d->ref);
}else if(d->bits.var.init.dinit){
dump_inc(ctx);
dump_init(ctx, d->bits.var.init.dinit);
dump_dec(ctx);
}
}
dump_inc(ctx);
dump_attributes(d->attr, ctx);
ty = type_skip_non_attr(d->ref);
if(ty && ty->type == type_attr)
dump_attributes(ty->bits.attr, ctx);
dump_dec(ctx);
if(is_func && d->bits.func.code){
funcargs *fa = type_funcargs(d->ref);
dump_inc(ctx);
dump_args(fa, ctx);
dump_stmt(d->bits.func.code, ctx);
dump_dec(ctx);
}
}
static void dump_expr_constituent(struct expr_constituent *c)
{
dump_op(fop_EXPR_CONSTITUENT);
dump_expr(c->expr);
}
