aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTeddy <ted.sybil@gmail.com>2013-08-13 14:49:18 +0800
committerTeddy <ted.sybil@gmail.com>2013-08-13 14:49:18 +0800
commitb215daca250b567d2b1a253c5019d94edf21d1cf (patch)
tree11e9956fcf2a11dee04f4a1d6a7e86589e09e5cf
parentba5fb7e4112bec20244586ac12285cfb25f2423f (diff)
parent2c48014df55c0e7b7b12ebff9bef8fe567a6d4d2 (diff)
Merge branch 'gc'
Conflicts: types.cpp
-rw-r--r--Makefile7
-rw-r--r--builtin.cpp334
-rw-r--r--consts.cpp3
-rw-r--r--consts.h3
-rw-r--r--eval.cpp28
-rw-r--r--gc.cpp113
-rw-r--r--gc.h32
-rw-r--r--main.cpp32
-rw-r--r--parser.cpp1
-rw-r--r--test/q.scm69
-rw-r--r--types.cpp373
-rw-r--r--types.h80
12 files changed, 794 insertions, 281 deletions
diff --git a/Makefile b/Makefile
index aeab6a0..37142aa 100644
--- a/Makefile
+++ b/Makefile
@@ -1,8 +1,8 @@
-sonsi: main.o parser.o builtin.o model.o eval.o exc.o consts.o types.o
+sonsi: main.o parser.o builtin.o model.o eval.o exc.o consts.o types.o gc.o
g++ -o sonsi $^ -pg -lgmp
.cpp.o:
- g++ $< -c -g -pg -DGMP_SUPPORT -Wall -O2
+ g++ $< -c -O2 -DGMP_SUPPORT -Wall
clean:
rm -f *.o
@@ -13,3 +13,6 @@ db:
cdb:
cgdb sonsi
+
+run:
+ ./sonsi
diff --git a/builtin.cpp b/builtin.cpp
index 8d3e21d..f1e4c19 100644
--- a/builtin.cpp
+++ b/builtin.cpp
@@ -7,6 +7,7 @@
#include "model.h"
#include "exc.h"
#include "types.h"
+#include "gc.h"
using std::stringstream;
@@ -45,7 +46,9 @@ Pair *SpecialOptIf::call(Pair *args, Environment * &envt,
{
if (ret_info->state == empty_list)
{
- *top_ptr++ = TO_PAIR(args->cdr)->car;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(TO_PAIR(args->cdr)->car);
+ gc.expose(args);
return ret_addr->next; // Move to the next instruction
}
else
@@ -59,30 +62,38 @@ Pair *SpecialOptIf::call(Pair *args, Environment * &envt,
{
second->next = NULL;
// Undo pop and invoke again
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = empty_list;
+ gc.expose(args);
return second;
}
else if (third != empty_list)
{
third->next = NULL;
// Undo pop and invoke again
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = empty_list;
+ gc.expose(args);
return third;
}
else
{
- *top_ptr++ = unspec_obj;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(unspec_obj);
+ gc.expose(args);
return ret_addr->next;
}
}
}
else
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(TO_PAIR(ret_addr->car)->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
throw NormalError(INT_ERR);
@@ -160,7 +171,9 @@ Pair *SpecialOptLambda::call(Pair *args, Environment * &envt,
for (Pair *ptr = body; ptr != empty_list; ptr = TO_PAIR(ptr->cdr))
ptr->next = NULL; // Make each expression isolated
- *top_ptr++ = new ProcObj(body, envt, params);
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(new ProcObj(body, envt, params));
+ gc.expose(args);
return ret_addr->next; // Move to the next instruction
}
@@ -195,9 +208,11 @@ Pair *SpecialOptDefine::call(Pair *args, Environment * &envt,
{
if (!ret_info->state)
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(TO_PAIR(pc->cdr)->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
if (!first->is_sym_obj())
@@ -233,7 +248,9 @@ Pair *SpecialOptDefine::call(Pair *args, Environment * &envt,
obj = new ProcObj(body, envt, params);
}
envt->add_binding(id, obj);
- *top_ptr++ = unspec_obj;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(unspec_obj);
+ gc.expose(args);
return ret_addr->next;
}
@@ -264,9 +281,11 @@ Pair *SpecialOptSet::call(Pair *args, Environment * &envt,
if (!ret_info->state)
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(TO_PAIR(pc->cdr)->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
@@ -277,7 +296,9 @@ Pair *SpecialOptSet::call(Pair *args, Environment * &envt,
bool flag = envt->add_binding(id, TO_PAIR(args->cdr)->car, false);
if (!flag) throw TokenError(id->ext_repr(), RUN_ERR_UNBOUND_VAR);
- *top_ptr++ = unspec_obj;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(unspec_obj);
+ gc.expose(args);
return ret_addr->next;
}
@@ -292,7 +313,9 @@ Pair *SpecialOptQuote::call(Pair *args, Environment * &envt,
Continuation * &cont, FrameObj ** &top_ptr) {
Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr;
Pair *pc = static_cast<Pair*>(ret_addr->car);
- *top_ptr++ = TO_PAIR(pc->cdr)->car;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(TO_PAIR(pc->cdr)->car);
+ gc.expose(args);
return ret_addr->next;
}
@@ -310,14 +333,20 @@ Pair *SpecialOptEval::call(Pair *args, Environment * &envt,
Pair *ret_addr = ret_info->addr;
if (ret_info->state)
{
- *top_ptr++ = TO_PAIR(args->cdr)->car;
+ gc.expose(ret_info->state); // Exec done
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(TO_PAIR(args->cdr)->car);
+ gc.expose(args);
return ret_addr->next; // Move to the next instruction
}
else
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(args->cdr);
+ gc.attach(ret_info->state); // Or it will be released
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
throw NormalError(INT_ERR);
@@ -336,14 +365,18 @@ Pair *SpecialOptAnd::call(Pair *args, Environment * &envt,
Pair *pc = static_cast<Pair*>(ret_addr->car);
if (pc->cdr == empty_list)
{
- *top_ptr++ = new BoolObj(true);
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(new BoolObj(true));
+ gc.expose(args);
return ret_addr->next;
}
if (!ret_info->state)
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(pc->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
EvalObj *ret = TO_PAIR(args->cdr)->car;
@@ -351,20 +384,26 @@ Pair *SpecialOptAnd::call(Pair *args, Environment * &envt,
{
if (ret_info->state->cdr == empty_list) // the last member
{
- *top_ptr++ = ret;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(ret);
+ gc.expose(args);
return ret_addr->next;
}
else
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(ret_info->state->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
}
else
{
- *top_ptr++ = ret;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(ret);
+ gc.expose(args);
return ret_addr->next;
}
throw NormalError(INT_ERR);
@@ -383,14 +422,18 @@ Pair *SpecialOptOr::call(Pair *args, Environment * &envt,
Pair *pc = static_cast<Pair*>(ret_addr->car);
if (pc->cdr == empty_list)
{
- *top_ptr++ = new BoolObj(false);
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(new BoolObj(false));
+ gc.expose(args);
return ret_addr->next;
}
if (!ret_info->state)
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(pc->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
EvalObj *ret = TO_PAIR(args->cdr)->car;
@@ -398,20 +441,26 @@ Pair *SpecialOptOr::call(Pair *args, Environment * &envt,
{
if (ret_info->state->cdr == empty_list) // the last member
{
- *top_ptr++ = ret;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(ret);
+ gc.expose(args);
return ret_addr->next;
}
else
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = TO_PAIR(ret_info->state->cdr);
ret_info->state->next = NULL;
+ gc.expose(args);
return ret_info->state;
}
}
else
{
- *top_ptr++ = ret;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(ret);
+ gc.expose(args);
return ret_addr->next;
}
throw NormalError(INT_ERR);
@@ -421,8 +470,9 @@ SpecialOptApply::SpecialOptApply() : SpecialOptObj("apply") {}
void SpecialOptApply::prepare(Pair *pc) {}
-Pair *SpecialOptApply::call(Pair *args, Environment * &envt,
+Pair *SpecialOptApply::call(Pair *_args, Environment * &envt,
Continuation * &cont, FrameObj ** &top_ptr) {
+ Pair *args = _args;
top_ptr++; // Recover the return address
if (args->cdr == empty_list)
throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
@@ -431,13 +481,13 @@ Pair *SpecialOptApply::call(Pair *args, Environment * &envt,
if (!args->car->is_opt_obj())
throw TokenError("an operator", RUN_ERR_WRONG_TYPE);
- *top_ptr++ = args->car; // Push the operator into the stack
- args = TO_PAIR(args->cdr); // Examine arguments
+ *top_ptr++ = gc.attach(args->car); // Push the operator into the stack
+ args = TO_PAIR(args->cdr); // Examine arguments
if (args == empty_list)
throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
for (; args->cdr != empty_list; args = TO_PAIR(args->cdr))
- *top_ptr++ = args->car; // Add leading arguments: arg_1 ...
+ *top_ptr++ = gc.attach(args->car); // Add leading arguments: arg_1 ...
if (args->car != empty_list) // args->car is the trailing args
{
@@ -448,7 +498,7 @@ Pair *SpecialOptApply::call(Pair *args, Environment * &envt,
EvalObj *nptr;
for (;;)
{
- *top_ptr++ = args->car;
+ *top_ptr++ = gc.attach(args->car);
if ((nptr = args->cdr)->is_pair_obj())
args = TO_PAIR(nptr);
else break;
@@ -457,6 +507,7 @@ Pair *SpecialOptApply::call(Pair *args, Environment * &envt,
throw TokenError("a list", RUN_ERR_WRONG_TYPE);
}
// force the invocation, so that the desired operator will take over
+ gc.expose(_args);
return NULL;
}
@@ -468,8 +519,9 @@ void SpecialOptForce::prepare(Pair *pc) {
throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
}
-Pair *SpecialOptForce::call(Pair *args, Environment * &envt,
+Pair *SpecialOptForce::call(Pair *_args, Environment * &envt,
Continuation * &cont, FrameObj ** &top_ptr) {
+ Pair *args = _args;
args = TO_PAIR(args->cdr);
RetAddr *ret_info = static_cast<RetAddr*>(*top_ptr);
Pair *ret_addr = ret_info->addr;
@@ -477,7 +529,9 @@ Pair *SpecialOptForce::call(Pair *args, Environment * &envt,
{
EvalObj *mem = args->car;
prom->feed_mem(mem);
- *top_ptr++ = mem;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(mem);
+ gc.expose(_args);
return ret_addr->next; // Move to the next instruction
}
else
@@ -488,14 +542,18 @@ Pair *SpecialOptForce::call(Pair *args, Environment * &envt,
EvalObj *mem = prom->get_mem();
if (mem) // fetch from memorized result
{
- *top_ptr++ = mem;
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(mem);
+ gc.expose(_args);
return ret_addr->next;
}
else // force
{
- top_ptr += 2;
+ gc.attach(static_cast<EvalObj*>(*(++top_ptr)));
+ top_ptr++;
ret_info->state = prom->get_entry();
ret_info->state->next = NULL;
+ gc.expose(_args);
return ret_info->state;
}
}
@@ -514,7 +572,9 @@ Pair *SpecialOptDelay::call(Pair *args, Environment * &envt,
Continuation * &cont, FrameObj ** &top_ptr) {
Pair *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr;
Pair *pc = static_cast<Pair*>(ret_addr->car);
- *top_ptr++ = new PromObj(TO_PAIR(pc->cdr)->car);
+ delete *top_ptr;
+ *top_ptr++ = gc.attach(new PromObj(TO_PAIR(pc->cdr)->car));
+ gc.expose(args);
return ret_addr->next; // Move to the next instruction
}
@@ -562,7 +622,7 @@ BUILTIN_PROC_DEF(pair_cdr) {
BUILTIN_PROC_DEF(make_list) {
- return args;
+ return gc.attach(args); // Or it will be GCed
}
BUILTIN_PROC_DEF(num_add) {
@@ -574,11 +634,16 @@ BUILTIN_PROC_DEF(num_add) {
throw TokenError("a number", RUN_ERR_WRONG_TYPE);
opr = static_cast<NumObj*>(args->car);
NumObj *_res = res;
- if (_res->level < opr->level)
- opr = _res->convert(opr);
+ if (res->level < opr->level)
+ {
+ res->add(opr = res->convert(opr));
+ delete opr;
+ }
else
- _res = opr->convert(_res);
- res = _res->add(opr);
+ {
+ (res = opr->convert(res))->add(opr);
+ delete _res;
+ }
}
return res;
}
@@ -589,12 +654,15 @@ BUILTIN_PROC_DEF(num_sub) {
throw TokenError("a number", RUN_ERR_WRONG_TYPE);
NumObj *res = static_cast<NumObj*>(args->car), *opr;
+ res = res->clone();
args = TO_PAIR(args->cdr);
if (args == empty_list)
{
- IntNumObj _zero(0);
- NumObj *zero = res->convert(&_zero);
- return zero->sub(res);
+ IntNumObj *_zero = new IntNumObj(0);
+ NumObj *zero = res->convert(_zero);
+ if (zero != _zero) delete _zero;
+ zero->sub(res);
+ return zero;
}
for (; args != empty_list; args = TO_PAIR(args->cdr))
{
@@ -603,16 +671,20 @@ BUILTIN_PROC_DEF(num_sub) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
NumObj *_res = res;
- if (_res->level < opr->level)
- opr = _res->convert(opr);
+ if (res->level < opr->level)
+ {
+ res->sub(opr = res->convert(opr));
+ delete opr;
+ }
else
- _res = opr->convert(_res);
- res = _res->sub(opr);
+ {
+ (res = opr->convert(res))->sub(opr);
+ delete _res;
+ }
}
return res;
}
-
BUILTIN_PROC_DEF(num_mul) {
// ARGS_AT_LEAST_ONE;
NumObj *res = new IntNumObj(1), *opr; // the most accurate type
@@ -622,11 +694,16 @@ BUILTIN_PROC_DEF(num_mul) {
throw TokenError("a number", RUN_ERR_WRONG_TYPE);
opr = static_cast<NumObj*>(args->car);
NumObj *_res = res;
- if (_res->level < opr->level)
- opr = _res->convert(opr);
+ if (res->level < opr->level)
+ {
+ res->mul(opr = res->convert(opr));
+ delete opr;
+ }
else
- _res = opr->convert(_res);
- res = _res->mul(opr);
+ {
+ (res = opr->convert(res))->mul(opr);
+ delete _res;
+ }
}
return res;
}
@@ -635,13 +712,20 @@ BUILTIN_PROC_DEF(num_div) {
ARGS_AT_LEAST_ONE;
if (!args->car->is_num_obj())
throw TokenError("a number", RUN_ERR_WRONG_TYPE);
+
NumObj *res = static_cast<NumObj*>(args->car), *opr;
+ if (res->level > NUM_LVL_RAT)
+ res = new RatNumObj(static_cast<IntNumObj*>(res)->val);
+ else res = res->clone();
+
args = TO_PAIR(args->cdr);
if (args == empty_list)
{
- IntNumObj _one(1);
- NumObj *one = res->convert(&_one);
- return one->div(res);
+ IntNumObj *_one = new IntNumObj(1);
+ NumObj *one = res->convert(_one);
+ if (one != _one) delete _one;
+ one->div(res);
+ return one;
}
for (; args != empty_list; args = TO_PAIR(args->cdr))
{
@@ -650,15 +734,21 @@ BUILTIN_PROC_DEF(num_div) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
NumObj *_res = res;
- if (_res->level < opr->level)
- opr = _res->convert(opr);
+ if (res->level < opr->level)
+ {
+ res->div(opr = res->convert(opr));
+ delete opr;
+ }
else
- _res = opr->convert(_res);
- res = _res->div(opr);
+ {
+ (res = opr->convert(res))->div(opr);
+ delete _res;
+ }
}
return res;
}
+
BUILTIN_PROC_DEF(num_le) {
if (args == empty_list)
return new BoolObj(true);
@@ -675,16 +765,28 @@ BUILTIN_PROC_DEF(num_le) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
if (last->level < opr->level)
- opr = last->convert(opr);
+ {
+ if (!last->le(opr = last->convert(opr)))
+ {
+ delete opr;
+ return new BoolObj(false);
+ }
+ else delete opr;
+ }
else
- last = opr->convert(last);
- if (!last->le(opr))
- return new BoolObj(false);
+ {
+ if (!(last = opr->convert(last))->le(opr))
+ {
+ delete last;
+ return new BoolObj(false);
+ }
+ else delete last;
+ }
}
return new BoolObj(true);
}
-BUILTIN_PROC_DEF(num_ge) {
+BUILTIN_PROC_DEF(num_lt) {
if (args == empty_list)
return new BoolObj(true);
// zero arguments
@@ -700,17 +802,28 @@ BUILTIN_PROC_DEF(num_ge) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
if (last->level < opr->level)
- opr = last->convert(opr);
+ {
+ if (!last->lt(opr = last->convert(opr)))
+ {
+ delete opr;
+ return new BoolObj(false);
+ }
+ else delete opr;
+ }
else
- last = opr->convert(last);
- if (!last->ge(opr))
- return new BoolObj(false);
+ {
+ if (!(last = opr->convert(last))->lt(opr))
+ {
+ delete last;
+ return new BoolObj(false);
+ }
+ else delete last;
+ }
}
return new BoolObj(true);
}
-
-BUILTIN_PROC_DEF(num_lt) {
+BUILTIN_PROC_DEF(num_ge) {
if (args == empty_list)
return new BoolObj(true);
// zero arguments
@@ -726,11 +839,23 @@ BUILTIN_PROC_DEF(num_lt) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
if (last->level < opr->level)
- opr = last->convert(opr);
+ {
+ if (!last->ge(opr = last->convert(opr)))
+ {
+ delete opr;
+ return new BoolObj(false);
+ }
+ else delete opr;
+ }
else
- last = opr->convert(last);
- if (!last->lt(opr))
- return new BoolObj(false);
+ {
+ if (!(last = opr->convert(last))->ge(opr))
+ {
+ delete last;
+ return new BoolObj(false);
+ }
+ else delete last;
+ }
}
return new BoolObj(true);
}
@@ -751,11 +876,23 @@ BUILTIN_PROC_DEF(num_gt) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
if (last->level < opr->level)
- opr = last->convert(opr);
+ {
+ if (!last->gt(opr = last->convert(opr)))
+ {
+ delete opr;
+ return new BoolObj(false);
+ }
+ else delete opr;
+ }
else
- last = opr->convert(last);
- if (!last->gt(opr))
- return new BoolObj(false);
+ {
+ if (!(last = opr->convert(last))->gt(opr))
+ {
+ delete last;
+ return new BoolObj(false);
+ }
+ else delete last;
+ }
}
return new BoolObj(true);
}
@@ -776,15 +913,28 @@ BUILTIN_PROC_DEF(num_eq) {
opr = static_cast<NumObj*>(args->car);
// upper type conversion
if (last->level < opr->level)
- opr = last->convert(opr);
+ {
+ if (!last->eq(opr = last->convert(opr)))
+ {
+ delete opr;
+ return new BoolObj(false);
+ }
+ else delete opr;
+ }
else
- last = opr->convert(last);
- if (!last->eq(opr))
- return new BoolObj(false);
+ {
+ if (!(last = opr->convert(last))->eq(opr))
+ {
+ delete last;
+ return new BoolObj(false);
+ }
+ else delete last;
+ }
}
return new BoolObj(true);
}
+
BUILTIN_PROC_DEF(bool_not) {
ARGS_EXACTLY_ONE;
return new BoolObj(!args->car->is_true());
@@ -1148,7 +1298,9 @@ BUILTIN_PROC_DEF(is_integer) {
BUILTIN_PROC_DEF(num_abs) {
ARGS_EXACTLY_ONE;
CHECK_NUMBER(args->car);
- return static_cast<NumObj*>(args->car)->abs();
+ NumObj* num = static_cast<NumObj*>(args->car)->clone();
+ num->abs();
+ return num;
}
BUILTIN_PROC_DEF(num_mod) {
@@ -1159,7 +1311,9 @@ BUILTIN_PROC_DEF(num_mod) {
NumObj* b = static_cast<NumObj*>(TO_PAIR(args->cdr)->car);
CHECK_INT(a);
CHECK_INT(b);
- return static_cast<IntNumObj*>(a)->mod(b);
+ NumObj* res = a->clone();
+ static_cast<IntNumObj*>(res)->mod(b);
+ return res;
}
BUILTIN_PROC_DEF(num_rem) {
@@ -1170,7 +1324,9 @@ BUILTIN_PROC_DEF(num_rem) {
NumObj* b = static_cast<NumObj*>(TO_PAIR(args->cdr)->car);
CHECK_INT(a);
CHECK_INT(b);
- return static_cast<IntNumObj*>(a)->rem(b);
+ NumObj* res = a->clone();
+ static_cast<IntNumObj*>(res)->rem(b);
+ return res;
}
BUILTIN_PROC_DEF(num_quo) {
@@ -1181,12 +1337,14 @@ BUILTIN_PROC_DEF(num_quo) {
NumObj* b = static_cast<NumObj*>(TO_PAIR(args->cdr)->car);
CHECK_INT(a);
CHECK_INT(b);
- return static_cast<IntNumObj*>(a)->quo(b);
+ NumObj* res = a->clone();
+ static_cast<IntNumObj*>(res)->div(b);
+ return res;
}
BUILTIN_PROC_DEF(num_gcd) {
// ARGS_AT_LEAST_ONE;
- NumObj *res = new IntNumObj(0);
+ IntNumObj *res = new IntNumObj(0);
IntNumObj *opr;
for (;args != empty_list; args = TO_PAIR(args->cdr))
{
@@ -1194,14 +1352,14 @@ BUILTIN_PROC_DEF(num_gcd) {
CHECK_INT(static_cast<NumObj*>(args->car));
opr = static_cast<IntNumObj*>(args->car);
- res = opr->gcd(res);
+ res->gcd(opr);
}
return res;
}
BUILTIN_PROC_DEF(num_lcm) {
// ARGS_AT_LEAST_ONE;
- NumObj *res = new IntNumObj(1);
+ IntNumObj *res = new IntNumObj(1);
IntNumObj *opr;
for (;args != empty_list; args = TO_PAIR(args->cdr))
{
@@ -1209,7 +1367,7 @@ BUILTIN_PROC_DEF(num_lcm) {
CHECK_INT(static_cast<NumObj*>(args->car));
opr = static_cast<IntNumObj*>(args->car);
- res = opr->lcm(res);
+ res->lcm(opr);
}
return res;
}
diff --git a/consts.cpp b/consts.cpp
index a04d5c7..fd835a4 100644
--- a/consts.cpp
+++ b/consts.cpp
@@ -19,5 +19,6 @@ const char *ERR_MSG[] = {
"Queue overflowed: the expected expansion is too long!",
"%s stack overflowed!",
"Numeric overflow!",
- "Value out of range"
+ "Value out of range",
+ "GC overflow!"
};
diff --git a/consts.h b/consts.h
index b24e951..10cd951 100644
--- a/consts.h
+++ b/consts.h
@@ -20,7 +20,8 @@ enum ErrCode {
RUN_ERR_QUEUE_OVERFLOW,
RUN_ERR_STACK_OVERFLOW,
RUN_ERR_NUMERIC_OVERFLOW,
- RUN_ERR_VALUE_OUT_OF_RANGE
+ RUN_ERR_VALUE_OUT_OF_RANGE,
+ RUN_ERR_GC_OVERFLOW
};
extern const char *ERR_MSG[];
diff --git a/eval.cpp b/eval.cpp
index 2f5921d..bf61b3e 100644
--- a/eval.cpp
+++ b/eval.cpp
@@ -2,6 +2,7 @@
#include "builtin.h"
#include "exc.h"
#include "consts.h"
+#include "gc.h"
#include <cstdio>
extern Pair *empty_list;
@@ -91,6 +92,7 @@ void Evaluator::add_builtin_routines() {
Evaluator::Evaluator() {
envt = new Environment(NULL); // Top-level Environment
+ gc.attach(envt);
add_builtin_routines();
}
@@ -113,8 +115,7 @@ inline void push(Pair * &pc, FrameObj ** &top_ptr, Environment *envt) {
// puts("oops");
if (pc->car->is_simple_obj()) // Not an opt invocation
{
- *top_ptr = envt->get_obj(pc->car); // Objectify the symbol
- top_ptr++;
+ *top_ptr++ = gc.attach(envt->get_obj(pc->car)); // Objectify the symbol
pc = pc->next; // Move to the next instruction
// if (pc == empty_list)
// puts("oops");
@@ -148,8 +149,12 @@ EvalObj *Evaluator::run_expr(Pair *prog) {
FrameObj **top_ptr = eval_stack;
Pair *pc = prog;
Continuation *cont = NULL;
+#ifdef GC_DEBUG
+ fprintf(stderr, "Start the evaluation...\n");
+#endif
// envt is this->envt
push(pc, top_ptr, envt);
+ gc.attach(prog);
while((*eval_stack)->is_ret_addr())
{
@@ -161,21 +166,34 @@ EvalObj *Evaluator::run_expr(Pair *prog) {
{
Pair *args = empty_list;
while (!(*(--top_ptr))->is_ret_addr())
- args = new Pair(static_cast<EvalObj*>(*top_ptr), args);
+ {
+ EvalObj* obj = static_cast<EvalObj*>(*top_ptr);
+ gc.expose(obj);
+ args = new Pair(obj, args);
+ }
//< static_cast because the while condition
RetAddr *ret_addr = static_cast<RetAddr*>(*top_ptr);
+ gc.attach(args);
if (!ret_addr->addr)
{
Pair *nexp = TO_PAIR(cont->proc_body->cdr);
cont->proc_body = nexp;
if (nexp == empty_list)
{
- *top_ptr = args->car;
+ *top_ptr = gc.attach(args->car);
+
+ gc.expose(envt);
envt = cont->envt;
+ gc.attach(envt);
+
pc = cont->pc->next;
+
+ gc.expose(cont);
cont = cont->prev_cont;
+ gc.attach(cont);
}
else pc = nexp;
+ gc.expose(args);
top_ptr++;
}
else
@@ -186,9 +204,11 @@ EvalObj *Evaluator::run_expr(Pair *prog) {
call(args, envt, cont, top_ptr);
else
throw TokenError(opt->ext_repr(), SYN_ERR_CAN_NOT_APPLY);
+ gc.force();
}
}
}
+ gc.expose(prog);
// static_cast because the previous while condition
return static_cast<EvalObj*>(*(eval_stack));
}
diff --git a/gc.cpp b/gc.cpp
new file mode 100644
index 0000000..13dfb3c
--- /dev/null
+++ b/gc.cpp
@@ -0,0 +1,113 @@
+#include "gc.h"
+#include "exc.h"
+#include "consts.h"
+
+#if defined(GC_DEBUG) || defined (GC_INFO)
+#include <cstdio>
+typedef unsigned long long ull;
+#endif
+
+static EvalObj *gcq[GC_QUEUE_SIZE];
+
+GarbageCollector::GarbageCollector() {
+ mapping.clear();
+ pend_cnt = 0;
+ pending_list = NULL;
+}
+
+GarbageCollector::PendingEntry::PendingEntry(
+ EvalObj *_obj, PendingEntry *_next) : obj(_obj), next(_next) {}
+
+
+void GarbageCollector::expose(EvalObj *ptr) {
+ bool flag = mapping.count(ptr);
+ if (flag)
+ {
+#ifdef GC_DEBUG
+ fprintf(stderr, "GC: 0x%llx exposed. count = %lu \"%s\"\n",
+ (ull)ptr, mapping[ptr] - 1, ptr->ext_repr().c_str());
+#endif
+ if (!--mapping[ptr])
+ {
+#ifdef GC_DEBUG
+ fprintf(stderr, "GC: 0x%llx pending. \n", (ull)ptr);
+#endif
+ pending_list = new PendingEntry(ptr, pending_list);
+ }
+ }
+}
+
+void GarbageCollector::force() {
+ EvalObj **l = gcq, **r = l;
+ for (PendingEntry *p = pending_list, *np; p; p = np)
+ {
+ np = p->next;
+ if (mapping[p->obj] == 0)
+ *r++ = p->obj;
+ delete p;
+ } // fetch the pending pointers in the list
+ // clear the list
+ pending_list = NULL;
+/* for (EvalObj2Int::iterator it = mapping.begin();
+ it != mapping.end(); it++)
+ if (it->second == 0) *r++ = it->first;*/
+
+#ifdef GC_INFO
+ fprintf(stderr, "%ld\n", mapping.size());
+ size_t cnt = 0;
+#endif
+#ifdef GC_DEBUG
+ fprintf(stderr,
+ "================================\n"
+ "GC: Forcing the clear process...\n");
+#endif
+ for (; l != r; l++)
+ {
+#ifdef GC_DEBUG
+ fprintf(stderr, "GC: !!! destroying space 0x%llx. \n", (ull)*l);
+#endif
+#ifdef GC_INFO
+ cnt++;
+#endif
+ delete *l;
+ mapping.erase(*l);
+ // maybe it's a complex structure,
+ // so that more pointers are reported
+ for (PendingEntry *p = pending_list, *np; p; p = np)
+ {
+ np = p->next;
+ *r++ = p->obj;
+ if (r == gcq + GC_QUEUE_SIZE)
+ throw NormalError(RUN_ERR_GC_OVERFLOW);
+ delete p;
+ }
+ pending_list = NULL;
+ }
+#ifdef GC_INFO
+ fprintf(stderr, "GC: Forced clear, %