void mexecute(u16 n, const char *name, int count, fncode fn)
/* Effects: Generates code to call function in variable n, with count
arguments
*/
{
struct string *mod;
int status = module_vstatus(fnglobals(fn), 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(fnglobals(fn), mod->str) != module_protected &&
!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);
}
if (count == 1)
ins2(op_execute_global1, n, fn);
else if (count == 2)
ins2(op_execute_global2, n, fn);
else
{
/* Could have an op_execute_global */
ins2(op_recall + global_var, n, fn);
ins1(op_execute, count, fn);
}
}
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);
}
void massign(u16 n, const char *name, fncode fn)
/* Effects: Generate code to assign to variable n
*/
{
struct string *mod;
int status = module_vstatus(fnglobals(fn), n, &mod);
if (status == var_module)
if (mod == this_module && fntoplevel(fn))
/* defined here */
ins2(op_define, n, fn);
else
log_error("write of global %s (module %s)", name, mod->str);
else if (all_writable || in_glist(n, writable))
{
ins2(op_assign + global_var, n, fn);
if (status != var_write)
module_vset(fnglobals(fn), n, var_write, NULL);
}
else
log_error("write of global %s", name);
}
static value make_gsymbol(const char *name, fncode fn)
{
struct table *gsymbols = (fn ? fnglobals(fn) : globals)->gsymbols;
struct symbol *gsym;
if (!table_lookup(gsymbols, name, &gsym))
{
struct string *s;
GCPRO1(gsymbols);
s = alloc_string(name);
SET_READONLY(s);
GCPOP(1);
gsym = table_add_fast(gsymbols, s, makeint(table_entries(gsymbols)));
}
return gsym;
}
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);
}
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);
}
