static void continue_prepare(struct compile_and_run_frame *frame)
{
value closure;
struct global_state *gcopy;
if (mprepare_load_next_start(&frame->ps))
return;
mprepare_vars(&frame->ps);
gcopy = copy_global_state(frame->ps.ccontext->gstate);
GCPRO1(gcopy);
closure = compile_code(frame->ps.ccontext->gstate, frame->f->body);
GCPOP(1);
if (closure)
{
GCPRO1(closure);
if (debug_lvl > 1)
output_value(muderr, prt_examine, closure);
frame->state = running;
if (frame->dontrun)
{
/* Just leave the closure itself as the result */
stack_reserve(sizeof(value));
stack_push(closure);
}
else
push_closure(closure, 0);
GCPOP(1);
return;
}
global_set(frame->ps.ccontext->gstate, gcopy);
runtime_error(error_compile_error);
}
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 value make_list(constant loc, cstlist csts, int has_tail, bool save_location, fncode fn)
{
struct list *l;
if (has_tail && csts != NULL)
{
l = csts->cst ? make_constant(csts->cst, FALSE, fn) : NULL;
csts = csts->next;
}
else
l = NULL;
GCPRO1(l);
/* Remember that csts is in reverse order ... */
while (csts)
{
value tmp = make_constant(csts->cst, save_location, fn);
l = alloc_list(tmp, l);
SET_READONLY(l); SET_IMMUTABLE(l);
csts = csts->next;
}
if (save_location)
{
value vloc = make_location(&loc->loc);
l = alloc_list(vloc, l);
SET_READONLY(l); SET_IMMUTABLE(l);
}
GCPOP(1);
return l;
}
static u16 global_add(struct global_state *gstate,
struct string *name, value val)
{
struct symbol *pos;
ivalue old_size, aindex;
GCCHECK(val);
GCPRO2(gstate, name);
old_size = vector_len(gstate->environment->values);
aindex = env_add_entry(gstate->environment, val);
if (vector_len(gstate->environment->values) != old_size) /* Increase mvars too */
{
struct vector *new_mvars = alloc_vector(vector_len(gstate->environment->values));
memcpy(new_mvars->data, gstate->mvars->data,
gstate->mvars->o.size - sizeof(struct obj));
gstate->mvars = new_mvars;
}
GCPOP(2);
gstate->mvars->data[aindex] = makeint(var_normal);
pos = table_add_fast(gstate->global, name, makeint(aindex));
SET_READONLY(pos); /* index of global vars never changes */
return aindex;
}
void delete_fncode(fncode fn)
/* Effects: deletes fncode 'fn'
*/
{
GCPOP(1);
POP_LIST(fn->cstpro);
free_block(fn->fnmemory);
}
static void pcst(struct oport *f, instruction *i, char *insname)
{
value cst = RINSCST(i);
GCPRO1(cst);
pprintf(f, insname);
GCPOP(1);
_print_value(f, prt_examine, cst, 0);
pprintf(f, "\n");
}
struct string *copy_string(struct string *s)
{
struct string *newp;
uvalue size = string_len(s);
GCPRO1(s);
newp = alloc_string_n(size);
memcpy(newp->str, s->str, size * sizeof(*s->str));
GCPOP(1);
return newp;
}
struct vector *copy_vector(struct vector *v)
{
struct vector *newp;
uvalue size = vector_len(v);
GCPRO1(v);
newp = alloc_vector(size);
memcpy(newp->data, v->data, size * sizeof(*v->data));
GCPOP(1);
return newp;
}
static value make_symbol(cstpair p, fncode fn)
{
struct symbol *sym;
struct string *s = alloc_string(p->cst1->u.string);
GCPRO1(s);
SET_IMMUTABLE(s); SET_READONLY(s);
sym = alloc_symbol(s, make_constant(p->cst2, FALSE, fn));
SET_IMMUTABLE(sym); SET_READONLY(sym);
GCPOP(1);
return sym;
}
struct closure *alloc_closure0(struct code *code)
{
struct closure *newp;
GCCHECK(code);
GCPRO1(code);
newp = (struct closure *)allocate_record(type_function, 1);
GCPOP(1);
newp->code = code;
SET_READONLY(newp);
return newp;
}
CC compile_and_run(block_t region,
struct global_state *gstate,
const char *nicename, u8 *noreload,
bool dontrun)
{
struct compile_and_run_frame *frame;
struct compile_context *ccontext;
GCPRO1(gstate);
frame = push_frame(compile_and_run_action, sizeof(struct compile_and_run_frame));
ccontext = (struct compile_context *)allocate_record(type_vector, 2);
frame->dontrun = dontrun;
frame->ps.ccontext = ccontext;
ccontext->gstate = gstate;
/* no evaluation_state yet */
GCPOP(1);
frame->state = init;
if (!region)
region = new_block();
frame->parser_block = region;
/* Set filename */
lexloc.filename = bstrdup(region, nicename);
normal_lexing();
if ((frame->f = parse(frame->parser_block)))
{
if (noreload)
{
if (frame->f->name &&
module_status(frame->ps.ccontext->gstate, frame->f->name) != module_unloaded)
{
free_block(frame->parser_block);
*noreload = TRUE;
FA_POP(&fp, &sp);
return;
}
*noreload = FALSE;
}
if (mprepare(&frame->ps, frame->parser_block, frame->f))
{
frame->state = preparing;
continue_prepare(frame);
return;
}
}
runtime_error(error_compile_error);
}
struct list *alloc_list(value car, value cdr)
{
struct list *newp;
GCCHECK(car);
GCCHECK(cdr);
GCPRO2(car, cdr);
newp = (struct list *)unsafe_allocate_record(type_pair, 2);
GCPOP(2);
newp->car = car;
newp->cdr = cdr;
return newp;
}
static value make_table(cstlist csts, fncode fn)
{
struct table *t = alloc_table(DEF_TABLE_SIZE);
GCPRO1(t);
for (; csts; csts = csts->next)
table_set(t, csts->cst->u.constpair->cst1->u.string,
make_constant(csts->cst->u.constpair->cst2, FALSE, fn), NULL);
table_foreach(t, protect_symbol);
SET_READONLY(t);
GCPOP(1);
return t;
}
static void make_global_state(int argc, const char **argv)
{
struct machine_specification *this_machine =
(struct machine_specification *)allocate_record(type_vector, 4);
struct extptr *tms;
GCPRO1(this_machine);
tms = alloc_extptr(&this_machine_specification);
GCPOP(1);
this_machine->c_machine_specification = tms;
globals = new_global_state(this_machine);
staticpro((value *)&globals);
runtime_setup(globals, argc, argv);
}
struct closure *unsafe_alloc_and_push_closure(u8 nb_variables)
{
/* This could (should?) be optimised to avoid the need for
GCPRO1/stack_reserve/GCPOP */
struct closure *newp = (struct closure *)unsafe_allocate_record(type_function, nb_variables + 1);
SET_READONLY(newp);
GCPRO1(newp);
stack_reserve(sizeof(value));
GCPOP(1);
stack_push(newp);
return newp;
}
struct symbol *alloc_symbol(struct string *name, value data)
{
struct symbol *newp;
GCCHECK(name);
GCCHECK(data);
GCPRO2(name, data);
newp = (struct symbol *)unsafe_allocate_record(type_symbol, 2);
GCPOP(2);
newp->name = name;
newp->data = data;
return newp;
}
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;
}
struct global_state *new_global_state(struct machine_specification *machine)
/* Returns: A new global state for a motlle interpreter for machine
*/
{
struct global_state *gstate;
GCPRO1(machine);
gstate = (struct global_state *)allocate_record(type_vector, 5);
GCPRO1(gstate);
gstate->modules = alloc_table(DEF_TABLE_SIZE);
gstate->mvars = alloc_vector(GLOBAL_SIZE);
gstate->global = alloc_table(GLOBAL_SIZE);
gstate->environment = alloc_env(GLOBAL_SIZE);
gstate->machine = machine;
GCPOP(2);
return gstate;
}
u16 global_lookup(struct global_state *gstate, const char *name)
/* Returns: the index for global variable name in environment.
If name doesn't exist yet, it is created with a variable
whose value is NULL.
*/
{
struct symbol *pos;
struct string *tname;
if (table_lookup(gstate->global, name, &pos))
return (u16)intval(pos->data);
GCPRO1(gstate);
tname = alloc_string(name);
GCPOP(1);
return global_add(gstate, tname, NULL);
}
static void write_string(struct oport *p, prt_level level, struct string *print)
{
uvalue l = string_len(print);
if (level == prt_display)
pswrite(p, print, 0, l);
else
{
unsigned char *str = (unsigned char *)alloca(l + 1);
unsigned char *endstr;
memcpy((char *)str, print->str, l + 1);
GCPRO1(p);
/* The NULL byte at the end doesn't count */
endstr = str + l;
pputc('"', p);
while (str < endstr)
{
unsigned char *pos = str;
while (pos < endstr && writable(*pos)) pos++;
opwrite(p, (char *)str, pos - str);
if (pos < endstr) /* We stopped for a \ */
{
pputc('\\', p);
switch (*pos)
{
case '\\': case '"': pputc(*pos, p); break;
case '\n': pputc('n', p); break;
case '\r': pputc('r', p); break;
case '\t': pputc('t', p); break;
case '\f': pputc('f', p); break;
default: pprintf(p, "%o", *pos); break;
}
str = pos + 1;
}
else str = pos;
}
pputc('"', p);
GCPOP(1);
}
}
u16 mglobal_lookup(struct global_state *gstate, struct string *name)
/* Returns: the index for global variable name in environment.
If name doesn't exist yet, it is created with a variable
whose value is NULL.
*/
{
struct symbol *pos;
struct string *tname;
if (table_lookup(gstate->global, name->str, &pos))
return (u16)intval(pos->data);
GCPRO2(gstate, name);
tname = alloc_string_n(string_len(name));
strcpy(tname->str, name->str);
GCPOP(2);
return global_add(gstate, tname, NULL);
}
static value make_quote(constant c, bool save_location, fncode fn)
{
struct list *l;
value quote;
l = alloc_list(make_constant(c->u.constant, save_location, fn), NULL);
SET_READONLY(l); SET_IMMUTABLE(l);
GCPRO1(l);
quote = make_gsymbol("quote", fn);
l = alloc_list(quote, l);
SET_READONLY(l); SET_IMMUTABLE(l);
if (save_location)
{
value loc = make_location(&c->loc);
l = alloc_list(loc, l);
SET_READONLY(l); SET_IMMUTABLE(l);
}
GCPOP(1);
return l;
}
static value make_array(cstlist csts, fncode fn)
{
struct list *l;
struct vector *v;
uvalue size = 0, i;
cstlist scan;
for (scan = csts; scan; scan = scan->next) size++;
/* This intermediate step is necessary as v is IMMUTABLE
(so must be allocated after its contents) */
l = make_list(NULL, csts, 0, FALSE, fn);
GCPRO1(l);
v = alloc_vector(size);
SET_IMMUTABLE(v); SET_READONLY(v);
GCPOP(1);
for (i = 0; i < size; i++, l = l->cdr) v->data[i] = l->car;
return v;
}
static void write_code(struct oport *f, struct code *c)
{
u16 nbins, i;
GCPRO2(f, c);
nbins = code_length(c);
if (c->varname)
{
write_string(f, prt_display, c->varname);
pputs(": ", f);
}
pprintf(f, "Code[");
write_string(f, prt_display, c->filename);
pprintf(f, ":%u] %u bytes:\n", c->lineno, nbins);
i = 0;
while (i < nbins)
i += write_instruction(f, c->ins + i, i);
pprintf(f, "\n%u locals, %u stack\n",
c->nb_locals, c->stkdepth);
GCPOP(2);
}
u16 global_add(struct global_state *gstate, const char *name, mtype t)
/* Effects: adds name to global environment gstate, along with its type (t)
If variable already exists, change its type to t.
Returns: the new variable's index
Modifies: gstate
*/
{
struct string *tname;
mtype current_type;
u16 pos = global_lookup(gstate, name, ¤t_type);
if (pos != GLOBAL_INVALID)
{
gstate->types->data[pos] = makeint(t);
return pos;
}
GCPRO1(gstate);
tname = alloc_string(name);
GCPOP(1);
return global_add1(gstate, tname, t, NULL);
}
struct global_state *copy_global_state(struct global_state *gstate)
/* Returns: A copy of global state gstate, which includes copying
global variable and module state
*/
{
struct global_state *newp;
value tmp;
GCPRO1(gstate);
newp = (struct global_state *)allocate_record(type_vector, 8);
GCPRO1(newp);
tmp = copy_table(gstate->modules); newp->modules = tmp;
tmp = copy_vector(gstate->mvars); newp->mvars = tmp;
tmp = copy_vector(gstate->types); newp->types = tmp;
tmp = copy_vector(gstate->names); newp->names = tmp;
tmp = copy_table(gstate->global); newp->global = tmp;
tmp = copy_table(gstate->gsymbols); newp->gsymbols = tmp;
tmp = copy_env(gstate->environment); newp->environment = tmp;
newp->machine = gstate->machine;
GCPOP(2);
return newp;
}
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);
}
