static void generate_decls(vlist decls, fncode fn)
{
/* Generate code for initialisers */
for (; decls; decls = decls->next)
if (decls->init)
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(decls->l, decls->var, &offset, &t, FALSE);
generate_component(decls->init, NULL, FALSE, fn);
if (t != stype_any)
ins0(OPmscheck4 + t, fn);
if (vclass == global_var)
massign(decls->l, offset, decls->var, fn);
else
ins1(OPmwritel, offset, fn);
ins0(OPmpop, fn);
}
}
static void generate_component(component comp, fncode fn)
{
clist args;
set_lineno(comp->lineno, fn);
switch (comp->vclass)
{
case c_assign:
{
ulong offset;
bool is_static;
variable_class vclass = env_lookup(comp->u.assign.symbol, &offset,
false, true, &is_static);
component val = comp->u.assign.value;
if (val->vclass == c_closure)
{
/* Defining a function, give it a name */
if (vclass == global_var)
val->u.closure->varname = comp->u.assign.symbol;
else
{
char *varname = allocate(fnmemory(fn), strlen(comp->u.assign.symbol) + 7);
sprintf(varname, "local-%s", comp->u.assign.symbol);
val->u.closure->varname = varname;
}
}
if (is_static)
{
ins1(op_recall + vclass, offset, fn);
generate_component(comp->u.assign.value, fn);
mexecute(g_symbol_set, NULL, 2, fn);
break;
}
generate_component(comp->u.assign.value, fn);
set_lineno(comp->lineno, fn);
if (vclass == global_var)
massign(offset, comp->u.assign.symbol, fn);
else
ins1(op_assign + vclass, offset, fn);
/* Note: varname becomes a dangling pointer when fnmemory(fn) is
deallocated, but it is never used again so this does not cause
a problem. */
break;
}
case c_vref:
case c_recall:
{
bool is_vref = comp->vclass == c_vref;
ulong offset;
bool is_static;
variable_class vclass = env_lookup(comp->u.recall, &offset,
true, is_vref, &is_static);
if (is_static)
{
assert(vclass != global_var);
ins1(op_recall + vclass, offset, fn);
ulong gidx = is_vref ? g_make_symbol_ref : g_symbol_get;
mexecute(gidx, NULL, 1, fn);
break;
}
if (vclass != global_var)
ins1((is_vref ? op_vref : op_recall) + vclass, offset, fn);
else if (is_vref)
{
if (!mwritable(offset, comp->u.recall))
return;
ins_constant(makeint(offset), fn);
}
else
mrecall(offset, comp->u.recall, fn);
if (is_vref)
mexecute(g_make_variable_ref, "make_variable_ref", 1, fn);
break;
}
case c_constant:
ins_constant(make_constant(comp->u.cst), fn);
break;
case c_closure:
{
uword idx;
idx = add_constant(generate_function(comp->u.closure, false, fn), fn);
if (idx < ARG1_MAX) ins1(op_closure_code1, idx, fn);
else ins2(op_closure_code2, idx, fn);
break;
}
case c_block:
generate_block(comp->u.blk, fn);
break;
case c_labeled:
start_block(comp->u.labeled.name, fn);
generate_component(comp->u.labeled.expression, fn);
end_block(fn);
break;
case c_exit:
generate_component(comp->u.labeled.expression, fn);
if (!exit_block(comp->u.labeled.name, fn)) {
if (!comp->u.labeled.name)
log_error("no loop to exit from");
else
log_error("no block labeled %s", comp->u.labeled.name);
}
break;
case c_execute:
{
uword count;
generate_args(comp->u.execute->next, fn, &count);
set_lineno(comp->lineno, fn);
generate_execute(comp->u.execute->c, count, fn);
break;
}
case c_builtin:
args = comp->u.builtin.args;
switch (comp->u.builtin.fn)
{
case b_if: {
block cb = new_codeblock(fnmemory(fn), NULL,
new_clist(fnmemory(fn), args->next->c,
new_clist(fnmemory(fn),
component_undefined,
NULL)),
NULL, NULL, -1);
generate_if(args->c, new_component(fnmemory(fn),
args->next->c->lineno,
c_block, cb),
component_undefined, fn);
break;
}
case b_ifelse:
generate_if(args->c, args->next->c, args->next->next->c, fn);
break;
case b_sc_and: case b_sc_or:
generate_if(comp, component_true, component_false, fn);
break;
case b_while:
generate_while(args->c, args->next->c, fn);
break;
case b_loop:
{
label loop = new_label(fn);
env_start_loop();
set_label(loop, fn);
start_block(NULL, fn);
generate_component(args->c, fn);
branch(op_loop1, loop, fn);
end_block(fn);
env_end_loop();
adjust_depth(1, fn);
break;
}
case b_add: case b_subtract:
case b_ref: case b_set:
case b_bitor: case b_bitand:
case b_not:
case b_eq: case b_ne:
case b_lt: case b_le: case b_ge: case b_gt:
{
uword count;
assert(comp->u.builtin.fn < last_builtin);
generate_args(args, fn, &count);
set_lineno(comp->lineno, fn);
ins0(builtin_ops[comp->u.builtin.fn], fn);
break;
}
default:
{
uword count;
assert(comp->u.builtin.fn < last_builtin);
generate_args(args, fn, &count);
set_lineno(comp->lineno, fn);
mexecute(builtin_functions[comp->u.builtin.fn], NULL, count, fn);
break;
}
}
break;
default: abort();
}
}
void generate_component(component comp, const char *mlabel, bool discard, fncode fn)
{
clist args;
switch (comp->vclass)
{
case c_assign:
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(comp->l, comp->u.assign.symbol, &offset, &t, FALSE);
component val = comp->u.assign.value;
if (val->vclass == c_closure)
{
/* Defining a function, give it a name */
if (vclass == global_var)
val->u.closure->varname = comp->u.assign.symbol;
else
{
char *varname = allocate(fnmemory(fn), strlen(comp->u.assign.symbol) + 7);
sprintf(varname, "local-%s", comp->u.assign.symbol);
val->u.closure->varname = varname;
}
}
generate_component(comp->u.assign.value, NULL, FALSE, fn);
if (t != stype_any)
ins0(OPmscheck4 + t, fn);
if (vclass == global_var)
massign(comp->l, offset, comp->u.assign.symbol, fn);
else if (vclass == closure_var)
ins1(OPmwritec, offset, fn);
else
ins1(OPmwritel, offset, fn);
/* Note: varname becomes a dangling pointer when fnmemory(fn) is
deallocated, but it is never used again so this does not cause
a problem. */
break;
}
case c_recall:
scompile_recall(comp->l, comp->u.recall, fn);
break;
case c_constant:
ins_constant(make_constant(comp->u.cst, FALSE, fn), fn);
break;
case c_scheme:
scheme_compile_mgc(comp->l, make_constant(comp->u.cst, TRUE, fn), discard, fn);
discard = FALSE;
break;
case c_closure:
generate_function(comp->u.closure, fn);
break;
case c_block:
generate_block(comp->u.blk, discard, fn);
discard = FALSE;
break;
case c_decl:
{
vlist decl, next;
/* declare variables one at a time (any x = y, y = 2; is an error) */
for (decl = comp->u.decls; decl; decl = next)
{
next = decl->next;
decl->next = NULL;
env_declare(decl);
generate_decls(decl, fn);
}
generate_component(component_undefined, NULL, FALSE, fn);
break;
}
case c_labeled: {
start_block(comp->u.labeled.name, FALSE, discard, fn);
generate_component(comp->u.labeled.expression, comp->u.labeled.name, discard, fn);
end_block(fn);
discard = FALSE;
break;
}
case c_exit:
{
bool discard_exit;
label exitlab = exit_block(comp->u.labeled.name, FALSE, &discard_exit, fn);
if (comp->u.labeled.expression != component_undefined && discard_exit)
warning(comp->l, "break result is ignored");
generate_component(comp->u.labeled.expression, NULL, discard_exit, fn);
if (exitlab)
branch(OPmba3, exitlab, fn);
else
{
if (!comp->u.labeled.name)
log_error(comp->l, "No loop to exit from");
else
log_error(comp->l, "No block labeled %s", comp->u.labeled.name);
}
/* Callers expect generate_component to increase stack depth by 1 */
if (discard_exit)
adjust_depth(1, fn);
break;
}
case c_continue:
{
bool discard_exit; /* Meaningless for continue blocks */
label exitlab = exit_block(comp->u.labeled.name, TRUE, &discard_exit, fn);
if (exitlab)
branch(OPmba3, exitlab, fn);
else
{
if (comp->u.labeled.name[0] == '<')
log_error(comp->l, "No loop to continue");
else
log_error(comp->l, "No loop labeled %s", comp->u.labeled.name);
}
/* Callers expect generate_component to increase stack depth by 1 (*/
adjust_depth(1, fn);
break;
}
case c_execute:
{
u16 count;
generate_args(comp->u.execute->next, fn, &count);
generate_execute(comp->u.execute->c, count, fn);
break;
}
case c_builtin:
args = comp->u.builtin.args;
switch (comp->u.builtin.fn)
{
case b_if:
generate_if(args->c, args->next->c, NULL, TRUE, fn);
generate_component(component_undefined, NULL, FALSE, fn);
break;
case b_ifelse:
generate_if(args->c, args->next->c, args->next->next->c, discard, fn);
discard = FALSE;
break;
case b_sc_and: case b_sc_or:
generate_if(comp, component_true, component_false, discard, fn);
discard = FALSE;
break;
case b_while:
enter_loop(fn);
generate_while(args->c, args->next->c, mlabel, discard, fn);
exit_loop(fn);
discard = FALSE;
break;
case b_dowhile:
enter_loop(fn);
generate_dowhile(args->c, args->next->c, mlabel, discard, fn);
exit_loop(fn);
discard = FALSE;
break;
case b_for:
enter_loop(fn);
generate_for(args->c, args->next->c, args->next->next->c,
args->next->next->next->c, mlabel, discard, fn);
exit_loop(fn);
discard = FALSE;
break;
default:
{
u16 count;
assert(comp->u.builtin.fn < last_builtin);
generate_args(args, fn, &count);
ins0(builtin_ops[comp->u.builtin.fn], fn);
break;
}
case b_cons:
{
u16 count;
u16 goffset;
mtype t;
assert(comp->u.builtin.fn < last_builtin);
generate_args(args, fn, &count);
goffset = global_lookup(fnglobals(fn),
builtin_functions[comp->u.builtin.fn], &t);
mexecute(comp->l, goffset, NULL, count, fn);
break;
}
}
break;
default: assert(0);
}
if (discard)
ins0(OPmpop, fn);
}
