klisp

commit 9c7a803586fd259ad5f0311a835ca2a484c94176
parent bd7a55436a6037228dd30b51dec164e85512a410
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 24 Mar 2011 20:40:56 -0300

eq? now takes an arbitrary list of arguments.

Diffstat:
M
src/kgeqp.c
 | 
25
+++++++++++++++++++++----
M
src/kgeqp.h
 | 
2
+-
M
src/kground.c
 | 
3
++-

3 files changed, 24 insertions(+), 6 deletions(-)
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -20,14 +20,31 @@
 #include "kgeqp.h"
 
 /* 4.2.1 eq? */
-/* TEMP: for now it takes only two argument */
+/* 6.5.1 eq? */
 void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 {
     (void) denv;
     (void) xparams;
 
-    bind_2p(K, "eq?", ptree, obj1, obj2);
+    int32_t cpairs;
+    int32_t pairs = check_list(K, "eq?", true, ptree, &cpairs);
 
-    bool res = eq2p(K, obj1, obj2);
-    kapply_cc(K, b2tv(res));
+    /* In this case we can get away without comparing the
+       first and last element on a cycle because eq? 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 (!eq2p(K, first, second)) {
+	    res = KFALSE;
+	    break;
+	}
+    }
+
+    kapply_cc(K, res);
 }
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -19,7 +19,7 @@
 #include "kghelpers.h"
 
 /* 4.2.1 eq? */
-/* TEMP: for now it takes only two argument */
+/* 6.5.1 eq? */
 void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* Helper (also used in equal?) */
diff --git a/src/kground.c b/src/kground.c
@@ -87,6 +87,7 @@ void kinit_ground_env(klisp_State *K)
     */
 
     /* 4.2.1 eq? */
+    /* 6.5.1 eq? */
     add_applicative(K, ground_env, "eq?", eqp, 0);
 
     /*
@@ -426,7 +427,7 @@ void kinit_ground_env(klisp_State *K)
     */
 
     /* 6.5.1 eq? */
-    /* TODO */
+    /* DONE: above, together with 4.2.1 */
 
     /*
     ** 6.6 Equivalance up to mutation