static void check_args(su_state *s, va_list arg, int start, int num) { int i; su_object_type_t a, b; for (i = start; num; i--, num--) { a = su_type(s, -i); b = va_arg(arg, su_object_type_t); if (b != SU_NIL) su_assert(s, a == b, "Expected argument %i to be of type '%s', but it is of type '%s'.", start - i, type_name(b), type_name(a)); } }
void su_unreg_reference(su_state *s, void *ref) { value_t key; unsigned hash; su_assert(s, s->main_state == s, MAIN_STATE_ONLY_MSG); key.type = SU_NATIVEPTR; key.obj.ptr = ref; hash = hash_value(&key); s->stack[SU_REGISTRY_INDEX] = map_remove(s, s->stack[SU_REGISTRY_INDEX].obj.m, &key, hash); s->stack_top--; }
void *su_allocate(su_state *s, void *p, size_t n) { void *np; if (n) { thread_interrupt(s, IGC); np = s->alloc(p, n); su_assert(s, np != NULL, "Out of memory!"); return np; } else { return s->alloc(p, 0); } }
void *su_reg_reference(su_state *s, int idx) { value_t key; unsigned hash; su_assert(s, s->main_state == s, MAIN_STATE_ONLY_MSG); key.type = SU_NATIVEPTR; key.obj.ptr = (void*)s->msi->ref_counter; hash = hash_value(&key); s->stack[SU_REGISTRY_INDEX] = map_insert(s, s->stack[SU_REGISTRY_INDEX].obj.m, &key, hash, STK(TOP(idx))); s->msi->ref_counter++; assert(s->msi->ref_counter); return key.obj.ptr; }
int su_clambda(su_state *s, su_nativefunc f) { value_t v; int id = s->msi->num_c_lambdas; su_assert(s, s->main_state == s, MAIN_STATE_ONLY_MSG); s->msi->c_lambdas = (value_t*)su_allocate(s, s->msi->c_lambdas, sizeof(value_t) * (++s->msi->num_c_lambdas)); if (f) { v.type = SU_NATIVEFUNC; v.obj.nfunc = f; s->msi->c_lambdas[id] = v; } else { s->msi->c_lambdas[id] = *STK(-1); s->stack_top--; } return id; }
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; }
void su_fork(su_state *s, int narg) { value_t v; su_state *ns; narg++; v.type = SU_BOOLEAN; su_thread_indisposable(s); spin_lock(&s->msi->thread_pool_lock); su_thread_disposable(s); ns = new_state(s); if (!ns) { s->stack_top -= narg; v.obj.b = 0; push_value(s, &v); spin_unlock(&s->msi->thread_pool_lock); return; } ns->interrupt = 0x0; ns->narg = narg - 1; ns->pc = 0xffff; ns->string_builder = NULL; ns->errtop = ns->ferrtop = -1; ns->stack[SU_GLOBAL_INDEX] = s->stack[SU_GLOBAL_INDEX]; su_assert(s, !thread_init(&thread_boot, (void*)ns), "Could not create thread!"); s->stack_top -= narg; v.obj.b = 1; push_value(s, &v); spin_unlock(&s->msi->thread_pool_lock); }
static int map_remove(su_state *s, int narg) { su_check_arguments(s, 2, SU_MAP, SU_NIL); su_assert(s, su_map_has(s, -3), "Key does not exist in map!"); su_map_remove(s, -1); return 1; }
static int map_insert(su_state *s, int narg) { su_check_arguments(s, 3, SU_MAP, SU_NIL, SU_NIL); su_assert(s, !su_map_has(s, -3), "Duplicated key in map!"); su_map_insert(s, -3); return 1; }
void su_check_type(su_state *s, int idx, su_object_type_t t) { value_t *v = STK(TOP(idx)); su_assert(s, t == SU_SEQ ? isseq(s, v) : v->type == t, "Bad argument: Expected %s, but got %s.", type_name(t), type_name((su_object_type_t)v->type)); }
void push_value(su_state *s, value_t *v) { su_assert(s, s->stack_top < STACK_SIZE, "Stack overflow!"); s->stack[s->stack_top++] = *v; }
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 } }
void su_check_num_arguments(su_state *s, int num) { su_assert(s, num == s->narg, "Bad number of arguments to function. Expected %i but got %i.", num, s->narg); }
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; }