void generate_for(component init, component condition, component next,
component iteration, const char *continue_label,
bool discard, fncode fn)
{
struct whiledata wdata;
env_block_push(NULL); /* init may have local declarations */
if (init)
generate_component(init, NULL, TRUE, fn);
start_block(NULL, FALSE, discard, fn);
wdata.continue_label = continue_label;
wdata.looplab = new_label(fn);
wdata.mainlab = new_label(fn);
wdata.endlab = new_label(fn);
wdata.code = iteration;
wdata.next = next;
set_label(wdata.looplab, fn);
if (condition)
{
generate_condition(condition, wdata.mainlab, wmain_code, &wdata,
wdata.endlab, NULL, NULL, fn);
set_label(wdata.endlab, fn);
if (!discard)
generate_component(component_undefined, NULL, FALSE, fn);
}
else
wmain_code(&wdata, fn);
end_block(fn);
env_block_pop();
}
static void loop_body(struct whiledata *wdata, fncode fn)
{
set_label(wdata->mainlab, fn);
start_block(NULL, TRUE, TRUE, fn);
if (wdata->continue_label)
start_block(wdata->continue_label, TRUE, TRUE, fn);
generate_component(wdata->code, NULL, TRUE, fn);
if (wdata->continue_label)
end_block(fn);
end_block(fn);
if (wdata->next)
generate_component(wdata->next, NULL, TRUE, fn);
}
void generate_condition(component condition,
label slab, gencode scode, void *sdata,
label flab, gencode fcode, void *fdata,
fncode fn)
{
struct andordata data;
switch (condition->vclass)
{
case c_builtin:
switch (condition->u.builtin.fn)
{
case b_sc_and: case b_sc_or:
{
component arg1 = condition->u.builtin.args->c;
data.arg2 = condition->u.builtin.args->next->c;
data.lab = new_label(fn);
data.slab = slab; data.scode = scode; data.sdata = sdata;
data.flab = flab; data.fcode = fcode; data.fdata = fdata;
if (condition->u.builtin.fn == b_sc_and)
generate_condition(arg1,
data.lab, andorcode, &data,
flab, NULL, NULL,
fn);
else
generate_condition(arg1,
slab, NULL, NULL,
data.lab, andorcode, &data,
fn);
return;
}
case b_not:
/* Just swap conclusions */
generate_condition(condition->u.builtin.args->c,
flab, fcode, fdata,
slab, scode, sdata,
fn);
return;
}
/* Fall through */
default:
generate_component(condition, NULL, FALSE, fn);
if (scode)
{
branch(OPmbf3, flab, fn);
scode(sdata, fn);
if (fcode) fcode(fdata, fn);
}
else
{
branch(OPmbt3, slab, fn);
if (fcode) fcode(fdata, fn);
else branch(OPmba3, flab, fn);
}
break;
}
}
static void wmain_code(void *_data, fncode fn)
{
struct whiledata *wdata = _data;
set_label(wdata->mainlab, fn);
generate_component(wdata->code, fn);
branch(op_loop1, wdata->looplab, fn);
}
static void iff_code(void *_data, fncode fn)
{
struct ifdata *data = _data;
set_label(data->flab, fn);
generate_component(data->failure, fn);
branch(op_branch1, data->endlab, fn);
adjust_depth(-1, fn);
}
static void wexit_code(void *_data, fncode fn)
{
struct whiledata *wdata = _data;
set_label(wdata->exitlab, fn);
generate_component(component_undefined, fn);
branch(op_branch1, wdata->endlab, fn);
adjust_depth(-1, fn);
}
static void iff_code(void *_data, fncode fn)
{
struct ifdata *data = _data;
set_label(data->flab, fn);
generate_component(data->failure, NULL, data->discard, fn);
branch(OPmba3, data->endlab, fn);
if (!data->discard)
adjust_depth(-1, fn);
}
void generate_args(clist args, fncode fn, u16 *_count)
{
u16 count = 0;
while (args)
{
count++;
generate_component(args->c, NULL, FALSE, fn);
args = args->next;
}
*_count = count;
}
static void generate_args(clist args, fncode fn, uword *_count)
{
uword count = 0;
while (args)
{
count++;
generate_component(args->c, fn);
args = args->next;
}
*_count = count;
}
static void generate_execute(component acall, int count, fncode fn)
{
/* Optimise main case: calling a given global function */
if (acall->vclass == c_recall)
{
ulong offset;
bool is_static;
variable_class vclass = env_lookup(acall->u.recall, &offset,
true, false, &is_static);
if (vclass == global_var)
{
assert(!is_static);
mexecute(offset, acall->u.recall, count, fn);
return;
}
}
generate_component(acall, fn);
ins1(op_execute, count, fn);
}
void generate_dowhile(component iteration, component condition,
const char *continue_label, bool discard, fncode fn)
{
struct whiledata wdata;
start_block(NULL, FALSE, discard, fn);
wdata.continue_label = continue_label;
wdata.looplab = new_label(fn);
wdata.mainlab = new_label(fn);
wdata.endlab = new_label(fn);
wdata.code = iteration;
wdata.next = NULL;
loop_body(&wdata, fn);
generate_condition(condition, wdata.mainlab, NULL, NULL,
wdata.endlab, NULL, NULL, fn);
set_label(wdata.endlab, fn);
if (!discard)
generate_component(component_undefined, NULL, FALSE, fn);
end_block(fn);
}
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);
}
}
void generate_execute(component acall, int count, fncode fn)
{
if (count >= 16)
log_error(acall->l, "no more than 15 arguments allowed");
/* Optimise main case: calling a given global function. Also
support implicit function declaration. */
if (acall->vclass == c_recall)
{
u16 offset;
mtype t;
variable_class vclass = env_lookup(acall->l, acall->u.recall, &offset, &t, TRUE);
if (vclass == global_var)
{
mexecute(acall->l, offset, acall->u.recall, count, fn);
return;
}
}
generate_component(acall, NULL, FALSE, fn);
ins0(OPmexec4 + (count & 0xf), fn);
}
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();
}
void generate_clist(clist cc, bool discard, fncode fn)
{
/* Generate code for sequence */
for (; cc; cc = cc->next)
generate_component(cc->c, NULL, discard || cc->next, 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_function(function f, fncode fn)
{
struct code *c;
struct string *help, *afilename, *varname;
fncode newfn;
vlist argument;
u16 clen;
i8 nargs;
u8 nb_locals, *cvars;
varlist closure, cvar;
/* Code strings must be allocated before code (immutability restriction) */
if (f->help)
help = alloc_string(f->help);
else
help = NULL;
GCPRO1(help);
/* Make variable name (if present) */
if (f->varname)
varname = alloc_string(f->varname);
else
varname = NULL;
GCPRO1(varname);
/* Make filename string */
afilename = make_filename(f->l.filename);
GCPRO1(afilename);
if (f->varargs)
/* varargs makes a vector from the first nargs entries of the stack and
stores it in local value 0 */
nargs = -1;
else
/* count the arguments */
for (nargs = 0, argument = f->args; argument; argument = argument->next)
nargs++;
newfn = new_fncode(fnglobals(fn), f->l, FALSE, nargs);
if (!f->varargs)
{
/* Generate code to check the argument types */
for (nargs = 0, argument = f->args; argument; argument = argument->next)
{
if (argument->type != stype_any)
ins1(OPmvcheck4 + argument->type, nargs, newfn);
nargs++;
}
}
/* Generate code of function */
env_push(f->args, newfn);
start_block("<return>", FALSE, FALSE, newfn);
generate_component(f->value, NULL, FALSE, newfn);
end_block(newfn);
if (f->type != stype_any) ins0(OPmscheck4 + f->type, newfn);
ins0(OPmreturn, newfn);
closure = env_pop(&nb_locals);
c = generate_fncode(newfn, nb_locals, help, varname, afilename, f->l.lineno);
/* Generate code for creating closure */
/* Count length of closure */
clen = 0;
for (cvar = closure; cvar; cvar = cvar->next) clen++;
/* Generate closure */
cvars = ins_closure(c, clen, fn);
/* Add variables to it */
for (cvar = closure; cvar; cvar = cvar->next)
*cvars++ = (cvar->offset << 1) + cvar->vclass;
delete_fncode(newfn);
GCPOP(3);
}
static struct icode *generate_function(function f, bool toplevel, fncode fn)
{
/* make help string; must be allocated before code (immutability
restriction) */
struct string *help = NULL;
if (f->help.len)
help = make_readonly(alloc_string_length(f->help.str, f->help.len));
struct string *varname = NULL, *filename = NULL, *nicename = NULL;
struct vector *arg_types = NULL;
GCPRO5(help, varname, filename, nicename, arg_types);
/* Make variable name (if present) */
if (f->varname)
varname = make_readonly(alloc_string(f->varname));
else
varname = NULL;
/* Make filename string */
filename = make_filename(f->filename);
nicename = make_filename(f->nicename);
arg_types = make_arg_types(f);
fncode newfn = new_fncode(toplevel);
set_lineno(f->lineno, newfn);
if (f->varargs)
/* varargs makes a vector from the first nargs entries of the stack and
stores it in local value 0 */
ins0(op_varargs, newfn);
else
{
/* First, generate code to check the argument types & count */
/* argcheck copies the arguments into the local variables, assuming that
the last argument (on top of the stack) is local value 0, the next to
last local value 1, and so on.
It then discards all the parameters */
int nargs = 0;
for (vlist argument = f->args; argument; argument = argument->next)
nargs++;
ins1(op_argcheck, nargs, newfn);
nargs = 0;
for (vlist argument = f->args; argument; argument = argument->next)
{
generate_typeset_check(argument->typeset, nargs, newfn);
nargs++;
}
ins1(op_pop_n, nargs, newfn);
}
/* Generate code of function */
env_push(f->args, newfn);
start_block("function", newfn);
generate_component(f->value, newfn);
end_block(newfn);
generate_typeset_check(f->typeset, 0, newfn);
ins0(op_return, newfn);
peephole(newfn);
struct icode *c = generate_fncode(
newfn, help, varname, filename, nicename, f->lineno, arg_types,
f->typeset, compile_level);
varlist closure = env_pop(&c->nb_locals);
UNGCPRO();
/* Generate code for creating closure */
/* Count length of closure */
int clen = 0;
for (varlist cvar = closure; cvar; cvar = cvar->next) clen++;
/* Generate closure */
ins1(op_closure, clen, fn);
/* Add variables to it */
for (varlist cvar = closure; cvar; cvar = cvar->next)
ins1(op_closure_var + cvar->vclass, cvar->offset, fn);
delete_fncode(newfn);
return c;
}
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);
}