klisp

commit bb68806dbb11377290da23374a20b8c03b809fc0
parent b3bca47b867fb818debfd9a87d55b052a7b4d70e
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 25 Mar 2011 15:21:54 -0300

Added $set! to the ground environment.

Diffstat:
M
src/kgenv_mut.c
 | 
47
+++++++++++++++++++++++++++++++++++++++++++++++
M
src/kgenv_mut.h
 | 
12
++++++++++++
M
src/kground.c
 | 
2
+-

3 files changed, 60 insertions(+), 1 deletion(-)
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -55,3 +55,50 @@ void do_match(klisp_State *K, TValue *xparams, TValue obj)
     match(K, name, env, ptree, obj);
     kapply_cc(K, KINERT);
 }
+
+/* 6.8.1 $set! */
+void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(denv);
+
+    TValue sname = xparams[0];
+
+    bind_3p(K, "$set!", ptree, env_exp, raw_formals, eval_exp);
+
+    TValue formals = check_copy_ptree(K, "$set!", raw_formals, KIGNORE);
+
+    TValue new_cont = 
+	kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_set_eval_obj, 4, 
+			   sname, formals, eval_exp, denv);
+    kset_cc(K, new_cont);
+    ktail_eval(K, env_exp, denv);
+}
+
+/* Helpers for $set! */
+void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj)
+{
+    TValue sname = xparams[0];
+    TValue formals = xparams[1];
+    TValue eval_exp = xparams[2];
+    TValue denv = xparams[3];
+    
+    if (!ttisenvironment(obj)) {
+	klispE_throw_extra(K, ksymbol_buf(sname), ": bad type from first "
+			   "operand evaluation (expected environment)");
+	return;
+    } else {
+	TValue env = obj;
+
+	TValue new_cont = 
+	    kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_match, 3, 
+			       formals, env, sname);
+	kset_cc(K, new_cont);
+	ktail_eval(K, eval_exp, denv);
+    }
+}
+
+/* 6.8.2 $provide! */
+/* TODO */
+
+/* 6.8.3 $import! */
+/* TODO */
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -232,4 +232,16 @@ inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
     return copy;
 }
 
+/* 6.8.1 $set! */
+void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* Helper for $set! */
+void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj);
+
+/* 6.8.2 $provide! */
+/* TODO */
+
+/* 6.8.3 $import! */
+/* TODO */
+
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -478,7 +478,7 @@ void kinit_ground_env(klisp_State *K)
     */
 
     /* 6.8.1 $set! */
-    /* TODO */
+    add_operative(K, ground_env, "$set!", SsetB, 1, symbol);
 
     /* 6.8.2 $provide! */
     /* TODO */