void su_seq_reverse(su_state *s, int idx) {
su_pushnil(s);
su_copy(s, idx - 1);
while (su_type(s, -1) == SU_SEQ) {
su_first(s, -1);
su_copy(s, -3);
su_cons(s);
su_swap(s, -3, -1);
su_pop(s, 1);
su_rest(s, -1);
su_swap(s, -2, -1);
su_pop(s, 1);
}
su_pop(s, 1);
}
void su_setglobal(su_state *s, const char *name) {
value_t v;
unsigned size = strlen(name);
v.type = SU_STRING;
v.obj.gc_object = string_from_cache(s, name, size);
set_global(s, name, hash_value(&v), size, STK(-1));
su_pop(s, 1);
}
void su_call(su_state *s, int narg, int nret) {
int pc, tmp, fret;
prototype_t *prot;
int top = s->stack_top - narg - 1;
value_t *f = &s->stack[top];
frame_t *frame = &s->frames[s->frame_top++];
assert(s->frame_top <= MAX_CALLS);
frame->ret_addr = 0xffff;
frame->func = f->obj.func;
frame->stack_top = top;
pc = s->pc;
prot = s->prot;
tmp = s->narg;
s->narg = narg;
if (f->type == SU_FUNCTION) {
if (f->obj.func->narg < 0) {
su_vector(s, narg);
s->narg = narg = 1;
} else {
su_assert(s, f->obj.func->narg == narg, "Bad number of argument to function!");
}
vm_loop(s, f->obj.func);
if (nret == 0)
su_pop(s, 1);
} else if (f->type == SU_NATIVEFUNC) {
fret = f->obj.nfunc(s, narg);
if (nret > 0 && fret > 0) {
s->stack[top] = *STK(-1);
su_pop(s, narg);
} else {
s->stack_top = top;
if (nret > 0)
su_pushnil(s);
}
s->frame_top--;
} else {
assert(0);
}
s->narg = tmp;
s->prot = prot;
s->pc = pc;
}
int su_load_call_wrp(lua_State *L) {
su_state *s = (su_state*)lua_touserdata(L, -3);
int len = lua_tointeger(L, -2);
code = lua_tostring(L, -1);
len = su_load(s, reader, &len);
if (!len) {
su_pushnil(s);
su_call(s, 1, 1);
push_sexp(L, s, s->stack[s->stack_top - 1]);
su_pop(s, 1);
} else {
lua_pushnil(L);
}
return 1;
}
void su_vector_set(su_state *s, int idx) {
s->stack[s->stack_top - 2] = vector_set(s, STK(TOP(idx))->obj.vec, (int)STK(-2)->obj.num, STK(-1));
su_pop(s, 1);
}
static void vm_loop(su_state *s, function_t *func) {
value_t tmpv, tmpv2;
instruction_t inst;
int tmp, narg, i, j, k;
const char *tmpcs;
su_debug_data dbg;
s->frame = FRAME();
s->prot = func->prot;
#define ARITH_OP(op) \
su_check_type(s, -2, SU_NUMBER); \
su_check_type(s, -1, SU_NUMBER); \
STK(-2)->obj.num = STK(-2)->obj.num op STK(-1)->obj.num; \
su_pop(s, 1); \
break;
#define LOG_OP(op) \
su_check_type(s, -2, SU_NUMBER); \
su_check_type(s, -1, SU_NUMBER); \
STK(-2)->type = SU_BOOLEAN; \
STK(-2)->obj.b = STK(-2)->obj.num op STK(-1)->obj.num; \
su_pop(s, 1); \
break;
for (s->pc = 0; s->pc < s->prot->num_inst; s->pc++) {
tmp = s->interrupt | atomic_get(&s->msi->interrupt);
if (tmp) {
if ((tmp & ISCOLLECT) == ISCOLLECT) {
su_thread_indisposable(s);
su_thread_disposable(s);
}
if ((tmp & IGC) == IGC) {
unmask_thread_interrupt(s, IGC);
gc_trace(s);
}
if ((tmp & IBREAK) == IBREAK) {
unmask_thread_interrupt(s, IBREAK);
dbg.file = s->prot->name->str;
dbg.line = s->prot->lineinf[s->pc];
s->debug_cb(s, &dbg, s->debug_cb_data);
}
}
inst = s->prot->inst[s->pc];
switch (inst.id) {
case OP_PUSH:
push_value(s, &func->constants[inst.a]);
break;
case OP_POP:
su_pop(s, inst.a);
break;
case OP_ADD: ARITH_OP(+)
case OP_SUB: ARITH_OP(-)
case OP_MUL: ARITH_OP(*)
case OP_DIV:
su_check_type(s, -2, SU_NUMBER);
su_check_type(s, -1, SU_NUMBER);
su_assert(s, STK(-1)->obj.num != 0.0, "Division by zero!");
STK(-2)->obj.num = STK(-2)->obj.num / STK(-1)->obj.num;
su_pop(s, 1);
break;
case OP_MOD:
su_check_type(s, -2, SU_NUMBER);
su_check_type(s, -1, SU_NUMBER);
STK(-2)->obj.num = (double)((int)STK(-2)->obj.num % (int)STK(-1)->obj.num);
su_pop(s, 1);
break;
case OP_POW:
su_check_type(s, -2, SU_NUMBER);
su_check_type(s, -1, SU_NUMBER);
STK(-2)->obj.num = pow(STK(-2)->obj.num, STK(-1)->obj.num);
su_pop(s, 1);
break;
case OP_UNM:
su_check_type(s, -1, SU_NUMBER);
STK(-1)->obj.num = -STK(-1)->obj.num;
break;
case OP_EQ:
STK(-2)->obj.b = value_eq(STK(-2), STK(-1));
STK(-2)->type = SU_BOOLEAN;
su_pop(s, 1);
break;
case OP_LESS: LOG_OP(<);
case OP_LEQUAL: LOG_OP(<=);
case OP_NOT:
if (STK(-1)->type == SU_BOOLEAN) {
STK(-1)->obj.b = !STK(-1)->obj.b;
} else {
STK(-1)->obj.b = (STK(-1)->type == SU_NIL) ? 1 : 0;
STK(-1)->type = SU_BOOLEAN;
}
break;
case OP_AND:
tmp = STK(-2)->type != SU_NIL && (STK(-2)->type != SU_BOOLEAN || STK(-2)->obj.b);
if (tmp && STK(-1)->type != SU_NIL && (STK(-1)->type != SU_BOOLEAN || STK(-1)->obj.b)) {
s->stack[s->stack_top - 2] = *STK(-1);
} else {
STK(-2)->obj.b = 0;
STK(-2)->type = SU_BOOLEAN;
}
su_pop(s, 1);
break;
case OP_OR:
if (STK(-2)->type != SU_NIL && (STK(-2)->type != SU_BOOLEAN || STK(-2)->obj.b)) {
/* return -2 */
} else if (STK(-1)->type != SU_NIL && (STK(-1)->type != SU_BOOLEAN || STK(-1)->obj.b)) {
s->stack[s->stack_top - 2] = *STK(-1);
} else {
STK(-2)->obj.b = 0;
STK(-2)->type = SU_BOOLEAN;
}
su_pop(s, 1);
break;
case OP_TEST:
if (STK(-1)->type != SU_NIL && (STK(-1)->type != SU_BOOLEAN || STK(-1)->obj.b))
s->pc = inst.b - 1;
su_pop(s, 1);
break;
case OP_FOR:
if (STK(-2)->type == SU_NIL) {
su_swap(s, -2, -1);
s->stack_top--;
s->pc = inst.b - 1;
} else {
s->stack_top--;
su_check_type(s, -1, SU_SEQ);
su_rest(s, -1);
su_swap(s, -2, -1);
su_first(s, -1);
su_swap(s, -2, -1);
s->stack_top--;
}
break;
case OP_JMP:
s->pc = inst.b - 1;
break;
case OP_RETURN:
s->pc = s->frame->ret_addr - 1;
s->prot = s->frame->func->prot;
func = s->frame->func;
s->stack[s->frame->stack_top] = *STK(-1);
s->stack_top = s->frame->stack_top + 1;
s->frame_top--;
s->frame = FRAME();
break;
case OP_TCALL:
s->pc = s->frame->ret_addr - 1;
s->prot = s->frame->func->prot;
func = s->frame->func;
memmove(&s->stack[s->frame->stack_top], &s->stack[s->stack_top - (inst.a + 1)], sizeof(value_t) * (inst.a + 1));
s->stack_top = s->frame->stack_top + inst.a + 1;
s->frame_top--;
s->frame = FRAME();
/* Do a normal call. */
case OP_CALL:
tmp = s->stack_top - inst.a - 1;
switch (s->stack[tmp].type) {
case SU_FUNCTION:
s->frame = &s->frames[s->frame_top++];
assert(s->frame_top <= MAX_CALLS);
s->frame->ret_addr = s->pc + 1;
s->frame->func = func;
s->frame->stack_top = tmp;
func = s->stack[tmp].obj.func;
if (func->narg < 0)
su_vector(s, inst.a);
else if (func->narg != inst.a)
su_error(s, "Bad number of arguments to function! Expected %i, but got %i.", (int)func->narg, (int)inst.a);
s->prot = func->prot;
s->pc = -1;
break;
case SU_NATIVEFUNC:
narg = s->narg;
s->narg = inst.a;
if (s->stack[tmp].obj.nfunc(s, inst.a)) {
s->stack[tmp] = *STK(-1);
} else {
s->stack[tmp].type = SU_NIL;
}
s->stack_top = tmp + 1;
s->narg = narg;
break;
case SU_VECTOR:
if (inst.a == 1) {
su_check_type(s, -1, SU_NUMBER);
tmpv = vector_index(s, s->stack[tmp].obj.vec, su_tointeger(s, -1));
su_pop(s, 2);
push_value(s, &tmpv);
} else {
for (i = -inst.a, j = 0; i; i++, j++) {
su_check_type(s, i - j, SU_NUMBER);
tmpv = vector_index(s, s->stack[tmp].obj.vec, su_tointeger(s, i - j));
push_value(s, &tmpv);
}
su_vector(s, inst.a);
s->stack[tmp] = s->stack[s->stack_top - 1];
s->stack_top -= inst.a + 1;
}
break;
case SU_MAP:
if (inst.a == 1) {
tmpv2 = *STK(-1);
tmpv = map_get(s, s->stack[tmp].obj.m, &tmpv2, hash_value(&tmpv2));
su_assert(s, tmpv.type != SU_INV, "No value with key: %s", stringify(s, &tmpv2));
su_pop(s, 2);
push_value(s, &tmpv);
} else {
for (i = -inst.a, j = 0; i; i++, j += 2) {
tmpv2 = *STK(i - j);
push_value(s, &tmpv2);
tmpv = map_get(s, s->stack[tmp].obj.m, &tmpv2, hash_value(&tmpv2));
su_assert(s, tmpv.type != SU_INV, "No value with key: %s", stringify(s, &tmpv2));
push_value(s, &tmpv);
}
su_map(s, inst.a);
s->stack[tmp] = s->stack[s->stack_top - 1];
s->stack_top -= inst.a + 1;
}
break;
case SU_STRING:
if (inst.a == 1) {
su_check_type(s, -1, SU_NUMBER);
j = su_tointeger(s, -1);
su_assert(s, j < s->stack[tmp].obj.str->size, "Out of range!");
s->scratch_pad[0] = s->stack[tmp].obj.str->str[j];
su_pop(s, 2);
su_pushbytes(s, s->scratch_pad, 1);
} else {
k = 0;
for (i = -inst.a; i; i++) {
su_check_type(s, i, SU_NUMBER);
j = su_tointeger(s, i);
su_assert(s, j < s->stack[tmp].obj.str->size, "Out of range!");
s->scratch_pad[k++] = s->stack[tmp].obj.str->str[j];
assert(k < SU_SCRATCHPAD_SIZE);
}
su_pushbytes(s, s->scratch_pad, k);
s->stack[tmp] = s->stack[s->stack_top - 1];
s->stack_top -= inst.a + 1;
}
break;
case SU_NATIVEDATA:
tmpv = s->stack[tmp];
if (tmpv.obj.data->vt && tmpv.obj.data->vt->call) {
narg = s->narg;
s->narg = inst.a;
if (tmpv.obj.data->vt->call(s, (void*)tmpv.obj.data->data, inst.a))
s->stack[tmp] = *STK(-1);
else
s->stack[tmp].type = SU_NIL;
s->stack_top = tmp + 1;
s->narg = narg;
break;
}
default:
if (inst.a == 1 && isseq(s, &s->stack[tmp])) {
su_check_type(s, -1, SU_STRING);
tmpcs = su_tostring(s, -1, NULL);
if (!strcmp(tmpcs, "first")) {
s->stack[(--s->stack_top) - 1] = seq_first(s, STK(-1)->obj.q);
break;
} else if (!strcmp(tmpcs, "rest")) {
s->stack[(--s->stack_top) - 1] = seq_rest(s, STK(-1)->obj.q);
break;
}
}
su_error(s, "Can't apply '%s'.", type_name(s->stack[tmp].type));
}
break;
case OP_LAMBDA:
assert(inst.a < s->prot->num_prot);
lambda(s, &s->prot->prot[inst.a], inst.b);
break;
case OP_GETGLOBAL:
tmpv = func->constants[inst.a];
su_assert(s, tmpv.type == SU_STRING, "Global key must be a string!");
tmpv = map_get(s, unref_local(s, s->stack[SU_GLOBAL_INDEX].obj.loc).obj.m, &tmpv, hash_value(&tmpv));
if (tmpv.type == SU_INV)
global_error(s, "Undefined global variable", &func->constants[inst.a]);
push_value(s, &tmpv);
break;
case OP_SETGLOBAL:
tmpv = func->constants[inst.a];
su_assert(s, tmpv.type == SU_STRING, "Global key must be a string!");
i = hash_value(&tmpv);
tmpv2 = unref_local(s, s->stack[SU_GLOBAL_INDEX].obj.loc);
tmpv = map_insert(s, tmpv2.obj.m, &tmpv, i, STK(-1));
set_local(s, s->stack[SU_GLOBAL_INDEX].obj.loc, &tmpv);
break;
case OP_SHIFT:
s->stack[s->stack_top - (inst.a + 1)] = *STK(-1);
s->stack_top -= inst.a;
break;
case OP_LOAD:
assert(FRAME()->stack_top + inst.a < s->stack_top);
push_value(s, &s->stack[FRAME()->stack_top + inst.a]);
break;
case OP_LUP:
assert(inst.a < func->num_ups);
push_value(s, &func->upvalues[inst.a]);
break;
case OP_LCL:
assert(inst.b < s->msi->num_c_lambdas);
push_value(s, &s->msi->c_lambdas[inst.b]);
break;
default:
assert(0);
}
#undef ARITH_OP
#undef LOG_OP
}
}
int main(int argc, char *argv[]) {
int ret, i;
int compile;
FILE *fp;
jmp_buf err;
su_state *s;
lua_State *L;
char *tmp;
const char *tmp2;
const char *input, *output;
int print_help = argc > 1 && strstr("-h -v --help --version", argv[1]) != NULL;
int pipe = argc > 1 && !strcmp("--", argv[1]);
compiler = su_init(NULL);
su_libinit(compiler);
___saurus(compiler);
atexit(shutdown);
if (!pipe && (argc <= 1 || print_help)) {
printf("S A U R U S\nCopyright (c) 2009-2015 Andreas T Jonsson <*****@*****.**>\nVersion: %s\n\n", su_version(NULL, NULL, NULL));
if (print_help) {
puts("Usage: saurus <options> <input.su> <output.suc>\n\tOptions:\n\t\t'-c' Compile source file to binary file.\n\t\t'--' read from STDIN.");
return 0;
}
}
s = su_init(NULL);
su_libinit(s);
L = lua_open();
luaL_openlibs(L);
luaopen_writebin(L);
if (luaL_loadstring(L, compiler_code)) {
fprintf(stderr, "%s\n", lua_tostring(L, -1));
lua_close(L);
su_close(s);
return -1;
}
if (lua_pcall(L, 0, 0, 0)) {
lua_getglobal(L, "saurus_error");
if (lua_isnil(L, -1))
lua_pop(L, 1);
fprintf(stderr, "%s\n", lua_tostring(L, -1));
lua_close(L);
su_close(s);
return -1;
}
ret = 0;
if (argc < 2 || pipe) {
if (!pipe)
puts("Type '_h' for help or '_q' to exit.\n");
su_pushstring(s, repl_help_text);
su_setglobal(s, "_h");
su_pushstring(s, "_q");
su_setglobal(s, "_q");
ret = setjmp(err);
if (!pipe)
su_seterror(s, err, ret);
jump: for (;;) {
if (!pipe)
printf("> ");
fgets(buffer, BUFFER_SIZE, stdin);
lua_getglobal(L, "repl");
lua_pushstring(L, buffer);
lua_pushstring(L, argv[0]);
if (lua_pcall(L, 2, 1, 0)) {
lua_getglobal(L, "saurus_error");
if (lua_isnil(L, -1)) {
lua_pop(L, 1);
puts(lua_tostring(L, -1));
} else {
puts(lua_tostring(L, -1));
lua_pop(L, 1);
}
lua_pop(L, 1);
goto jump;
}
lua_getglobal(L, "c_code");
su_assert(s, lua_isnil(L, -1), "Inline C is not supported in interpreter!");
lua_pop(L, 1);
tmp2 = lua_tolstring(L, -1, NULL);
su_assert(s, su_getglobal(s, "io"), "Could not retrieve 'io' namespace.");
su_pushstring(s, "print");
su_assert(s, su_map_get(s, -2), "Could not retrieve 'print' function.");
if (su_load(s, NULL, (void*)tmp2)) {
su_close(s);
lua_close(L);
fprintf(stderr, "Could not load: %s\n", argv[1]);
return -1;
}
lua_pop(L, 1);
su_call(s, 0, 1);
if (su_type(s, -1) == SU_STRING && !strcmp(su_tostring(s, -1, NULL), "_q")) {
ret = 0;
break;
}
su_call(s, 1, 0);
su_pop(s, 1);
}
} else {
compile = !strcmp(argv[1], "-c");
input = compile ? argv[2] : argv[1];
if (compile) {
if (argc < 4) {
fputs("Expected input and output file!", stderr);
lua_close(L);
su_close(s);
return -1;
}
} else {
fp = fopen(input, "rb");
if (!fp) {
fprintf(stderr, "Could not open: %s\n", input);
lua_close(L);
su_close(s);
return -1;
}
if (fread(buffer, 1, 1, fp) == 1) {
if (*buffer == '\x1b') {
rewind(fp);
if (su_load(s, &reader_fp, fp)) {
su_close(s);
lua_close(L);
fclose(fp);
fprintf(stderr, "Could not load: %s\n", input);
return -1;
}
su_pushstring(s, input);
for (i = 2; i < argc; i++)
su_pushstring(s, argv[i]);
su_call(s, argc - 1, 1);
if (su_type(s, -1) == SU_NUMBER)
ret = (int)su_tonumber(s, -1);
su_close(s);
lua_close(L);
fclose(fp);
return ret;
}
}
fclose(fp);
}
tmp = tmpnam(buffer);
output = compile ? argv[3] : tmp;
lua_getglobal(L, "compile");
lua_pushstring(L, input);
lua_pushstring(L, output);
lua_pushboolean(L, compile);
if (lua_pcall(L, 3, 0, 0)) {
lua_getglobal(L, "saurus_error");
if (lua_isnil(L, -1))
lua_pop(L, 1);
fprintf(stderr, "%s\n", lua_tostring(L, -1));
lua_close(L);
su_close(s);
return -1;
}
if (!compile) {
fp = fopen(output, "rb");
if (!fp) {
fprintf(stderr, "Could not open: %s\n", output);
lua_close(L);
su_close(s);
return -1;
}
if (su_load(s, &reader_fp, fp)) {
su_close(s);
lua_close(L);
fclose(fp);
remove(tmp);
fprintf(stderr, "Could not load: %s\n", output);
return -1;
}
fclose(fp);
remove(tmp);
su_pushstring(s, argv[1]);
for (i = 2; i < argc; i++)
su_pushstring(s, argv[i]);
su_call(s, argc - 1, 1);
if (su_type(s, -1) == SU_NUMBER)
ret = (int)su_tonumber(s, -1);
}
}
lua_close(L);
su_close(s);
return ret;
}
