klisp

commit df7b383c12bb4f017eae860196e57bf97cbbb703
parent e8901159d26864060b67cb5d166fb318ac67c30c
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Mon,  4 Apr 2011 21:30:55 -0300

Bugfix: filter didn't copy the list if it was immutable. Added bool flag to check_copy_list to force copy even if immutable.

Diffstat:
M
src/kgbooleans.c
 | 
2
+-
M
src/kgcontinuations.c
 | 
2
+-
M
src/kgcontrol.c
 | 
4
++--
M
src/kgenv_mut.c
 | 
2
+-
M
src/kgenvironments.c
 | 
2
+-
M
src/kghelpers.h
 | 
11
++++++++---
M
src/kgpairs_lists.c
 | 
4
+++-

7 files changed, 17 insertions(+), 10 deletions(-)
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -145,7 +145,7 @@ void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     TValue sname = xparams[0];
     TValue term_bool = xparams[1];
     
-    TValue ls = check_copy_list(K, ksymbol_buf(sname), ptree);
+    TValue ls = check_copy_list(K, ksymbol_buf(sname), ptree, false);
     /* This will work even if ls is empty */
     TValue new_cont = 
 	kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_Sandp_Sorp, 
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -237,7 +237,7 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
 	
 	/* the list of instructions is copied to avoid mutation */
 	/* MAYBE: copy the evaluation structure, ASK John */
-	TValue ls = check_copy_list(K, "$let/cc", objs);
+	TValue ls = check_copy_list(K, "$let/cc", objs, false);
 	/* this is needed because seq continuation doesn't check for 
 	   nil sequence */
 	TValue tail = kcdr(ls);
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -74,7 +74,7 @@ void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     } else {
 	/* the list of instructions is copied to avoid mutation */
 	/* MAYBE: copy the evaluation structure, ASK John */
-	TValue ls = check_copy_list(K, "$sequence", ptree);
+	TValue ls = check_copy_list(K, "$sequence", ptree, false);
 	/* this is needed because seq continuation doesn't check for 
 	   nil sequence */
 	/* TODO this could be at least in an inlineable function to
@@ -175,7 +175,7 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
 	*/
 	while(count--) {
 	    TValue first = kcar(tail);
-	    TValue copy = check_copy_list(K, "$cond", first);
+	    TValue copy = check_copy_list(K, "$cond", first, false);
 	    kset_car(tail, copy);
 	    tail = kcdr(tail);
 	}
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -200,7 +200,7 @@ void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     bind_al1p(K, name, ptree, symbols, body);
 
     symbols = check_copy_symbol_list(K, name, symbols);
-    body = check_copy_list(K, name, body);
+    body = check_copy_list(K, name, body, false);
     
     TValue new_env = kmake_environment(K, denv);
     /* this will copy the bindings from new_env to denv */
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -263,7 +263,7 @@ void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     int32_t dummy;
     int32_t count = check_typed_list(K, "$binds?", "symbol", ksymbolp, 
 				     true, symbols, &dummy);
-    symbols = check_copy_list(K, "$binds?", symbols);
+    symbols = check_copy_list(K, "$binds?", symbols, false);
 
     TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_bindsp, 
 					 2, symbols, i2tv(count));
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -235,6 +235,9 @@ inline void unmark_tree(klisp_State *K, TValue obj)
 ** Structure checking and copying
 */
 
+/* TODO: move all bools to a flag parameter (with constants like
+   KCHK_LS_FORCE_COPY, KCHK_ALLOW_CYCLE, KCHK_AVOID_ENCYCLE, etc) */
+
 /* typed finite list. Structure error should be throw before type errors */
 int32_t check_typed_list(klisp_State *K, char *name, char *typename,
 			 bool (*typep)(TValue), bool allow_infp, TValue obj,
@@ -252,14 +255,16 @@ int32_t check_list(klisp_State *K, char *name, bool allow_infp,
 /* REFACTOR: return the number of pairs and cycle pairs in two extra params */
 /* TODO: add check_copy_typed_list */
 /* TODO: remove inline */
+/* check that obj is a list and make a copy if it is not immutable or
+ force_copy is true */
 
-/* check that obj is a list and make a copy if it is not immutable */
-inline TValue check_copy_list(klisp_State *K, char *name, TValue obj)
+inline TValue check_copy_list(klisp_State *K, char *name, TValue obj, 
+			      bool force_copy)
 {
     if (ttisnil(obj))
 	return obj;
 
-    if (ttispair(obj) && kis_immutable(obj)) {
+    if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
 	int32_t dummy;
 	(void)check_list(K, name, true, obj, &dummy);
 	return obj;
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -538,7 +538,9 @@ void filter(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     /* REFACTOR: do this in a single pass */
     int32_t cpairs;
     int32_t pairs = check_list(K, "filter", true, ls, &cpairs);
-    ls = check_copy_list(K, "filter", ls);
+    /* force copy even if immutable to allow use of mutation 
+     to filter */
+    ls = check_copy_list(K, "filter", ls, true);
     /* add dummy pair to allow set-cdr! to filter out any pair */
     ls = kcons(K, KINERT, ls);