clist_t* clist_copy(clist_t *list) {
if (list == NULL) return NULL;
clist_t *copyList = new_clist();
cnode_t *node = NULL;
for (node = list->front; node != NULL; node = node->next) {
clist_push_back(copyList, node->data);
}
return copyList;
}
static clist make_clist(block_t heap, int count, va_list args)
{
clist first = NULL, *scan = &first;
while (count-- > 0)
{
*scan = new_clist(heap, va_arg(args, component), NULL);
scan = &(*scan)->next;
}
return first;
}
constant new_constant(block_t heap, enum constant_class vclass, ...)
{
va_list args;
constant newp = allocate(heap, sizeof *newp);
newp->vclass = vclass;
va_start(args, vclass);
switch (vclass)
{
case cst_int:
newp->u.integer = va_arg(args, int);
break;
case cst_string:
newp->u.string = va_arg(args, str_and_len_t);
break;
case cst_list:
{
cstlist clhead = newp->u.constants = va_arg(args, cstlist);
cstlist *clp = &newp->u.constants;
while (*clp && ((*clp)->cst == NULL
|| (*clp)->cst->vclass != cst_expression))
clp = &(*clp)->next;
cstlist cltail = *clp;
if (cltail == NULL)
break;
if (clp == &newp->u.constants)
{
/* the first expression is the list tail */
newp = clhead->cst;
cltail = cltail->next;
}
else if (clp == &newp->u.constants->next)
{
/* the first expression is the last element before the tail */
if (newp->u.constants->cst)
newp = newp->u.constants->cst;
else
newp->u.constants = NULL;
}
else
{
/* the first expression is here, so truncate the tail */
*clp = NULL;
}
build_heap = heap;
component l = new_component(heap, -1, c_constant, newp);
for (; cltail; cltail = cltail->next)
{
component c = new_component(heap, -1, c_constant, cltail->cst);
l = build_exec(build_recall(GEP "pcons"), 2, c, l);
}
newp = allocate(heap, sizeof *newp);
newp->vclass = cst_expression;
newp->u.expression = l;
break;
}
case cst_array: case cst_table:
{
newp->u.constants = va_arg(args, cstlist);
bool dynamic = false;
for (cstlist cl = newp->u.constants; cl; cl = cl->next)
if (cl->cst->vclass == cst_expression)
{
dynamic = true;
break;
}
if (!dynamic)
break;
build_heap = heap;
clist cargs = NULL;
for (cstlist cl = newp->u.constants; cl; cl = cl->next)
cargs = new_clist(heap, new_component(heap, -1, c_constant,
cl->cst),
cargs);
cargs = new_clist(heap, build_recall(GEP "sequence"), cargs);
component c = new_component(heap, 0, c_execute, cargs);
if (vclass == cst_table)
c = build_exec(build_recall(GEP "vector_to_ptable"), 1, c);
newp->vclass = cst_expression;
newp->u.expression = c;
break;
}
case cst_float:
newp->u.mudlle_float = va_arg(args, double);
break;
case cst_bigint:
newp->u.bigint_str = va_arg(args, const char *);
break;
case cst_symbol:
{
newp->u.constpair = va_arg(args, cstpair);
if (newp->u.constpair->cst1->vclass != cst_expression
&& newp->u.constpair->cst2->vclass != cst_expression)
break;
build_heap = heap;
component c = build_exec(build_recall(GEP "make_psymbol"), 2,
new_component(heap, -1, c_constant,
newp->u.constpair->cst1),
new_component(heap, -1, c_constant,
newp->u.constpair->cst2));
newp->vclass = cst_expression;
newp->u.expression = c;
break;
}
case cst_expression:
newp->u.expression = va_arg(args, component);
break;
default: abort();
}
va_end(args);
return newp;
}
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();
}
}
