klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

commit 2e9710546f1320ff63abf641f4b321f5ebc5a5c9
parent 674f30ad4cd197f01689b48f9046dfb2956eb6f9
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 24 Mar 2011 20:56:07 -0300

equal? now takes an arbitrary list of arguments. BUG: there seems to be a problem with marks in equal?... It show when comparing pairs with shared struct (copied with copy-es).

Diffstat:
Msrc/kgeqp.c | 1+
Msrc/kgequalp.c | 29+++++++++++++++++++++++++----
Msrc/kgequalp.h | 2+-
Msrc/kground.c | 3++-
4 files changed, 29 insertions(+), 6 deletions(-)

diff --git a/src/kgeqp.c b/src/kgeqp.c @@ -21,6 +21,7 @@ /* 4.2.1 eq? */ /* 6.5.1 eq? */ +/* NOTE: this does 2 passes but could do it in one */ void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { (void) denv; diff --git a/src/kgequalp.c b/src/kgequalp.c @@ -23,6 +23,7 @@ #include "kgequalp.h" /* 4.3.1 equal? */ +/* 6.6.1 equal? */ /* ** equal? is O(n) where n is the number of pairs. @@ -33,12 +34,32 @@ ** Idea to look up these papers from srfi 85: ** "Recursive Equivalence Predicates" by William D. Clinger */ -void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv) +void equalp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { (void) denv; - bind_2p(K, "equal?", ptree, obj1, obj2); - bool res = equal2p(K, obj1, obj2); - kapply_cc(K, b2tv(res)); + (void) xparams; + + int32_t cpairs; + int32_t pairs = check_list(K, "equal?", true, ptree, &cpairs); + + /* In this case we can get away without comparing the + first and last element on a cycle because equal? is + symetric, (cf: ftyped_bpred) */ + int32_t comps = pairs - 1; + TValue tail = ptree; + TValue res = KTRUE; + while(comps-- > 0) { /* comps could be -1 if ptree is nil */ + TValue first = kcar(tail); + tail = kcdr(tail); /* tail only advances one place per iteration */ + TValue second = kcar(tail); + + if (!equal2p(K, first, second)) { + res = KFALSE; + break; + } + } + + kapply_cc(K, res); } diff --git a/src/kgequalp.h b/src/kgequalp.h @@ -19,7 +19,7 @@ #include "kghelpers.h" /* 4.3.1 equal? */ -/* TEMP: for now it takes only two argument */ +/* 6.6.1 equal? */ void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv); /* Helper (may be used in assoc and member) */ diff --git a/src/kground.c b/src/kground.c @@ -95,6 +95,7 @@ void kinit_ground_env(klisp_State *K) */ /* 4.3.1 equal? */ + /* 6.6.1 equal? */ add_applicative(K, ground_env, "equal?", equalp, 0); /* @@ -434,7 +435,7 @@ void kinit_ground_env(klisp_State *K) */ /* 6.6.1 equal? */ - /* TODO */ + /* DONE: above, together with 4.3.1 */ /* ** 6.7 Environments