commit 1f3aab1d158d6149314883a315a38bc2380ebf6f
parent bb68806dbb11377290da23374a20b8c03b809fc0
Author: Andres Navarro <canavarro82@gmail.com>
Date: Mon, 28 Mar 2011 14:55:57 -0300
Added some preliminary work for the $let family of operatives.
Diffstat:
4 files changed, 104 insertions(+), 5 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -102,7 +102,7 @@ kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h kgeqp.h
kgenvironments.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
- kenvironment.h
+ kenvironment.h kgenv_mut.h kgpair_mut.h
kgenv_mut.o: kgenv_mut.c kgenv_mut.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
kenvironment.h
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -20,6 +20,9 @@
#include "kghelpers.h"
#include "kgenvironments.h"
+#include "kgenv_mut.h" /* for check_ptree */
+#include "kgpair_mut.h" /* for copy_es_immutable_h */
+/* MAYBE: move the above to kghelpers.h */
/* 4.8.1 environment? */
/* uses typep */
@@ -68,8 +71,102 @@ void make_environment(klisp_State *K, TValue *xparams, TValue ptree,
}
}
+/* Helpers for all the let family */
+
+/*
+** The split-let-bindings function has two cases:
+** the 'lets' with a star ($let* and $letrec) allow repeated symbols
+** in different bidings (each binding is a different ptree whereas
+** in $let, $letrec, $let-redirect and $let-safe, all the bindings
+** are collected in a single ptree).
+** In both cases the value returned is a list of cars of bindings and
+** exprs is modified to point to a list of cadrs of bindings.
+** The ptrees are copied as by copy-es-immutable (as with $vau & $lambda)
+** If bindings is not finite (or not a list) an error is signaled.
+*/
+
+TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
+ TValue *exprs, bool starp)
+{
+ TValue dummy_cars = kcons(K, KNIL, KNIL);
+ TValue last_car_pair = dummy_cars;
+ TValue dummy_cadrs = kcons(K, KNIL, KNIL);
+ TValue last_cadr_pair = dummy_cadrs;
+
+ TValue tail = bindings;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ kmark(tail);
+ TValue first = kcar(tail);
+ if (!ttispair(first) || !ttispair(kcdr(first)) ||
+ !ttisnil(kcddr(first))) {
+ unmark_list(K, bindings);
+ klispE_throw_extra(K, name, ": bad structure in bindings");
+ return KNIL;
+ }
+
+ TValue new_car = kcons(K, kcar(first), KNIL);
+ kset_cdr(last_car_pair, new_car);
+ last_car_pair = new_car;
+ TValue new_cadr = kcons(K, kcadr(first), KNIL);
+ kset_cdr(last_cadr_pair, new_cadr);
+ last_cadr_pair = new_cadr;
+
+ tail = kcdr(tail);
+ }
+
+ unmark_list(K, bindings);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_extra(K, name, ": expected list");
+ return KNIL;
+ } else if(ttispair(tail)) {
+ klispE_throw_extra(K, name , ": expected finite list");
+ return KNIL;
+ } else {
+ *exprs = kcdr(dummy_cadrs);
+ TValue res;
+ if (starp) {
+ /* all bindings are consider individual ptrees in these 'let's,
+ replace each ptree with its copy (after checking of course) */
+ tail = kcdr(dummy_cars);
+ while(!ttisnil(tail)) {
+ TValue first = kcar(tail);
+ TValue copy = check_copy_ptree(K, name, first, KIGNORE);
+ kset_car(tail, copy);
+ tail = kcdr(tail);
+ }
+ res = kcdr(dummy_cars);
+ } else {
+ /* all bindings are consider one ptree in these 'let's */
+ res = check_copy_ptree(K, name, kcdr(dummy_cars), KIGNORE);
+ }
+ return res;
+ }
+}
+
/* 5.10.1 $let */
-/* TODO */
+/* TEMP: for now this only checks the parameters and makes copies */
+/* XXX: it doesn't do any evaluation or env creation */
+void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ /*
+ ** xparams[0]: symbol name
+ */
+ UNUSED(denv);
+ char *name = ksymbol_buf(xparams[0]);
+ bind_al1p(K, name, ptree, bindings, body);
+
+ TValue exprs;
+ TValue btree = 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);
+
+ /* XXX */
+ TValue res = kcons(K, btree, kcons(K, exprs, body));
+ kapply_cc(K, res);
+}
/* 6.7.1 $binds? */
/* TODO */
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -32,8 +32,11 @@ void eval(klisp_State *K, TValue *xparams, TValue ptree,
void make_environment(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
+/* Helpers for all $let family */
+TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
+ TValue *exprs, bool starp);
/* 5.10.1 $let */
-/* TODO */
+void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 6.7.1 $binds? */
/* TODO */
diff --git a/src/kground.c b/src/kground.c
@@ -337,8 +337,7 @@ void kinit_ground_env(klisp_State *K)
*/
/* 5.10.1 $let */
- /* TODO */
-
+ add_operative(K, ground_env, "$let", Slet, 1, symbol);
/*
**
