klisp

commit c0373129054cf7a061dbf05ba70eb4a9e8fe668f
parent c7e6f2e9617569ec54e02446714d60001cbdf0df
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Wed, 30 Mar 2011 15:20:40 -0300

Added $provide! to the ground environment.

Diffstat:
M
src/Makefile
 | 
2
+-
M
src/kgenv_mut.c
 | 
42
++++++++++++++++++++++++++++++++++++++++--
M
src/kgenv_mut.h
 | 
9
+++++----
M
src/kground.c
 | 
2
+-

4 files changed, 47 insertions(+), 8 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -106,7 +106,7 @@ kgenvironments.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \
 	kenvironment.h kgenv_mut.h kgpair_mut.h kgcontrol.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
+	kenvironment.h kgcontrol.h
 kgcombiners.o: kgcombiners.c kgenvironments.h kghelpers.h kstate.h \
 	klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
 	kenvironment.h kapplicative.h koperative.h kgpair_mut.h
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -20,6 +20,7 @@
 
 #include "kghelpers.h"
 #include "kgenv_mut.h"
+#include "kgcontrol.h" /* for do_seq */
 
 /* 4.9.1 $define! */
 void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
@@ -132,7 +133,7 @@ TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
     while(ttispair(tail) && !kis_marked(tail)) {
 	/* even if there is a type error continue checking the structure */
 	TValue first = kcar(tail);
-	if (ksymbolp(first)) {
+	if (ttissymbol(first)) {
 	    repeated_errorp |= kis_marked(first);
 	    kmark(first);
 	} else {
@@ -188,8 +189,45 @@ void do_import(klisp_State *K, TValue *xparams, TValue obj)
 }
 
 /* 6.8.2 $provide! */
-/* TODO */
+void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    /* 
+    ** xparams[0]: name as symbol
+    */
+    TValue sname = xparams[0];
+    char *name = ksymbol_buf(sname);
+
+    bind_al1p(K, name, ptree, symbols, body);
 
+    symbols = check_copy_symbol_list(K, name, symbols);
+    body = check_copy_list(K, name, body);
+    
+    TValue new_env = kmake_environment(K, denv);
+    /* this will copy the bindings from new_env to denv */
+    TValue import_cont =
+	kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_import, 3, 
+			   sname, symbols, denv);
+    /* this will ignore the last value and pass the env to the 
+       above continuation */
+    TValue ret_exp_cont = 
+	kmake_continuation(K, import_cont, KNIL, KNIL, do_return_value, 
+			   1, new_env);
+    kset_cc(K, ret_exp_cont);
+
+    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, new_env);
+	    kset_cc(K, new_cont);
+	} 
+	ktail_eval(K, kcar(body), new_env);
+    }
+}
 
 /* 6.8.3 $import! */
 void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -238,12 +238,13 @@ 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 */
-
-/* Helper for $import! */
+/* Helpers for $provide & $import! */
+TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj);
 void do_import(klisp_State *K, TValue *xparams, TValue obj);
 
+/* 6.8.2 $provide! */
+void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
 /* 6.8.3 $import! */
 void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
diff --git a/src/kground.c b/src/kground.c
@@ -481,7 +481,7 @@ void kinit_ground_env(klisp_State *K)
     add_operative(K, ground_env, "$set!", SsetB, 1, symbol);
 
     /* 6.8.2 $provide! */
-    /* TODO */
+    add_operative(K, ground_env, "$provide!", SprovideB, 1, symbol);
 
     /* 6.8.3 $import! */
     add_operative(K, ground_env, "$import!", SimportB, 1, symbol);