void mrecall(u16 n, const char *name, fncode fn)
/* Effects: Generate code to recall variable n
*/
{
struct string *mod;
struct global_state *gstate = fnglobals(fn);
int status = module_vstatus(gstate, n, &mod);
if (!in_glist(n, definable) &&
!in_glist(n, readable) && !in_glist(n, writable)) {
if (status == var_module)
{
/* Implicitly import protected modules */
if (module_status(gstate, mod->str) == module_protected)
{
if (immutablep(GVAR(gstate, n))) /* Use value */
{
ins_constant(GVAR(gstate, n), fn);
return;
}
}
else if (!all_readable && imported(mod->str) == module_unloaded)
log_error("read of global %s (module %s)", name, mod->str);
}
else if (!all_readable)
log_error("read of global %s", name);
}
ins2(op_recall + global_var, n, fn);
}
static void generate_typeset_check(unsigned typeset, unsigned arg,
fncode newfn)
{
if (typeset == TYPESET_ANY)
return;
mtype t;
if (typeset == TYPESET_FUNCTION)
t = stype_function;
else if (typeset == TYPESET_LIST)
t = stype_list;
else if (typeset == 0)
t = stype_none;
else if ((typeset & (typeset - 1)) == 0)
t = ffs(typeset) - 1;
else
{
ins_constant(makeint(typeset), newfn);
ins1(op_typeset_check, arg, newfn);
return;
}
ins1(op_typecheck + t, arg, newfn);
}
static void generate_block(block b, fncode fn)
{
clist cc = b->sequence;
env_block_push(b->locals, b->statics);
if (b->statics)
for (vlist vl = b->locals; vl; vl = vl->next)
{
ulong offset;
bool is_static;
variable_class vclass = env_lookup(vl->var, &offset,
false, true, &is_static);
assert(is_static && vclass == local_var);
ins_constant(alloc_string(vl->var), fn);
mexecute(g_get_static, NULL, 1, fn);
ins1(op_assign + vclass, offset, fn);
}
/* Generate code for sequence */
for (; cc; cc = cc->next)
{
generate_component(cc->c, fn);
if (cc->next) ins0(op_discard, fn);
}
for (vlist vl = b->locals; vl; vl = vl->next)
if (!vl->was_written)
if (!vl->was_read)
warning_line(b->filename, b->nicename, vl->lineno,
"local variable %s is unused", vl->var);
else
warning_line(b->filename, b->nicename, vl->lineno,
"local variable %s is never written", vl->var);
else if (!vl->was_read)
warning_line(b->filename, b->nicename, vl->lineno,
"local variable %s is never read", vl->var);
env_block_pop();
}
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);
}
