commit f5084f890c92f547b2c2e0970d68b11c222d4451
parent b92ab2d6f19f19944961ab508c32bd8b22cc6452
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 29 Mar 2011 18:50:07 -0300
Added $cond to the ground environment.
Diffstat:
3 files changed, 147 insertions(+), 3 deletions(-)
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -106,5 +106,143 @@ void do_seq(klisp_State *K, TValue *xparams, TValue obj)
ktail_eval(K, first, denv);
}
+/* Helpers for cond */
+
+/*
+** Check the clauses structure.
+** Each should be a list of at least 1 element.
+** Return both a copied list of tests (only list structure is copied)
+** and a copied list of bodies (only list structure is copied, see comment
+** on $sequence, cf. $let, $vau and $lambda)
+** Throw errors if any of the above mentioned checks fail.
+*/
+TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
+ TValue *bodies)
+{
+ TValue dummy_cars = kcons(K, KNIL, KNIL);
+ TValue last_car_pair = dummy_cars;
+ TValue dummy_cdrs = kcons(K, KNIL, KNIL);
+ TValue last_cdr_pair = dummy_cdrs;
+
+ TValue tail = clauses;
+ int32_t count = 0;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ count++;
+ TValue first = kcar(tail);
+ if (!ttispair(first)) {
+ unmark_list(K, clauses);
+ klispE_throw(K, "$cond: bad structure in clauses");
+ return KNIL;
+ }
+
+ TValue new_car = kcons(K, kcar(first), KNIL);
+ kset_cdr(last_car_pair, new_car);
+ last_car_pair = new_car;
+ /* bodies have to be checked later */
+ TValue new_cdr = kcons(K, kcdr(first), KNIL);
+ kset_cdr(last_cdr_pair, new_cdr);
+ last_cdr_pair = new_cdr;
+
+ kset_mark(tail, kcons(K, new_car, new_cdr));
+ tail = kcdr(tail);
+ }
+
+ /* complete the cycles before unmarking */
+ if (ttispair(tail)) {
+ TValue mark = kget_mark(tail);
+ kset_cdr(last_car_pair, kcar(mark));
+ kset_cdr(last_cdr_pair, kcdr(mark));
+ }
+
+ unmark_list(K, clauses);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw(K, "$cond: expected list (clauses)");
+ return KNIL;
+ } else {
+
+ tail = kcdr(dummy_cdrs);
+ /*
+ check all the bodies (should be lists), and
+ make a copy of the list structure.
+ couldn't be done before because this uses
+ marks, count is used because it may be a cyclic list
+ */
+ while(count--) {
+ TValue first = kcar(tail);
+ TValue copy = check_copy_list(K, "$cond", first);
+ kset_car(tail, copy);
+ tail = kcdr(tail);
+ }
+ *bodies = kcdr(dummy_cdrs);
+ return kcdr(dummy_cars);
+ }
+}
+
+/* Helper for the $cond continuation */
+void do_cond(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: the body corresponding to obj
+ ** xparams[1]: remaining tests
+ ** xparams[2]: remaining bodies
+ ** xparams[3]: dynamic environment
+ */
+ TValue this_body = xparams[0];
+ TValue tests = xparams[1];
+ TValue bodies = xparams[2];
+ TValue denv = xparams[3];
+
+ if (!ttisboolean(obj)) {
+ klispE_throw(K, "$cond: test evaluated to a non boolean value");
+ return;
+ } else if (bvalue(obj)) {
+ if (ttisnil(this_body)) {
+ kapply_cc(K, KINERT);
+ } else {
+ TValue tail = kcdr(this_body);
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ do_seq, 2, tail, denv);
+ kset_cc(K, new_cont);
+ }
+ ktail_eval(K, kcar(this_body), denv);
+ }
+ } else {
+ /* check next clause if there is any*/
+ if (ttisnil(tests)) {
+ kapply_cc(K, KINERT);
+ } else {
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_cond, 4,
+ kcar(bodies), kcdr(tests), kcdr(bodies),
+ denv);
+ kset_cc(K, new_cont);
+ ktail_eval(K, kcar(tests), denv);
+ }
+ }
+}
+
/* 5.6.1 $cond */
-/* TODO */
+void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) xparams;
+
+ TValue bodies;
+ TValue tests = split_check_cond_clauses(K, ptree, &bodies);
+
+ TValue obj;
+ if (ttisnil(tests)) {
+ obj = KINERT;
+ } else {
+ /* pass a dummy body and a #f to the $cond continuation to
+ avoid code repetition here */
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_cond, 4,
+ KNIL, tests, bodies, denv);
+ kset_cc(K, new_cont);
+ obj = KFALSE;
+ }
+ kapply_cc(K, obj);
+}
diff --git a/src/kgcontrol.h b/src/kgcontrol.h
@@ -31,7 +31,13 @@ void Sif(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 5.1.1 $sequence */
void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* Helpers for $cond */
+TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
+ TValue *bodies);
+
+void do_cond(klisp_State *K, TValue *xparams, TValue obj);
+
/* 5.6.1 $cond */
-/* TODO */
+void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
#endif
diff --git a/src/kground.c b/src/kground.c
@@ -306,7 +306,7 @@ void kinit_ground_env(klisp_State *K)
*/
/* 5.6.1 $cond */
- /* TODO */
+ add_operative(K, ground_env, "$cond", Scond, 0);
/*
** 5.7 Pairs and lists
