klisp

commit 8c939c60b96e90ffbb16ddf019c31fbdfba8c099
parent 4ca5065cfc87fcbae0e2e868ebe2b6974e98ceea
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Mon, 28 Mar 2011 19:18:17 -0300

Added $let* to the ground environment.

Diffstat:
M
src/kgenvironments.c
 | 
68
+++++++++++++++++++++++++++++++++++++++++++++++++++++---------------
M
src/kgenvironments.h
 | 
2
+-
M
src/kground.c
 | 
2
+-

3 files changed, 55 insertions(+), 17 deletions(-)
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -173,24 +173,31 @@ void do_let(klisp_State *K, TValue *xparams, TValue obj)
     
     /* XXX */
     UNUSED(recp);
-    UNUSED(bindings);
-    UNUSED(exprs);
 
     match(K, name, env, ptree, obj);
     
-    /* TODO: check bindings */
-    if (ttisnil(body)) {
-	kapply_cc(K, KINERT);
+    if (ttisnil(bindings)) {
+	if (ttisnil(body)) {
+	    kapply_cc(K, KINERT);
+	} else {
+	    /* this is needed because seq continuation doesn't check for 
+	       nil sequence */
+	    TValue tail = kcdr(body);
+	    if (ttispair(tail)) {
+		TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+						     do_seq, 2, tail, env);
+		kset_cc(K, new_cont);
+	    } 
+	    ktail_eval(K, kcar(body), env);
+	}
     } else {
-	/* this is needed because seq continuation doesn't check for 
-	   nil sequence */
-	TValue tail = kcdr(body);
-	if (ttispair(tail)) {
-	    TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
-						 do_seq, 2, tail, env);
-	    kset_cc(K, new_cont);
-	} 
-	ktail_eval(K, kcar(body), env);
+	TValue new_env = kmake_environment(K, env);
+	TValue new_cont = 
+	    kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname, 
+			       kcar(bindings), kcdr(bindings), kcdr(exprs), 
+			       new_env, b2tv(false), body);
+	kset_cc(K, new_cont);
+	ktail_eval(K, kcar(exprs), recp? new_env : env);
     }
 }
 
@@ -244,7 +251,38 @@ void make_kernel_standard_environment(klisp_State *K, TValue *xparams,
 }
 
 /* 6.7.4 $let* */
-/* TODO */
+void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    /*
+    ** xparams[0]: symbol name
+    */
+    TValue sname = xparams[0];
+    char *name = ksymbol_buf(sname);
+    bind_al1p(K, name, ptree, bindings, body);
+
+    TValue exprs;
+    TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+    int32_t dummy;
+    UNUSED(check_list(K, name, true, body, &dummy));
+    body = copy_es_immutable_h(K, name, body, false);
+
+    TValue new_env = kmake_environment(K, denv);
+    if (ttisnil(bptree)) {
+	/* same as $let */
+	TValue new_cont = 
+	    kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname, 
+			       bptree, KNIL, KNIL, new_env, b2tv(false), body);
+	kset_cc(K, new_cont);
+	ktail_eval(K, kcons(K, K->list_app, exprs), denv);
+    } else {
+	TValue new_cont = 
+	    kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname, 
+			       kcar(bptree), kcdr(bptree), kcdr(exprs), 
+			       new_env, b2tv(false), body);
+	kset_cc(K, new_cont);
+	ktail_eval(K, kcar(exprs), denv);
+    }
+}
 
 /* 6.7.5 $letrec */
 /* TODO */
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -50,7 +50,7 @@ void make_kernel_standard_environment(klisp_State *K, TValue *xparams,
 				      TValue ptree, TValue denv);
 
 /* 6.7.4 $let* */
-/* TODO */
+void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 6.7.5 $letrec */
 void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
diff --git a/src/kground.c b/src/kground.c
@@ -452,7 +452,7 @@ void kinit_ground_env(klisp_State *K)
 		    make_kernel_standard_environment, 0);
 
     /* 6.7.4 $let* */
-    /* TODO */
+    add_operative(K, ground_env, "$let*", SletS, 1, symbol);
 
     /* 6.7.5 $letrec */
     add_operative(K, ground_env, "$letrec", Sletrec, 1, symbol);