klisp

commit 41b2e18fd58c07665ff97fee2d69dc7980b0d36d
parent 29ed3d333ceadc141c25c5857f5e422d01cb5853
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 25 Mar 2011 12:49:45 -0300

Added assq to the ground environment.

Diffstat:
M
src/kgpair_mut.c
 | 
24
+++++++++++++++++++++++-
M
src/kgpair_mut.h
 | 
2
+-
M
src/kground.c
 | 
2
+-
M
src/kpair.c
 | 
2
++
M
src/kpair.h
 | 
2
++

5 files changed, 29 insertions(+), 3 deletions(-)
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -227,7 +227,29 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
 /* uses copy_es helper (above copy-es-immutable) */
 
 /* 6.4.3 assq */
-/* TODO */
+void assq(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_typed_list(K, "assq", "pair", kpairp,
+				     true, ls, &dummy);
+    TValue tail = ls;
+    TValue res = KNIL;
+    while(pairs--) {
+	TValue first = kcar(tail);
+	if (eq2p(K, kcar(first), obj)) {
+	    res = first;
+	    break;
+	}
+	tail = kcdr(tail);
+    }
+
+    kapply_cc(K, res);
+}
 
 /* 6.4.3 memq? */
 /* REFACTOR: do just one pass, maybe use generalized accum function */
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -45,7 +45,7 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
 /* uses copy_es helper */
 
 /* 6.4.3 assq */
-/* TODO */
+void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 6.4.3 memq? */
 void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
diff --git a/src/kground.c b/src/kground.c
@@ -418,7 +418,7 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "copy-es", copy_es, 2, symbol, b2tv(true));
 
     /* 6.4.3 assq */
-    /* TODO */
+    add_applicative(K, ground_env, "assq", assq, 0);
 
     /* 6.4.3 memq? */
     add_applicative(K, ground_env, "memq?", memqp, 0);
diff --git a/src/kpair.c b/src/kpair.c
@@ -28,3 +28,5 @@ TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr)
 
     return gc2pair(new_pair);
 }
+
+bool kpairp(TValue obj) { return ttispair(obj); }
diff --git a/src/kpair.h b/src/kpair.h
@@ -61,4 +61,6 @@ TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr);
 #define kget_source_info(p_) (tv2pair(p_)->si)
 #define kset_source_info(p_, si_) (kget_source_info(p_) = (si_))
 
+bool kpairp(TValue obj);
+
 #endif