klisp

commit 29ed3d333ceadc141c25c5857f5e422d01cb5853
parent 8af5c4cbb5442030da5fe9fecd9fdeec9d1bbf76
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 25 Mar 2011 12:40:14 -0300

Added memq? to the ground environment.

Diffstat:
M
src/Makefile
 | 
2
+-
M
src/kgpair_mut.c
 | 
27
+++++++++++++++++++++++++--
M
src/kgpair_mut.h
 | 
4
++--
M
src/kground.c
 | 
4
++--

4 files changed, 30 insertions(+), 7 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -99,7 +99,7 @@ kgcontrol.o: kgcontrol.c kgcontrol.c kghelpers.h kstate.h klisp.h \
 kgpairs_lists.o: kgpairs_lists.c kgpairs_lists.h kghelpers.h kstate.h klisp.h \
 	kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h
 kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \
-	kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h
+	kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h kgeqp.h
 kgenvironments.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \
 	klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
 	kenvironment.h
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -19,6 +19,7 @@
 
 #include "kghelpers.h"
 #include "kgpair_mut.h"
+#include "kgeqp.h" /* eq? checking in memq and assq */
 
 /* 4.7.1 set-car!, set-cdr! */
 void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
@@ -228,5 +229,27 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
 /* 6.4.3 assq */
 /* TODO */
 
-/* 6.4.3 memq */
-/* TODO */
+/* 6.4.3 memq? */
+/* REFACTOR: do just one pass, maybe use generalized accum function */
+void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+    UNUSED(denv);
+
+    bind_2p(K, "memq", ptree, obj, ls);
+    /* first pass, check structure */
+    int32_t dummy;
+    int32_t pairs = check_list(K, "memq?", true, ls, &dummy);
+    TValue tail = ls;
+    TValue res = KFALSE;
+    while(pairs--) {
+	TValue first = kcar(tail);
+	if (eq2p(K, first, obj)) {
+	    res = KTRUE;
+	    break;
+	}
+	tail = kcdr(tail);
+    }
+
+    kapply_cc(K, res);
+}
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -47,7 +47,7 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
 /* 6.4.3 assq */
 /* TODO */
 
-/* 6.4.3 memq */
-/* TODO */
+/* 6.4.3 memq? */
+void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -420,8 +420,8 @@ void kinit_ground_env(klisp_State *K)
     /* 6.4.3 assq */
     /* TODO */
 
-    /* 6.4.3 memq */
-    /* TODO */
+    /* 6.4.3 memq? */
+    add_applicative(K, ground_env, "memq?", memqp, 0);
 
     /*
     ** 6.5 Equivalance under mutation