refactor to analyze gc

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;