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 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;
}
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;
}
struct string *make_filename(const char *fname)
{
if (strcmp(fname, last_c_filename))
{
free((void *)last_c_filename);
last_c_filename = xstrdup(fname);
last_filename = alloc_string(fname);
SET_READONLY(last_filename);
}
return last_filename;
}
void mprepare_vars(struct mprepare_state *s)
{
mfile f = s->f;
block_t heap = s->heap;
vlist reads, writes, defines;
imported_modules = s->lmodules;
all_writable = f->vclass == f_plain;
all_readable = f->vclass == f_plain || !s->all_loaded;
readable = writable = definable = NULL;
if (f->name)
{
this_module = alloc_string(f->name);
SET_READONLY(this_module);
}
else
this_module = NULL;
/* Change status of variables */
for (defines = f->defines; defines; defines = defines->next)
{
u16 n = global_lookup(s->ccontext->gstate, defines->var);
struct string *omod;
int ostatus = module_vstatus(s->ccontext->gstate, n, &omod);
if (!module_vset(s->ccontext->gstate, n, var_module, this_module))
log_error("cannot define %s: belongs to module %s", defines->var, omod->str);
else if (ostatus == var_write)
warning("%s was writable", defines->var);
definable = new_glist(heap, n, definable);
}
for (writes = f->writes; writes; writes = writes->next)
{
u16 n = global_lookup(s->ccontext->gstate, writes->var);
if (!module_vset(s->ccontext->gstate, n, var_write, NULL))
{
struct string *belongs;
module_vstatus(s->ccontext->gstate, n, &belongs);
log_error("cannot write %s: belongs to module %s", writes->var, belongs->str);
}
writable = new_glist(heap, n, writable);
}
for (reads = f->reads; reads; reads = reads->next)
readable = new_glist(heap, global_lookup(s->ccontext->gstate, reads->var),
readable);
}
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;
}
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;
}
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;
}
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 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;
}
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;
}
value make_constant(constant c, bool save_location, fncode fn)
{
struct obj *cst;
switch (c->vclass)
{
case cst_string:
cst = (value)alloc_string(c->u.string);
SET_READONLY(cst); SET_IMMUTABLE(cst);
return cst;
case cst_gsymbol: return make_gsymbol(c->u.string, fn);
case cst_quote: return make_quote(c, save_location, fn);
case cst_list: return make_list(c, c->u.constants, 1, save_location, fn);
case cst_array: return make_array(c->u.constants, fn);
case cst_int: return makeint(c->u.integer);
case cst_float: return alloc_mudlle_float(c->u.mudlle_float);
case cst_table: return make_table(c->u.constants, fn);
case cst_symbol: return make_symbol(c->u.constpair, fn);
default:
abort();
}
}
static void protect_symbol(struct symbol *s)
{
SET_READONLY(v);
}
