/*
* Transform
*
* (case-lambda
* ((<form1> <body1>)
* (<form2> <body2>)
* ...)
*
* to
*
* (lambda args
* (cond
* (((if (variadic? <form1>) >= =) (length args) <form1-min-args>)
* (apply (lambda (<form1>) <body1>) args))
* ...))
*/
cons_t* proc_case_lambda(cons_t* p, environment_t* e)
{
cons_t *cond_cases = list();
cons_t *cases = p;
for ( cons_t* c = cases; !nullp(c); c = cdr(c) ) {
cons_t *formals = caar(c);
cons_t *body = cdar(c);
// ((if (variadic? <form1>) >= =) argc <form1-min-args>)
cons_t* cond_if =
cons(symbol(variadicp(formals)? ">=" : "="),
cons(cons(symbol("length"), cons(symbol("args"))),
cons(integer(min_args(formals)))));
// (apply (lambda (<form1>) <body1>) args)
cons_t *cond_then =
cons(symbol("apply"),
cons(cons(symbol("lambda"),
cons(formals, body)),
cons(symbol("args"))));
cond_cases = append(cond_cases, list(list(cond_if, cond_then)));
}
cond_cases = splice(cons(symbol("cond")), cond_cases);
return make_closure(symbol("args"), cons(cond_cases), e);
}
int
main(void) {
(void)box_float;
(void)box_double;
(void)box_string;
/*Allocate an environment
* The environment size depends on how many nested functions there are ?
*/
svalue_t **env = calloc(sizeof (svalue_t *), 2);
/* Get the final closure */
svalue_t *closure1 = make_closure(make_doubleadder, env);
/* Invoke the closure that the closure returns */
svalue_t *c1 = invoke1(closure1, box_int(23));
svalue_t *c2 = invoke1(c1, box_int(5));
svalue_t *result = invoke1(c2, box_int(334));
/* The final result */
printf("print 23 + 5 + 334 == %d\n", result->value.integer);
svalue_t *a = box_int(123);
svalue_t *b = box_int(455);
svalue_t *improper = box_pair(a, b);
improper->value.pair.right = improper;
/* woo cyclic pair */
printf("(%d, %d)\n", improper->value.pair.left->value.integer, improper->value.pair.right->value.pair.left->value.integer);
return 0;
}
sexp call_lambda_as_ffi_closure(sexp lambda,sexp arg){
void **closure;
closure=make_closure(lambda,env_sexp(cur_env_ptr),1);
if(!closure){
return error_sexp("error constructing ffi_closure");
}
sexp(*f)(sexp)=(sexp(*)(sexp))(closure[0]);
sexp retval=f(arg);
return retval;
}
static void
cljc_init (void)
{
GC_INIT ();
PTABLE_NAME (cljc_DOT_core_SLASH_Nil) = alloc_ptable (TYPE_Nil);
PTABLE_NAME (cljc_DOT_core_SLASH_Integer) = alloc_ptable (TYPE_Integer);
PTABLE_NAME (cljc_DOT_core_SLASH_Boolean) = alloc_ptable (TYPE_Boolean);
PTABLE_NAME (cljc_DOT_core_SLASH_Array) = alloc_ptable (TYPE_Array);
PTABLE_NAME (cljc_DOT_core_SLASH_Character) = alloc_ptable (TYPE_Character);
PTABLE_NAME (cljc_DOT_core_SLASH_String) = alloc_ptable (TYPE_String);
value_nil = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Nil), sizeof (value_t));
value_true = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Boolean), sizeof (value_t));
value_false = alloc_value (PTABLE_NAME (cljc_DOT_core_SLASH_Boolean), sizeof (value_t));
VAR_NAME (cljc_DOT_core_SLASH_print) = make_closure (cljc_core_print, NULL);
VAR_NAME (cljc_DOT_core_SLASH_apply) = make_closure (cljc_core_apply, NULL);
}
void execute(Chunk *chunk) {
Closure *closure = make_closure(chunk);
Frame *frame = make_frame(NULL, closure);
VM *vm = make_vm(frame, 0);
execute_function(vm);
gc(vm);
free(vm);
// TODO - free last closure [?]
// Other closrues should be already taken care of
// by the last gc sweep, but this one existed outside
// of the heap.
}
void funcXXX(struct vm *vm){
ENTER_CLOSURE(1,"funcXXX");
vm->value = make_number(3);
PUSH(vm->value);
value = SHALLOW_ARGUMENT_REF(0);
vm->func = vm->value;
vm->value = make_vector(1);
CLOSURE_CALL()
vector_set(vm->value,0,POP())
PUSH(vm->value);
vm->value = make_closure(funcXXX,vm->env);
value = SHALLOW_ARGUMENT_SET(0);
vm->func = vm->value;
vm->value = make_vector(1);
CLOSURE_CALL()
vector_set(vm->value,0,POP())
EXIT_CLOSURE();
}
static struct frame* frame_push(struct jq_state* jq, struct closure callee,
uint16_t* argdef, int nargs) {
stack_ptr new_frame_idx = stack_push_block(&jq->stk, jq->curr_frame, frame_size(callee.bc));
struct frame* new_frame = stack_block(&jq->stk, new_frame_idx);
new_frame->bc = callee.bc;
new_frame->env = callee.env;
assert(nargs == new_frame->bc->nclosures);
union frame_entry* entries = new_frame->entries;
int i;
for (i=0; i<nargs; i++) {
entries->closure = make_closure(jq, argdef + i * 2);
entries++;
}
for (i=0; i<callee.bc->nlocals; i++) {
entries->localvar = jv_invalid();
entries++;
}
jq->curr_frame = new_frame_idx;
return new_frame;
}
static svalue_t*
make_doubleadder(svalue_t **x, svalue_t **env) {
env[0] = *x;
return make_closure(make_doubleadder_inner, env);
}
static inline svalue_t*
make_doubleadder_inner(svalue_t **y, svalue_t **env) {
env[1] = *y;
return make_closure(make_doubleadder_inner_inner, env);
}
}
void funcXXX(struct vm *vm){
ENTER_CLOSURE(1,"funcXXX");
vm->value = make_number(6);
value = SHALLOW_ARGUMENT_SET(1);
value = SHALLOW_ARGUMENT_REF(0);
PUSH(vm->value);
value = SHALLOW_ARGUMENT_REF(1);
PUSH(vm->value);
vm->value = cons(POP(),POP())
EXIT_CLOSURE();
}
void funcXXX(struct vm *vm){
ENTER_CLOSURE(1,"funcXXX");
vm->value = make_number(6);
value = SHALLOW_ARGUMENT_SET(1);
value = SHALLOW_ARGUMENT_REF(0);
PUSH(vm->value);
value = SHALLOW_ARGUMENT_REF(1);
PUSH(vm->value);
vm->value = cons(POP(),POP())
EXIT_CLOSURE();
}
//code
vm->value = make_closure(funcXXX,vm->env);
vm->func = vm->value;
vm->value = make_vector(0);
CLOSURE_CALL()
jv jq_next(jq_state *jq) {
jv cfunc_input[MAX_CFUNCTION_ARGS];
jv_nomem_handler(jq->nomem_handler, jq->nomem_handler_data);
uint16_t* pc = stack_restore(jq);
assert(pc);
int backtracking = !jq->initial_execution;
jq->initial_execution = 0;
while (1) {
uint16_t opcode = *pc;
if (jq->debug_trace_enabled) {
dump_operation(frame_current(jq)->bc, pc);
printf("\t");
const struct opcode_description* opdesc = opcode_describe(opcode);
stack_ptr param = 0;
if (!backtracking) {
int stack_in = opdesc->stack_in;
if (stack_in == -1) stack_in = pc[1];
int i;
for (i=0; i<stack_in; i++) {
if (i == 0) {
param = jq->stk_top;
} else {
printf(" | ");
param = *stack_block_next(&jq->stk, param);
}
if (!param) break;
jv_dump(jv_copy(*(jv*)stack_block(&jq->stk, param)), 0);
//printf("<%d>", jv_get_refcnt(param->val));
//printf(" -- ");
//jv_dump(jv_copy(jq->path), 0);
}
} else {
printf("\t<backtracking>");
}
printf("\n");
}
if (backtracking) {
opcode = ON_BACKTRACK(opcode);
backtracking = 0;
}
pc++;
switch (opcode) {
default: assert(0 && "invalid instruction");
case LOADK: {
jv v = jv_array_get(jv_copy(frame_current(jq)->bc->constants), *pc++);
assert(jv_is_valid(v));
jv_free(stack_pop(jq));
stack_push(jq, v);
break;
}
case DUP: {
jv v = stack_pop(jq);
stack_push(jq, jv_copy(v));
stack_push(jq, v);
break;
}
case DUP2: {
jv keep = stack_pop(jq);
jv v = stack_pop(jq);
stack_push(jq, jv_copy(v));
stack_push(jq, keep);
stack_push(jq, v);
break;
}
case SUBEXP_BEGIN: {
jv v = stack_pop(jq);
stack_push(jq, jv_copy(v));
stack_push(jq, v);
jq->subexp_nest++;
break;
}
case SUBEXP_END: {
assert(jq->subexp_nest > 0);
jq->subexp_nest--;
jv a = stack_pop(jq);
jv b = stack_pop(jq);
stack_push(jq, a);
stack_push(jq, b);
break;
}
case POP: {
jv_free(stack_pop(jq));
break;
}
case APPEND: {
jv v = stack_pop(jq);
uint16_t level = *pc++;
uint16_t vidx = *pc++;
jv* var = frame_local_var(jq, vidx, level);
assert(jv_get_kind(*var) == JV_KIND_ARRAY);
*var = jv_array_append(*var, v);
break;
}
case INSERT: {
jv stktop = stack_pop(jq);
jv v = stack_pop(jq);
jv k = stack_pop(jq);
jv objv = stack_pop(jq);
assert(jv_get_kind(objv) == JV_KIND_OBJECT);
if (jv_get_kind(k) == JV_KIND_STRING) {
stack_push(jq, jv_object_set(objv, k, v));
stack_push(jq, stktop);
} else {
print_error(jq, jv_invalid_with_msg(jv_string_fmt("Cannot use %s as object key",
jv_kind_name(jv_get_kind(k)))));
jv_free(stktop);
jv_free(v);
jv_free(k);
jv_free(objv);
goto do_backtrack;
}
break;
}
case ON_BACKTRACK(RANGE):
case RANGE: {
uint16_t level = *pc++;
uint16_t v = *pc++;
jv* var = frame_local_var(jq, v, level);
jv max = stack_pop(jq);
if (jv_get_kind(*var) != JV_KIND_NUMBER ||
jv_get_kind(max) != JV_KIND_NUMBER) {
print_error(jq, jv_invalid_with_msg(jv_string_fmt("Range bounds must be numeric")));
jv_free(max);
goto do_backtrack;
} else if (jv_number_value(jv_copy(*var)) >= jv_number_value(jv_copy(max))) {
/* finished iterating */
goto do_backtrack;
} else {
jv curr = jv_copy(*var);
*var = jv_number(jv_number_value(*var) + 1);
struct stack_pos spos = stack_get_pos(jq);
stack_push(jq, jv_copy(max));
stack_save(jq, pc - 3, spos);
stack_push(jq, curr);
}
break;
}
// FIXME: loadv/storev may do too much copying/freeing
case LOADV: {
uint16_t level = *pc++;
uint16_t v = *pc++;
jv* var = frame_local_var(jq, v, level);
if (jq->debug_trace_enabled) {
printf("V%d = ", v);
jv_dump(jv_copy(*var), 0);
printf("\n");
}
jv_free(stack_pop(jq));
stack_push(jq, jv_copy(*var));
break;
}
// Does a load but replaces the variable with null
case LOADVN: {
uint16_t level = *pc++;
uint16_t v = *pc++;
jv* var = frame_local_var(jq, v, level);
if (jq->debug_trace_enabled) {
printf("V%d = ", v);
jv_dump(jv_copy(*var), 0);
printf("\n");
}
jv_free(stack_pop(jq));
stack_push(jq, *var);
*var = jv_null();
break;
}
case STOREV: {
uint16_t level = *pc++;
uint16_t v = *pc++;
jv* var = frame_local_var(jq, v, level);
jv val = stack_pop(jq);
if (jq->debug_trace_enabled) {
printf("V%d = ", v);
jv_dump(jv_copy(val), 0);
printf("\n");
}
jv_free(*var);
*var = val;
break;
}
case PATH_BEGIN: {
jv v = stack_pop(jq);
stack_push(jq, jq->path);
stack_save(jq, pc - 1, stack_get_pos(jq));
stack_push(jq, jv_number(jq->subexp_nest));
stack_push(jq, v);
jq->path = jv_array();
jq->subexp_nest = 0;
break;
}
case PATH_END: {
jv v = stack_pop(jq);
jv_free(v); // discard value, only keep path
int old_subexp_nest = (int)jv_number_value(stack_pop(jq));
jv path = jq->path;
jq->path = stack_pop(jq);
struct stack_pos spos = stack_get_pos(jq);
stack_push(jq, jv_copy(path));
stack_save(jq, pc - 1, spos);
stack_push(jq, path);
jq->subexp_nest = old_subexp_nest;
break;
}
case ON_BACKTRACK(PATH_BEGIN):
case ON_BACKTRACK(PATH_END): {
jv_free(jq->path);
jq->path = stack_pop(jq);
goto do_backtrack;
}
case INDEX:
case INDEX_OPT: {
jv t = stack_pop(jq);
jv k = stack_pop(jq);
path_append(jq, jv_copy(k));
jv v = jv_get(t, k);
if (jv_is_valid(v)) {
stack_push(jq, v);
} else {
if (opcode == INDEX)
print_error(jq, v);
else
jv_free(v);
goto do_backtrack;
}
break;
}
case JUMP: {
uint16_t offset = *pc++;
pc += offset;
break;
}
case JUMP_F: {
uint16_t offset = *pc++;
jv t = stack_pop(jq);
jv_kind kind = jv_get_kind(t);
if (kind == JV_KIND_FALSE || kind == JV_KIND_NULL) {
pc += offset;
}
stack_push(jq, t); // FIXME do this better
break;
}
case EACH:
case EACH_OPT:
stack_push(jq, jv_number(-1));
// fallthrough
case ON_BACKTRACK(EACH):
case ON_BACKTRACK(EACH_OPT): {
int idx = jv_number_value(stack_pop(jq));
jv container = stack_pop(jq);
int keep_going, is_last = 0;
jv key, value;
if (jv_get_kind(container) == JV_KIND_ARRAY) {
if (opcode == EACH || opcode == EACH_OPT) idx = 0;
else idx = idx + 1;
int len = jv_array_length(jv_copy(container));
keep_going = idx < len;
is_last = idx == len - 1;
if (keep_going) {
key = jv_number(idx);
value = jv_array_get(jv_copy(container), idx);
}
} else if (jv_get_kind(container) == JV_KIND_OBJECT) {
if (opcode == EACH || opcode == EACH_OPT) idx = jv_object_iter(container);
else idx = jv_object_iter_next(container, idx);
keep_going = jv_object_iter_valid(container, idx);
if (keep_going) {
key = jv_object_iter_key(container, idx);
value = jv_object_iter_value(container, idx);
}
} else {
assert(opcode == EACH || opcode == EACH_OPT);
if (opcode == EACH) {
print_error(jq,
jv_invalid_with_msg(jv_string_fmt("Cannot iterate over %s",
jv_kind_name(jv_get_kind(container)))));
}
keep_going = 0;
}
if (!keep_going) {
jv_free(container);
goto do_backtrack;
} else if (is_last) {
// we don't need to make a backtrack point
jv_free(container);
path_append(jq, key);
stack_push(jq, value);
} else {
struct stack_pos spos = stack_get_pos(jq);
stack_push(jq, container);
stack_push(jq, jv_number(idx));
stack_save(jq, pc - 1, spos);
path_append(jq, key);
stack_push(jq, value);
}
break;
}
do_backtrack:
case BACKTRACK: {
pc = stack_restore(jq);
if (!pc) {
return jv_invalid();
}
backtracking = 1;
break;
}
case FORK: {
stack_save(jq, pc - 1, stack_get_pos(jq));
pc++; // skip offset this time
break;
}
case ON_BACKTRACK(FORK): {
uint16_t offset = *pc++;
pc += offset;
break;
}
case CALL_BUILTIN: {
int nargs = *pc++;
jv top = stack_pop(jq);
jv* in = cfunc_input;
int i;
in[0] = top;
for (i = 1; i < nargs; i++) {
in[i] = stack_pop(jq);
}
struct cfunction* function = &frame_current(jq)->bc->globals->cfunctions[*pc++];
typedef jv (*func_1)(jv);
typedef jv (*func_2)(jv,jv);
typedef jv (*func_3)(jv,jv,jv);
typedef jv (*func_4)(jv,jv,jv,jv);
typedef jv (*func_5)(jv,jv,jv,jv,jv);
switch (function->nargs) {
case 1: top = ((func_1)function->fptr)(in[0]); break;
case 2: top = ((func_2)function->fptr)(in[0], in[1]); break;
case 3: top = ((func_3)function->fptr)(in[0], in[1], in[2]); break;
case 4: top = ((func_4)function->fptr)(in[0], in[1], in[2], in[3]); break;
case 5: top = ((func_5)function->fptr)(in[0], in[1], in[2], in[3], in[4]); break;
default: return jv_invalid_with_msg(jv_string("Function takes too many arguments"));
}
if (jv_is_valid(top)) {
stack_push(jq, top);
} else {
print_error(jq, top);
goto do_backtrack;
}
break;
}
case CALL_JQ: {
jv input = stack_pop(jq);
uint16_t nclosures = *pc++;
uint16_t* retaddr = pc + 2 + nclosures*2;
struct frame* new_frame = frame_push(jq, make_closure(jq, pc),
pc + 2, nclosures);
new_frame->retdata = jq->stk_top;
new_frame->retaddr = retaddr;
pc = new_frame->bc->code;
stack_push(jq, input);
break;
}
case RET: {
jv value = stack_pop(jq);
assert(jq->stk_top == frame_current(jq)->retdata);
uint16_t* retaddr = frame_current(jq)->retaddr;
if (retaddr) {
// function return
pc = retaddr;
frame_pop(jq);
} else {
// top-level return, yielding value
struct stack_pos spos = stack_get_pos(jq);
stack_push(jq, jv_null());
stack_save(jq, pc - 1, spos);
return value;
}
stack_push(jq, value);
break;
}
case ON_BACKTRACK(RET): {
// resumed after top-level return
goto do_backtrack;
}
}
}
}
void execute_function(VM *vm) {
restart: {
Frame *frame = vm->current;
Closure *closure = frame->closure;
Chunk *chunk = closure->chunk;
StackObject *registers = frame->registers;
while (frame->pc < chunk->numinstructions) {
int instruction = chunk->instructions[frame->pc];
OpCode o = GET_O(instruction);
int a = GET_A(instruction);
int b = GET_B(instruction);
int c = GET_C(instruction);
switch (o) {
case OP_MOVE:
{
if (b < 256) {
copy_object(®isters[a], ®isters[b]);
} else {
copy_constant(vm, ®isters[a], chunk->constants[b - 256]);
}
} break;
case OP_GETUPVAR:
{
Upval *upval = closure->upvals[b];
if (!upval->open) {
// upval is closed
copy_object(®isters[a], upval->data.o);
} else {
// still on stack
copy_object(®isters[a], &upval->data.ref.frame->registers[upval->data.ref.slot]);
}
} break;
case OP_SETUPVAR:
{
Upval *upval = closure->upvals[b];
if (!upval->open) {
// upval is closed
copy_object(upval->data.o, ®isters[a]);
} else {
// still on stack
copy_object(&upval->data.ref.frame->registers[upval->data.ref.slot], ®isters[a]);
}
} break;
case OP_ADD:
{
// TODO - make string coercion better
// TODO - make string type with special operators
if (IS_STR(b) || IS_STR(c)) {
char *arg1 = TO_STR(b);
char *arg2 = TO_STR(c);
char *arg3 = malloc((strlen(arg1) + strlen(arg2) + 1) + sizeof *arg3);
strcpy(arg3, arg1);
strcat(arg3, arg2);
registers[a].value.o = make_string_ref(vm, arg3);
registers[a].type = OBJECT_REFERENCE; // put this after
free(arg1);
free(arg2);
} else {
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Cannot add types.");
}
if (IS_INT(b) && IS_INT(c)) {
int arg1 = AS_INT(b);
int arg2 = AS_INT(c);
registers[a].type = OBJECT_INT;
registers[a].value.i = arg1 + arg2;
} else {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_REAL;
registers[a].value.d = arg1 + arg2;
}
}
} break;
case OP_SUB:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to sub non-numbers.");
}
if (IS_INT(b) && IS_INT(c)) {
int arg1 = AS_INT(b);
int arg2 = AS_INT(c);
registers[a].type = OBJECT_INT;
registers[a].value.i = arg1 - arg2;
} else {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_REAL;
registers[a].value.d = arg1 - arg2;
}
} break;
case OP_MUL:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to mul non-numbers.");
}
if (IS_INT(b) && IS_INT(c)) {
int arg1 = AS_INT(b);
int arg2 = AS_INT(c);
registers[a].type = OBJECT_INT;
registers[a].value.i = arg1 * arg2;
} else {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_REAL;
registers[a].value.d = arg1 * arg2;
}
} break;
case OP_DIV:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to div non-numbers.");
}
if ((IS_INT(c) && AS_INT(c) == 0) || (IS_REAL(c) && AS_REAL(c) == 0)) {
fatal("Div by 0.");
}
if (IS_INT(b) && IS_INT(c)) {
int arg1 = AS_INT(b);
int arg2 = AS_INT(c);
registers[a].type = OBJECT_INT;
registers[a].value.i = arg1 / arg2;
} else {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_REAL;
registers[a].value.d = arg1 / arg2;
}
} break;
case OP_MOD:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to div non-numbers.");
}
if ((IS_INT(c) && AS_INT(c) == 0) || (IS_REAL(c) && AS_REAL(c) == 0)) {
fatal("Mod by 0.");
}
if (IS_INT(b) && IS_INT(c)) {
int arg1 = AS_INT(b);
int arg2 = AS_INT(c);
registers[a].type = OBJECT_INT;
registers[a].value.i = arg1 % arg2;
} else {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_REAL;
registers[a].value.i = fmod(arg1, arg2);
}
} break;
case OP_POW:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to div non-numbers.");
}
if (IS_INT(b) && IS_INT(c)) {
int arg1 = AS_INT(b);
int arg2 = AS_INT(c);
registers[a].type = OBJECT_INT;
registers[a].value.i = (int) pow(arg1, arg2);
} else {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_REAL;
registers[a].value.d = pow(arg1, arg2);
}
} break;
case OP_NEG:
{
if (IS_INT(b)) {
registers[a].type = OBJECT_INT;
registers[a].value.i = -AS_INT(b);
} else if (IS_REAL(b)) {
registers[a].type = OBJECT_INT;
registers[a].value.i = -AS_REAL(b);
} else {
fatal("Tried to negate non-numeric type.");
}
} break;
case OP_NOT:
{
if (registers[a].type != OBJECT_BOOL) {
fatal("Expected boolean type, not %d.", registers[a].type);
}
registers[a].value.i = registers[a].value.i == 1 ? 0 : 1;
} break;
case OP_EQ:
{
if ((IS_INT(b) || IS_REAL(b)) && (IS_INT(c) || IS_REAL(c))) {
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_BOOL;
registers[a].value.i = arg1 == arg2;
} else {
fatal("Comparison of reference types not yet supported.");
}
} break;
case OP_LT:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to compare non-numbers.");
}
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_BOOL;
registers[a].value.i = arg1 < arg2;
} break;
case OP_LE:
{
if (!(IS_INT(b) || IS_REAL(b)) || !(IS_INT(c) || IS_REAL(c))) {
fatal("Tried to compare non-numbers.");
}
double arg1 = IS_INT(b) ? (double) AS_INT(b) : AS_REAL(b);
double arg2 = IS_INT(c) ? (double) AS_INT(c) : AS_REAL(c);
registers[a].type = OBJECT_BOOL;
registers[a].value.i = arg1 <= arg2;
} break;
case OP_CLOSURE:
{
Closure *child = make_closure(chunk->children[b]);
int i;
for (i = 0; i < chunk->children[b]->numupvars; i++) {
int inst = chunk->instructions[++frame->pc];
OpCode oc = GET_O(inst);
int ac = GET_A(inst);
int bc = GET_B(inst);
int cc = GET_C(inst);
if (oc == OP_MOVE) {
// first upval for this variable
child->upvals[ac] = make_upval(vm, bc);
} else {
// share upval
child->upvals[ac] = closure->upvals[bc];
child->upvals[ac]->refcount++;
}
}
registers[a].value.o = make_closure_ref(vm, child);
registers[a].type = OBJECT_REFERENCE; // put this after
} break;
case OP_CALL:
{
if (registers[b].type != OBJECT_REFERENCE || registers[b].value.o->type != OBJECT_CLOSURE) {
fatal("Tried to call non-closure.");
}
// TODO - safety issue (see compile.c for notes)
Closure *child = registers[b].value.o->value.c;
Frame *subframe = make_frame(frame, child);
int i;
for (i = 0; i < child->chunk->numparams; i++) {
copy_object(&subframe->registers[i + 1], ®isters[c + i]);
}
vm->current = subframe;
goto restart;
} break;
case OP_RETURN:
{
UpvalNode *head;
for (head = vm->open; head != NULL; ) {
Upval *u = head->upval;
if (u->data.ref.frame == frame) {
StackObject *o = malloc(sizeof *o);
if (!o) {
fatal("Out of memory.");
}
u->open = 0;
copy_object(o, ®isters[u->data.ref.slot]);
u->data.o = o;
if (vm->open == head) {
vm->open = head->next;
} else {
head->next->prev = head->prev;
head->prev->next = head->next;
}
UpvalNode *temp = head;
head = head->next;
free(temp);
} else {
head = head->next;
}
}
if (vm->current->parent != NULL) {
Frame *p = vm->current->parent;
StackObject *target = &p->registers[GET_A(p->closure->chunk->instructions[p->pc++])];
if (b < 256) {
// debug
char *d = obj_to_str(®isters[b]);
printf("Return value: %s\n", d);
free(d);
copy_object(target, ®isters[b]);
} else {
copy_constant(vm, target, chunk->constants[b - 256]);
}
free_frame(frame);
vm->current = p;
goto restart;
} else {
// debug
char *d = obj_to_str(®isters[b]);
printf("Return value: %s\n", d);
free(d);
free_frame(frame);
vm->current = NULL;
return;
}
} break;
case OP_JUMP:
frame->pc += c ? -b : b;
break;
case OP_JUMP_TRUE:
{
if (registers[a].type != OBJECT_BOOL) {
fatal("Expected boolean type, not %d.", registers[a].type);
}
if (registers[a].value.i == 1) {
frame->pc += c ? -b : b;
}
} break;
case OP_JUMP_FALSE:
{
if (registers[a].type != OBJECT_BOOL) {
fatal("Expected boolean type, not %d.", registers[a].type);
}
if (registers[a].value.i == 0) {
frame->pc += c ? -b : b;
}
} break;
case OP_ENTER_TRY:
{
vm->catchframe = make_catch_frame(frame, vm->catchframe, frame->pc + b);
} break;
case OP_LEAVE_TRY:
{
CatchFrame *temp = vm->catchframe;
vm->catchframe = vm->catchframe->parent;
free_catch_frame(temp);
} break;
case OP_THROW:
{
// TODO - replace unwinding of stack with an exceptions
// table per-chunk. It will have an instructions range,
// the starting instruction of a handler, and the type of
// exception that it may handle.
// Exception table:
// From To Target Type
// 0 4 5 Class TestExc1
// 0 12 12 Class TestExc2
// TODO - implement a way to expect an exception
// of a given type instead of a generic catch-all.
char *s = obj_to_str(®isters[a]);
printf("Exception value: %s!\n", s);
free(s);
// TODO - this is probably wrong. Not sure how complicated
// it will be to handle upvalues and frame destruction here,
// so we're just doing it a shitty way for now :D [GO LAZE].
if (!vm->catchframe) {
// TODO - print a stack trace [ requires debug symbols :( ]
fatal("Exception thrown outside of handler.");
}
while (vm->current != vm->catchframe->frame) {
// TODO - destruct frame
vm->current = vm->current->parent;
}
vm->current->pc = vm->catchframe->target;
CatchFrame *temp = vm->catchframe;
vm->catchframe = vm->catchframe->parent;
free_catch_frame(temp);
goto restart;
} break;
}
frame->pc++;
}
fatal("VM left instruction-space.");
}
}
jv jq_next(jq_state *jq) {
jv cfunc_input[MAX_CFUNCTION_ARGS];
uint16_t* pc = stack_restore(jq);
assert(pc);
int backtracking = !jq->initial_execution;
jq->initial_execution = 0;
while (1) {
uint16_t opcode = *pc;
if (jq->debug_trace_enabled) {
dump_operation(frame_current_bytecode(&jq->frame_stk), pc);
printf("\t");
const struct opcode_description* opdesc = opcode_describe(opcode);
data_stk_elem* param = 0;
int stack_in = opdesc->stack_in;
if (stack_in == -1) stack_in = pc[1];
for (int i=0; i<stack_in; i++) {
if (i == 0) {
param = forkable_stack_peek(&jq->data_stk);
} else {
printf(" | ");
param = forkable_stack_peek_next(&jq->data_stk, param);
}
if (!param) break;
jv_dump(jv_copy(param->val), 0);
//printf("<%d>", jv_get_refcnt(param->val));
//printf(" -- ");
//jv_dump(jv_copy(jq->path), 0);
}
if (backtracking) printf("\t<backtracking>");
printf("\n");
}
if (backtracking) {
opcode = ON_BACKTRACK(opcode);
backtracking = 0;
}
pc++;
switch (opcode) {
default: assert(0 && "invalid instruction");
case LOADK: {
jv v = jv_array_get(jv_copy(frame_current_bytecode(&jq->frame_stk)->constants), *pc++);
assert(jv_is_valid(v));
jv_free(stack_pop(jq));
stack_push(jq, v);
break;
}
case DUP: {
jv v = stack_pop(jq);
stack_push(jq, jv_copy(v));
stack_push(jq, v);
break;
}
case DUP2: {
jv keep = stack_pop(jq);
jv v = stack_pop(jq);
stack_push(jq, jv_copy(v));
stack_push(jq, keep);
stack_push(jq, v);
break;
}
case SUBEXP_BEGIN: {
jv v = stack_pop(jq);
stack_push(jq, jv_copy(v));
stack_push(jq, v);
jq->subexp_nest++;
break;
}
case SUBEXP_END: {
assert(jq->subexp_nest > 0);
jq->subexp_nest--;
jv a = stack_pop(jq);
jv b = stack_pop(jq);
stack_push(jq, a);
stack_push(jq, b);
break;
}
case POP: {
jv_free(stack_pop(jq));
break;
}
case APPEND: {
jv v = stack_pop(jq);
uint16_t level = *pc++;
uint16_t vidx = *pc++;
frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level);
jv* var = frame_local_var(fp, vidx);
assert(jv_get_kind(*var) == JV_KIND_ARRAY);
*var = jv_array_append(*var, v);
break;
}
case INSERT: {
jv stktop = stack_pop(jq);
jv v = stack_pop(jq);
jv k = stack_pop(jq);
jv objv = stack_pop(jq);
assert(jv_get_kind(objv) == JV_KIND_OBJECT);
if (jv_get_kind(k) == JV_KIND_STRING) {
stack_push(jq, jv_object_set(objv, k, v));
stack_push(jq, stktop);
} else {
print_error(jv_invalid_with_msg(jv_string_fmt("Cannot use %s as object key",
jv_kind_name(jv_get_kind(k)))));
jv_free(stktop);
jv_free(v);
jv_free(k);
jv_free(objv);
goto do_backtrack;
}
break;
}
case ON_BACKTRACK(RANGE):
case RANGE: {
uint16_t level = *pc++;
uint16_t v = *pc++;
frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level);
jv* var = frame_local_var(fp, v);
jv max = stack_pop(jq);
if (jv_get_kind(*var) != JV_KIND_NUMBER ||
jv_get_kind(max) != JV_KIND_NUMBER) {
print_error(jv_invalid_with_msg(jv_string_fmt("Range bounds must be numeric")));
jv_free(max);
goto do_backtrack;
} else if (jv_number_value(jv_copy(*var)) >= jv_number_value(jv_copy(max))) {
/* finished iterating */
goto do_backtrack;
} else {
jv curr = jv_copy(*var);
*var = jv_number(jv_number_value(*var) + 1);
stack_save(jq, pc - 3);
stack_push(jq, jv_copy(max));
stack_switch(jq);
stack_push(jq, curr);
}
break;
}
// FIXME: loadv/storev may do too much copying/freeing
case LOADV: {
uint16_t level = *pc++;
uint16_t v = *pc++;
frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level);
jv* var = frame_local_var(fp, v);
if (jq->debug_trace_enabled) {
printf("V%d = ", v);
jv_dump(jv_copy(*var), 0);
printf("\n");
}
jv_free(stack_pop(jq));
stack_push(jq, jv_copy(*var));
break;
}
case STOREV: {
uint16_t level = *pc++;
uint16_t v = *pc++;
frame_ptr fp = frame_get_level(&jq->frame_stk, frame_current(&jq->frame_stk), level);
jv* var = frame_local_var(fp, v);
jv val = stack_pop(jq);
if (jq->debug_trace_enabled) {
printf("V%d = ", v);
jv_dump(jv_copy(val), 0);
printf("\n");
}
jv_free(*var);
*var = val;
break;
}
case PATH_BEGIN: {
jv v = stack_pop(jq);
stack_push(jq, jq->path);
stack_save(jq, pc - 1);
stack_switch(jq);
stack_push(jq, jv_number(jq->subexp_nest));
stack_push(jq, v);
jq->path = jv_array();
jq->subexp_nest = 0;
break;
}
case PATH_END: {
jv v = stack_pop(jq);
jv_free(v); // discard value, only keep path
int old_subexp_nest = (int)jv_number_value(stack_pop(jq));
jv path = jq->path;
jq->path = stack_pop(jq);
stack_save(jq, pc - 1);
stack_push(jq, jv_copy(path));
stack_switch(jq);
stack_push(jq, path);
jq->subexp_nest = old_subexp_nest;
break;
}
case ON_BACKTRACK(PATH_BEGIN):
case ON_BACKTRACK(PATH_END): {
jv_free(jq->path);
jq->path = stack_pop(jq);
goto do_backtrack;
}
case INDEX: {
jv t = stack_pop(jq);
jv k = stack_pop(jq);
path_append(jq, jv_copy(k));
jv v = jv_get(t, k);
if (jv_is_valid(v)) {
stack_push(jq, v);
} else {
print_error(v);
goto do_backtrack;
}
break;
}
case JUMP: {
uint16_t offset = *pc++;
pc += offset;
break;
}
case JUMP_F: {
uint16_t offset = *pc++;
jv t = stack_pop(jq);
jv_kind kind = jv_get_kind(t);
if (kind == JV_KIND_FALSE || kind == JV_KIND_NULL) {
pc += offset;
}
stack_push(jq, t); // FIXME do this better
break;
}
case EACH:
stack_push(jq, jv_number(-1));
// fallthrough
case ON_BACKTRACK(EACH): {
int idx = jv_number_value(stack_pop(jq));
jv container = stack_pop(jq);
int keep_going;
jv key, value;
if (jv_get_kind(container) == JV_KIND_ARRAY) {
if (opcode == EACH) idx = 0;
else idx = idx + 1;
keep_going = idx < jv_array_length(jv_copy(container));
if (keep_going) {
key = jv_number(idx);
value = jv_array_get(jv_copy(container), idx);
}
} else if (jv_get_kind(container) == JV_KIND_OBJECT) {
if (opcode == EACH) idx = jv_object_iter(container);
else idx = jv_object_iter_next(container, idx);
keep_going = jv_object_iter_valid(container, idx);
if (keep_going) {
key = jv_object_iter_key(container, idx);
value = jv_object_iter_value(container, idx);
}
} else {
assert(opcode == EACH);
print_error(jv_invalid_with_msg(jv_string_fmt("Cannot iterate over %s",
jv_kind_name(jv_get_kind(container)))));
keep_going = 0;
}
if (!keep_going) {
jv_free(container);
goto do_backtrack;
} else {
stack_save(jq, pc - 1);
stack_push(jq, container);
stack_push(jq, jv_number(idx));
stack_switch(jq);
path_append(jq, key);
stack_push(jq, value);
}
break;
}
do_backtrack:
case BACKTRACK: {
pc = stack_restore(jq);
if (!pc) {
return jv_invalid();
}
backtracking = 1;
break;
}
case FORK: {
stack_save(jq, pc - 1);
stack_switch(jq);
pc++; // skip offset this time
break;
}
case ON_BACKTRACK(FORK): {
uint16_t offset = *pc++;
pc += offset;
break;
}
case CALL_BUILTIN: {
int nargs = *pc++;
jv top = stack_pop(jq);
cfunc_input[0] = top;
for (int i = 1; i < nargs; i++) {
cfunc_input[i] = stack_pop(jq);
}
struct cfunction* func = &frame_current_bytecode(&jq->frame_stk)->globals->cfunctions[*pc++];
top = cfunction_invoke(func, cfunc_input);
if (jv_is_valid(top)) {
stack_push(jq, top);
} else {
print_error(top);
goto do_backtrack;
}
break;
}
case CALL_JQ: {
uint16_t nclosures = *pc++;
uint16_t* retaddr = pc + 2 + nclosures*2;
frame_ptr new_frame = frame_push(&jq->frame_stk,
make_closure(&jq->frame_stk, frame_current(&jq->frame_stk), pc),
retaddr);
pc += 2;
frame_ptr old_frame = forkable_stack_peek_next(&jq->frame_stk, new_frame);
assert(nclosures == frame_self(new_frame)->bc->nclosures);
for (int i=0; i<nclosures; i++) {
*frame_closure_arg(new_frame, i) = make_closure(&jq->frame_stk, old_frame, pc);
pc += 2;
}
pc = frame_current_bytecode(&jq->frame_stk)->code;
break;
}
case RET: {
uint16_t* retaddr = *frame_current_retaddr(&jq->frame_stk);
if (retaddr) {
// function return
pc = retaddr;
frame_pop(&jq->frame_stk);
} else {
// top-level return, yielding value
jv value = stack_pop(jq);
stack_save(jq, pc - 1);
stack_push(jq, jv_null());
stack_switch(jq);
return value;
}
break;
}
case ON_BACKTRACK(RET): {
// resumed after top-level return
goto do_backtrack;
}
}
}
}
