klisp

commit b92ab2d6f19f19944961ab508c32bd8b22cc6452
parent 15d5873d8647282b5137b001f7bf4cbc7e3f8637
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Tue, 29 Mar 2011 17:53:55 -0300

Added $binds? to the ground environment.

Diffstat:
M
src/kgenvironments.c
 | 
47
++++++++++++++++++++++++++++++++++++++++++++++-
M
src/kgenvironments.h
 | 
5
++++-
M
src/kghelpers.c
 | 
1
+
M
src/kground.c
 | 
2
+-
M
src/ksymbol.c
 | 
2
++
M
src/ksymbol.h
 | 
2
++

6 files changed, 56 insertions(+), 3 deletions(-)
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -223,8 +223,53 @@ void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     ktail_eval(K, kcons(K, K->list_app, exprs), denv);
 }
 
+/* Helper for $binds? */
+void do_bindsp(klisp_State *K, TValue *xparams, TValue obj)
+{
+    /*
+    ** xparams[0]: symbol list (may contain cycles)
+    ** xparams[1]: symbol list count
+    */
+    TValue symbols = xparams[0];
+    int32_t count = ivalue(xparams[1]);
+    
+    if (!ttisenvironment(obj)) {
+	klispE_throw(K, "$binds?: expected environment as first argument");
+	return;
+    }
+    TValue env = obj;
+    TValue res = KTRUE;
+
+    while(count--) {
+	TValue first = kcar(symbols);
+	symbols = kcdr(symbols);
+
+	if (!kbinds(K, env, first)) {
+	    res = KFALSE;
+	    break;
+	}
+    }
+
+    kapply_cc(K, res);
+}
+
 /* 6.7.1 $binds? */
-/* TODO */
+void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+    bind_al1p(K, "binds?", ptree, env_expr, symbols);
+
+    /* REFACTOR replace with single function check_copy_typed_list */
+    int32_t dummy;
+    int32_t count = check_typed_list(K, "$binds?", "symbol", ksymbolp, 
+				     true, symbols, &dummy);
+    symbols = check_copy_list(K, "$binds?", symbols);
+
+    TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_bindsp, 
+					 2, symbols, i2tv(count));
+    kset_cc(K, new_cont);
+    ktail_eval(K, env_expr, denv);
+}
 
 /* 6.7.2 get-current-environment */
 void get_current_environment(klisp_State *K, TValue *xparams, TValue ptree, 
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -38,8 +38,11 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
 /* 5.10.1 $let */
 void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
+/* Helper for $binds? */
+void do_bindsp(klisp_State *K, TValue *xparams, TValue obj);
+
 /* 6.7.1 $binds? */
-/* TODO */
+void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 6.7.2 get-current-environment */
 void get_current_environment(klisp_State *K, TValue *xparams, TValue ptree, 
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -176,6 +176,7 @@ void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     kapply_cc(K, b2tv(res));
 }
 
+/* TODO: allow NULL as argument to cpairs and avoid writing it in that case */
 /* typed finite list. Structure error should be throw before type errors */
 int32_t check_typed_list(klisp_State *K, char *name, char *typename,
 			 bool (*typep)(TValue), bool allow_infp, TValue obj,
diff --git a/src/kground.c b/src/kground.c
@@ -441,7 +441,7 @@ void kinit_ground_env(klisp_State *K)
     */
 
     /* 6.7.1 $binds? */
-    /* TODO */
+    add_operative(K, ground_env, "$binds?", Sbindsp, 0);
 
     /* 6.7.2 get-current-environment */
     add_applicative(K, ground_env, "get-current-environment", 
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -106,3 +106,5 @@ TValue ksymbol_new_check_i(klisp_State *K, TValue str)
     buf = kstring_buf(str);
     return ksymbol_new_g(K, buf, size, identifierp);
 }
+
+bool ksymbolp(TValue obj) { return ttissymbol(obj); }
diff --git a/src/ksymbol.h b/src/ksymbol.h
@@ -23,4 +23,6 @@ TValue ksymbol_new_check_i(klisp_State *K, TValue str);
 #define ksymbol_buf(tv_) (kstring_buf(tv2sym(tv_)->str))
 #define ksymbol_size(tv_) (kstring_size(tv2sym(tv_)->str))
 
+bool ksymbolp(TValue obj);
+
 #endif