klisp

commit 245ffa2c3de091f1dd89084dbaec21695ad03bdc
parent a0a18b822a1db40ad80f20b024125668d9726713
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Mon, 28 Mar 2011 21:32:08 -0300

Added $letrec* to the ground environment. Small bugfix to $letrec (but didn't fail, so it's mostly stylistic)

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

3 files changed, 35 insertions(+), 4 deletions(-)
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -303,13 +303,44 @@ void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     TValue new_env = kmake_environment(K, denv);
     TValue new_cont = 
 	kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname, 
-			   bptree, KNIL, KNIL, new_env, b2tv(false), body);
+			   bptree, KNIL, KNIL, new_env, b2tv(true), body);
     kset_cc(K, new_cont);
     ktail_eval(K, kcons(K, K->list_app, exprs), new_env);
 }
 
 /* 6.7.6 $letrec* */
-/* TODO */
+void SletrecS(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, true);
+    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 $letrec */
+	TValue new_cont = 
+	    kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname, 
+			       bptree, KNIL, KNIL, new_env, b2tv(true), body);
+	kset_cc(K, new_cont);
+	ktail_eval(K, kcons(K, K->list_app, exprs), new_env);
+    } 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(true), body);
+	kset_cc(K, new_cont);
+	ktail_eval(K, kcar(exprs), new_env);
+    }
+}
 
 /* Helper for $let-redirect */
 void do_let_redirect(klisp_State *K, TValue *xparams, TValue obj)
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -56,7 +56,7 @@ void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 6.7.6 $letrec* */
-/* TODO */
+void SletrecS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* Helper for $let-redirect */
 void do_let_redirect(klisp_State *K, TValue *xparams, TValue obj);
diff --git a/src/kground.c b/src/kground.c
@@ -458,7 +458,7 @@ void kinit_ground_env(klisp_State *K)
     add_operative(K, ground_env, "$letrec", Sletrec, 1, symbol);
 
     /* 6.7.6 $letrec* */
-    /* TODO */
+    add_operative(K, ground_env, "$letrec*", SletrecS, 1, symbol);
 
     /* 6.7.7 $let-redirect */
     add_operative(K, ground_env, "$let-redirect", Slet_redirect, 1, symbol);