diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/builtins.c | 7 | ||||
| -rw-r--r-- | src/builtins.h | 1 | ||||
| -rw-r--r-- | src/interp.c | 92 | ||||
| -rw-r--r-- | src/primitives.c | 142 |
4 files changed, 179 insertions, 63 deletions
diff --git a/src/builtins.c b/src/builtins.c index abd2ae9..5ed285a 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -382,6 +382,13 @@ SExpRef builtin_ge(Interp *interp, SExpRef args) { } } +SExpRef builtin_gcstat(Interp *interp, SExpRef args) { + int heapsize = SExpVector_len(&interp->objs); + int freesize = IntVector_len(&interp->empty_space); + fprintf(stderr, "heapsize: %d, free: %d\n", heapsize, freesize); + return NIL; +} + SExpRef builtin_le(Interp *interp, SExpRef args) { int args_len = lisp_length(interp, args); if (args_len != 2) return new_error(interp, "<=: wrong argument number.\n"); diff --git a/src/builtins.h b/src/builtins.h index 4e4e39f..5ed9133 100644 --- a/src/builtins.h +++ b/src/builtins.h @@ -23,5 +23,6 @@ SExpRef builtin_lt(Interp *interp, SExpRef sexp); SExpRef builtin_ge(Interp *interp, SExpRef sexp); SExpRef builtin_le(Interp *interp, SExpRef sexp); SExpRef builtin_show(Interp *interp, SExpRef sexp); +SExpRef builtin_gcstat(Interp *interp, SExpRef sexp); #endif diff --git a/src/interp.c b/src/interp.c index a28df21..8aa4329 100644 --- a/src/interp.c +++ b/src/interp.c @@ -25,6 +25,7 @@ void Interp_init(Interp *self) { String2IntHashTable_init(&self->symbols); int i = 0; SExp sexp; + sexp.marked = false; sexp.type = kNilSExp; SExpVector_push_back(&self->objs, sexp); self->nil = (SExpRef){i}; i++; @@ -92,6 +93,7 @@ void Interp_init(Interp *self) { Interp_add_userfunc(self, ">=", builtin_ge); Interp_add_userfunc(self, "<=", builtin_le); Interp_add_userfunc(self, "not", builtin_not); + Interp_add_userfunc(self, "gcstat", builtin_gcstat); } void Interp_add_userfunc(Interp *interp, const char *name, LispUserFunc fn) { @@ -132,7 +134,72 @@ void Interp_add_primitive(Interp *self, const char *name, LispPrimitive fn) { } void Interp_gc(Interp *interp, SExpRef tmproot) { - // TODO + if (!IntVector_empty(&interp->empty_space)) { + return; + } + SExpRefVector gcstack; + SExpRefVector_init(&gcstack); + // add root + SExpRefVector_push_back(&gcstack, tmproot); + SExpRefVector_push_back(&gcstack, interp->nil); + SExpRefVector_push_back(&gcstack, interp->t); + SExpRefVector_push_back(&gcstack, interp->f); + SExpRefVector_push_back(&gcstack, interp->stack); + SExpRefVector_push_back(&gcstack, interp->top_level); + SExpRefVector_push_back(&gcstack, interp->reg); + // mark + while (!SExpRefVector_empty(&gcstack)) { + SExpRef ref = *SExpRefVector_last(&gcstack); + SExpRefVector_pop(&gcstack); + if (ref.idx < 0) continue; + SExp *obj = REF(ref); + if (obj->marked) continue; + obj->marked = true; + if (obj->type == kPairSExp) { + SExpRefVector_push_back(&gcstack, obj->pair.car); + SExpRefVector_push_back(&gcstack, obj->pair.cdr); + } else if (obj->type == kFuncSExp) { + SExpRefVector_push_back(&gcstack, obj->func.args); + SExpRefVector_push_back(&gcstack, obj->func.body); + SExpRefVector_push_back(&gcstack, obj->func.env); + } else if (obj->type == kEnvSExp) { + SExpRefVector_push_back(&gcstack, obj->env.bindings); + SExpRefVector_push_back(&gcstack, obj->env.parent); + } else if (obj->type == kBindingSExp) { + SExpRefVector_push_back(&gcstack, obj->binding.name); + SExpRefVector_push_back(&gcstack, obj->binding.value); + SExpRefVector_push_back(&gcstack, obj->binding.func); + SExpRefVector_push_back(&gcstack, obj->binding.next); + } else if (obj->type == kMacroSExp) { + SExpRefVector_push_back(&gcstack, obj->macro.args); + SExpRefVector_push_back(&gcstack, obj->macro.body); + } + } + SExpRefVector_free(&gcstack); + // sweep + for (int i = 0; i < SExpVector_len(&interp->objs); i++) { + SExp *obj = SExpVector_ref(&interp->objs, i); + if (obj->marked) { + obj->marked = false; + continue; + } + if (obj->type == kSymbolSExp) continue; + if (obj->type == kStringSExp) free((void*)obj->str); + obj->type = kEmptySExp; + IntVector_push_back(&interp->empty_space, i); + } + // enlarge heap + int heapsize = SExpVector_len(&interp->objs); + int usedsize = heapsize - IntVector_len(&interp->empty_space); + if (heapsize < usedsize * 2) { + SExp sexp; + sexp.marked = false; + sexp.type = kEmptySExp; + while (SExpVector_len(&interp->objs) < usedsize * 2) { + SExpVector_push_back(&interp->objs, sexp); + IntVector_push_back(&interp->empty_space, SExpVector_len(&interp->objs) - 1); + } + } } bool lisp_truep(Interp *interp, SExpRef a) { @@ -360,10 +427,12 @@ SExpRef lisp_reverse(Interp *interp, SExpRef lst) { SExpRef lisp_eval_args(Interp *interp, SExpRef args) { SExpRef ret = interp->nil; SExpRef cur = args; + SExpRef evalres; + while (!NILP(cur)) { // save ret in register PUSH_REG(ret); - SExpRef evalres = EVAL(CAR(cur)); + evalres = EVAL(CAR(cur)); POP_REG(); if (ERRORP(evalres)) { ret = evalres; @@ -416,14 +485,15 @@ static SExpRef build_function_env(Interp *interp, SExpRef func, SExpRef args) { } SExpRef lisp_apply(Interp *interp, SExpRef fn, SExpRef args) { + SExpRef exp, env, ret, iter; + if (VALTYPE(fn) == kFuncSExp) { - SExpRef env = build_function_env(interp, fn, args); + env = build_function_env(interp, fn, args); if (ERRORP(env)) return env; interp->stack = CONS(env, interp->stack); - SExpRef ret; - SExpRef iter = REF(fn)->func.body; + iter = REF(fn)->func.body; while (!NILP(iter)) { - SExpRef exp = CAR(iter); + exp = CAR(iter); ret = EVAL(exp); if (ERRORP(exp)) goto end; iter = CDR(iter); @@ -432,10 +502,8 @@ SExpRef lisp_apply(Interp *interp, SExpRef fn, SExpRef args) { interp->stack = CDR(interp->stack); return ret; } else if (VALTYPE(fn) == kUserFuncSExp) { - PUSH_REG(args); LispUserFunc fnptr = REF(fn)->userfunc; - SExpRef ret = (*fnptr)(interp, args); - POP_REG(); + ret = (*fnptr)(interp, args); return ret; } error: @@ -493,7 +561,10 @@ SExpRef lisp_eval(Interp *interp, SExpRef sexp) { } if (VALTYPE(fn) == kFuncSExp || VALTYPE(fn) == kUserFuncSExp) { SExpRef args = CDR(sexp); - ret = primitive_funcall(interp, CONS(fn, args)); + SExpRef funcallargs = CONS(fn, args); + PUSH_REG(funcallargs); + ret = primitive_funcall(interp, funcallargs); + POP_REG(); goto end; } else if (VALTYPE(fn) == kMacroSExp) { SExpRef args = CDR(sexp); @@ -515,6 +586,7 @@ SExpRef new_sexp(Interp *interp) { if (IntVector_len(&interp->empty_space) == 0) { SExp sexp; sexp.type = kEmptySExp; + sexp.marked = false; SExpVector_push_back(&interp->objs, sexp); return (SExpRef){ SExpVector_len(&interp->objs) - 1 }; } diff --git a/src/primitives.c b/src/primitives.c index 8958842..1cee577 100644 --- a/src/primitives.c +++ b/src/primitives.c @@ -3,10 +3,12 @@ #include "sexp.h" SExpRef primitive_if(Interp *interp, SExpRef args) { + SExpRef cond, tb, fb; + if (lisp_length(interp, args) != 3) goto error; - SExpRef cond = CAR(args); - SExpRef tb = CADR(args); - SExpRef fb = CADDR(args); + cond = CAR(args); + tb = CADR(args); + fb = CADDR(args); cond = EVAL(cond); if (ERRORP(cond)) return cond; if (TRUEP(cond)) return EVAL(tb); @@ -17,14 +19,16 @@ error: } SExpRef primitive_cond(Interp *interp, SExpRef args) { + SExpRef pair, condition, exp, iter; + if (lisp_length(interp, args) < 1) goto error; - SExpRef iter = args; + iter = args; while (!NILP(iter)) { - SExpRef pair = CAR(iter); + pair = CAR(iter); if (!lisp_check_list(interp, pair)) goto error; if (lisp_length(interp, pair) != 2) goto error; - SExpRef condition = CAR(pair); - SExpRef exp = CADR(pair); + condition = CAR(pair); + exp = CADR(pair); condition = EVAL(condition); if (ERRORP(condition)) return condition; if (TRUEP(condition)) return EVAL(exp); @@ -38,6 +42,7 @@ error: SExpRef primitive_progn(Interp *interp, SExpRef args) { SExpRef iter = args; SExpRef ret; + while (!NILP(iter)) { ret = EVAL(CAR(iter)); if (ERRORP(ret)) return ret; @@ -47,11 +52,13 @@ SExpRef primitive_progn(Interp *interp, SExpRef args) { } SExpRef primitive_setq(Interp *interp, SExpRef args) { + SExpRef name, exp, value; + if (lisp_length(interp, args) != 2) goto error; - SExpRef name = CAR(args); - SExpRef exp = CADR(args); + name = CAR(args); + exp = CADR(args); if (REF(name)->type != kSymbolSExp) goto error; - SExpRef value = EVAL(exp); + value = EVAL(exp); if (ERRORP(value)) return value; return lisp_setq(interp, REF(name)->str, value); error: @@ -65,6 +72,7 @@ static const char *binding_name(Interp *interp, SExpRef binding) { static bool is_binding_repeat(Interp *interp, SExpRef sym, SExpRef env) { SExpRef binding = REF(env)->env.bindings; + while (!NILP(binding)) { if (strcmp(REF(sym)->str, binding_name(interp, binding)) == 0) return true; binding = REF(binding)->binding.next; @@ -73,40 +81,43 @@ static bool is_binding_repeat(Interp *interp, SExpRef sym, SExpRef env) { } SExpRef primitive_let(Interp *interp, SExpRef args) { + SExpRef binding, iter, bindings, env, x, + val, body, ret, exp; + if (lisp_length(interp, args) < 1) goto error; - SExpRef bindings = CAR(args); - SExpRef env = new_env(interp); + bindings = CAR(args); + env = new_env(interp); REF(env)->env.parent = CAR(interp->stack); - SExpRef iter = bindings; + iter = bindings; while (!NILP(iter)) { - SExpRef x = CAR(iter); + x = CAR(iter); if (!lisp_check_list(interp, x)) goto error; if (lisp_length(interp, x) != 2) goto error; if (REF(CAR(x))->type != kSymbolSExp) goto error; if (is_binding_repeat(interp, CAR(x), env)) goto error; - SExpRef binding = new_binding(interp, CAR(x), NIL); + binding = new_binding(interp, CAR(x), NIL); REF(binding)->binding.next = REF(env)->env.bindings; REF(env)->env.bindings = binding; iter = CDR(iter); } interp->stack = CONS(env, interp->stack); - SExpRef ret = NIL; + ret = NIL; iter = bindings; while (!NILP(iter)) { - SExpRef x = CAR(iter); - SExpRef val = EVAL(CADR(x)); + x = CAR(iter); + val = EVAL(CADR(x)); if (REF(val)->type == kErrSExp) goto end; ret = lisp_setq(interp, REF(CAR(x))->str, val); if (ERRORP(ret)) goto end; iter = CDR(iter); } - SExpRef body = CDR(args); + body = CDR(args); iter = body; while (!NILP(iter)) { - SExpRef exp = CAR(iter); + exp = CAR(iter); ret = EVAL(exp); if (REF(ret)->type == kErrSExp) goto end; iter = CDR(iter); @@ -120,17 +131,19 @@ error: } SExpRef primitive_while(Interp *interp, SExpRef args) { + SExpRef ret, pred, body, cond, iter, x; + if (lisp_length(interp, args) < 2) goto error; - SExpRef ret = NIL; - SExpRef pred = CAR(args); - SExpRef body = CDR(args); + ret = NIL; + pred = CAR(args); + body = CDR(args); while (1) { - SExpRef cond = EVAL(pred); + cond = EVAL(pred); if (ERRORP(cond)) return cond; if (!TRUEP(cond)) return ret; - SExpRef iter = body; + iter = body; while (!NILP(iter)) { - SExpRef x = CAR(iter); + x = CAR(iter); ret = EVAL(x); if (ERRORP(ret)) return ret; iter = CDR(iter); @@ -141,40 +154,46 @@ error: } SExpRef primitive_lambda(Interp *interp, SExpRef args) { + SExpRef env, param, body; + if (lisp_length(interp, args) < 2) goto error; - SExpRef env = CAR(interp->stack); - SExpRef param = CAR(args); - SExpRef body = CDR(args); + env = CAR(interp->stack); + param = CAR(args); + body = CDR(args); return new_lambda(interp, param, body, env); error: return new_error(interp, "lambda: syntax error.\n"); } SExpRef primitive_defun(Interp *interp, SExpRef args) { + SExpRef name, param, body, function; + if (lisp_length(interp, args) < 3) goto error; if (CAR(interp->stack).idx != interp->top_level.idx) { return new_error(interp, "defun: functions can only be defined in top level.\n"); } - SExpRef name = CAR(args); + name = CAR(args); if (VALTYPE(name) != kSymbolSExp) goto error; - SExpRef param = CADR(args); - SExpRef body = CDDR(args); - SExpRef function = new_lambda(interp, param, body, interp->top_level); + param = CADR(args); + body = CDDR(args); + function = new_lambda(interp, param, body, interp->top_level); lisp_defun(interp, REF(name)->str, function); return name; error: return new_error(interp, "defun: syntax error.\n"); } SExpRef primitive_defmacro(Interp *interp, SExpRef args) { + SExpRef param, name, body, macro; + if (lisp_length(interp, args) < 3) goto error; if (CAR(interp->stack).idx != interp->top_level.idx) { return new_error(interp, "defmacro: macros can only be defined in top level.\n"); } - SExpRef name = CAR(args); + name = CAR(args); if (VALTYPE(name) != kSymbolSExp) goto error; - SExpRef param = CADR(args); - SExpRef body = CDDR(args); - SExpRef macro = new_macro(interp, param, body); + param = CADR(args); + body = CDDR(args); + macro = new_macro(interp, param, body); lisp_defun(interp, REF(name)->str, macro); return name; error: @@ -182,14 +201,16 @@ error: } SExpRef primitive_defvar(Interp *interp, SExpRef args) { + SExpRef name, exp, val; + if (lisp_length(interp, args) != 2) goto error; if (CAR(interp->stack).idx != interp->top_level.idx) { return new_error(interp, "defvar: functions can only be defined in top level.\n"); } - SExpRef name = CAR(args); + name = CAR(args); if (VALTYPE(name) != kSymbolSExp) goto error; - SExpRef exp = CADR(args); - SExpRef val = EVAL(exp); + exp = CADR(args); + val = EVAL(exp); if (ERRORP(val)) return val; lisp_defvar(interp, REF(name)->str, val); return name; @@ -210,19 +231,21 @@ static SExpRef build_function_env(Interp *interp, SExpRef func, SExpRef args) { SExpRef iparam = param; SExpRef iargs = args; SExpRef env = new_env(interp); + SExpRef binding, name; + while (!NILP(iparam)) { if (VALTYPE(iparam) == kSymbolSExp) { - SExpRef binding = new_binding(interp, iparam, iargs); + binding = new_binding(interp, iparam, iargs); REF(binding)->binding.next = REF(env)->env.bindings; REF(env)->env.bindings = binding; return env; } - SExpRef name = CAR(iparam); + name = CAR(iparam); if (VALTYPE(name) != kSymbolSExp) { return new_error(interp, "function syntax error: parameter must be a symbol.\n"); } if (NILP(iargs)) return new_error(interp, "funcall: wrong argument number.\n"); - SExpRef binding = new_binding(interp, name, CAR(iargs)); + binding = new_binding(interp, name, CAR(iargs)); REF(binding)->binding.next = REF(env)->env.bindings; REF(env)->env.bindings = binding; iargs = CDR(iargs); @@ -247,10 +270,12 @@ SExpRef primitive_quote(Interp *interp, SExpRef args) { } SExpRef primitive_macroexpand1(Interp *interp, SExpRef args) { + SExpRef macro; + if (lisp_length(interp, args) != 1) goto error; args = CAR(args); if (VALTYPE(CAR(args)) != kSymbolSExp) goto error; - SExpRef macro = lisp_lookup_func(interp, REF(CAR(args))->str); + macro = lisp_lookup_func(interp, REF(CAR(args))->str); if (VALTYPE(macro) != kMacroSExp) goto error; return lisp_macroexpand1(interp, macro, CDR(args)); error: @@ -258,11 +283,16 @@ error: } SExpRef primitive_apply(Interp *interp, SExpRef args) { + SExpRef ret; + if (lisp_length(interp, args) != 2) goto error; args = lisp_eval_args(interp, args); if (ERRORP(args)) return args; if (!lisp_check_list(interp, CADR(args))) goto error; - return lisp_apply(interp, CAR(args), CADR(args)); + PUSH_REG(args); + ret = lisp_apply(interp, CAR(args), CADR(args)); + POP_REG(); + return ret; error: return new_error(interp, "apply: syntax error.\n"); } @@ -271,6 +301,8 @@ static SExpRef quasi_on_list(Interp *interp, SExpRef lst); static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing); static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing) { + SExpRef lst; + *slicing = false; if (VALTYPE(obj) != kPairSExp) return obj; if (VALTYPE(CAR(obj)) == kSymbolSExp @@ -282,7 +314,7 @@ static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing) { } if (VALTYPE(CAR(obj)) == kSymbolSExp && strcmp("slicing-unquote", REF(CAR(obj))->str) == 0) { - SExpRef lst = EVAL(CADR(obj)); + lst = EVAL(CADR(obj)); if (ERRORP(lst)) return lst; if (lisp_length(interp, obj) != 2) { return new_error(interp, "slicing-unquote: syntax error.\n"); @@ -298,14 +330,16 @@ static SExpRef quasi_impl(Interp *interp, SExpRef obj, bool *slicing) { static SExpRef quasi_on_list(Interp *interp, SExpRef lst) { SExpRef newlst = NIL; + SExpRef iter, j, x, newx; + bool slicing; - SExpRef iter = lst; + iter = lst; while (!NILP(iter)) { - SExpRef x = CAR(iter); - SExpRef newx = quasi_impl(interp, x, &slicing); + x = CAR(iter); + newx = quasi_impl(interp, x, &slicing); if (ERRORP(newx)) return newx; if (slicing) { - SExpRef j = newx; + j = newx; while (!NILP(j)) { newlst = CONS(CAR(j), newlst); j = CDR(j); @@ -320,17 +354,18 @@ static SExpRef quasi_on_list(Interp *interp, SExpRef lst) { } SExpRef primitive_quasi(Interp *interp, SExpRef args) { + SExpRef ret; if (lisp_length(interp, args) != 1) return new_error(interp, "quasiquote: syntax error.\n"); bool slicing; - SExpRef ret = quasi_impl(interp, CAR(args), &slicing); + ret = quasi_impl(interp, CAR(args), &slicing); if (slicing) return new_error(interp, "quasiquote: syntax error.\n"); return ret; } SExpRef primitive_and(Interp *interp, SExpRef args) { - if (lisp_length(interp, args) < 1) return new_error(interp, "and: syntax error.\n"); SExpRef ret; SExpRef i = args; + if (lisp_length(interp, args) < 1) return new_error(interp, "and: syntax error.\n"); while (!NILP(i)) { ret = EVAL(CAR(i)); if (!TRUEP(ret)) return ret; @@ -340,9 +375,10 @@ SExpRef primitive_and(Interp *interp, SExpRef args) { } SExpRef primitive_or(Interp *interp, SExpRef args) { - if (lisp_length(interp, args) < 1) return new_error(interp, "or: syntax error.\n"); SExpRef ret; SExpRef i = args; + + if (lisp_length(interp, args) < 1) return new_error(interp, "or: syntax error.\n"); while (!NILP(i)) { ret = EVAL(CAR(i)); if (TRUEP(ret)) return ret; |