static struct closure *compile_code(struct global_state *gstate, clist b)
{
struct code *cc;
u8 nb_locals;
fncode top;
location topl;
struct string *afilename;
/* Code strings must be allocated before code (immutability restriction) */
afilename = make_filename(lexloc.filename);
GCPRO1(afilename);
erred = FALSE;
env_reset();
topl.filename = NULL;
topl.lineno = 0;
top = new_fncode(gstate, topl, TRUE, 0);
env_push(NULL, top); /* Environment must not be totally empty */
generate_clist(b, FALSE, top);
ins0(OPmreturn, top);
env_pop(&nb_locals);
cc = generate_fncode(top, nb_locals, NULL, NULL, afilename, 0);
delete_fncode(top);
GCPOP(1);
if (erred) return NULL;
else return alloc_closure0(cc);
}
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_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);
}
