klisp

commit bd7a55436a6037228dd30b51dec164e85512a410
parent d8f513d76e2391c47e64fc420257329a56b42add
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 24 Mar 2011 20:38:49 -0300

check_list: Added a cpairs out parameter and a flag parameter to allow or not cyclic lists. Removed the inline qualifier.

Diffstat:
M
src/kgcombiners.c
 | 
6
++++--
M
src/kghelpers.c
 | 
25
+++++++++++++++++++++++++
M
src/kghelpers.h
 | 
25
++++++-------------------
M
src/kgpairs_lists.c
 | 
8
++++----

4 files changed, 39 insertions(+), 25 deletions(-)
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -45,7 +45,8 @@ void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     /* The ptree & body are copied to avoid mutation */
     vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
     /* the body should be a list */
-    (void)check_list(K, "$vau", vbody);
+    int32_t dummy;
+    (void)check_list(K, "$vau", true, vbody, &dummy);
     vbody = copy_es_immutable_h(K, "$vau", vbody, false);
 
     TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
@@ -118,7 +119,8 @@ void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     /* The ptree & body are copied to avoid mutation */
     vptree = check_copy_ptree(K, "$lambda", vptree, KIGNORE);
     /* the body should be a list */
-    (void)check_list(K, "$lambda", vbody);
+    int32_t dummy;
+    (void)check_list(K, "$lambda", true, vbody, &dummy);
     vbody = copy_es_immutable_h(K, "$lambda", vbody, false);
 
     TValue new_app = make_applicative(K, do_vau, 4, vptree, KIGNORE, vbody, 
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -204,6 +204,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
     TValue tail = obj;
     int32_t pairs = 0;
     bool type_errorp = false;
+
     while(ttispair(tail) && !kis_marked(tail)) {
 	/* even if there is a type error continue checking the structure */
 	type_errorp |= !(*typep)(kcar(tail));
@@ -227,3 +228,27 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
     }
     return pairs;
 }
+
+int32_t check_list(klisp_State *K, char *name, bool allow_infp,
+			  TValue obj, int32_t *cpairs)
+{
+    TValue tail = obj;
+    int pairs = 0;
+    while(ttispair(tail) && !kis_marked(tail)) {
+	kset_mark(tail, i2tv(pairs));
+	tail = kcdr(tail);
+	++pairs;
+    }
+    *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+    unmark_list(K, obj);
+
+    if (!ttispair(tail) && !ttisnil(tail)) {
+	klispE_throw_extra(K, name , ": expected finite list"); 
+	return 0;
+    } else if(ttispair(tail) & !allow_infp) {
+	klispE_throw_extra(K, name , ": expected finite list"); 
+	return 0;
+    } else {
+	return pairs;
+    }
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -239,28 +239,14 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
 			 bool (*typep)(TValue), bool allow_infp, TValue obj,
 			 int32_t *cpairs);
 
+/* check that obj is a list, returns the number of pairs */
+int32_t check_list(klisp_State *K, char *name, bool allow_infp,
+			  TValue obj, int32_t *cpairs);
+
 /*
 ** MAYBE: These shouldn't be inline really.
 */
 
-/* check that obj is a list, returns the number of pairs */
-inline int32_t check_list(klisp_State *K, char *name, TValue obj)
-{
-    TValue tail = obj;
-    int pairs = 0;
-    while(ttispair(tail) && !kis_marked(tail)) {
-	kmark(tail);
-	tail = kcdr(tail);
-	++pairs;
-    }
-    unmark_list(K, obj);
-
-    if (!ttispair(tail) && !ttisnil(tail)) {
-	klispE_throw_extra(K, name , ": expected list"); 
-	return 0;
-    }
-    return pairs;
-}
 
 /* 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)
@@ -269,7 +255,8 @@ inline TValue check_copy_list(klisp_State *K, char *name, TValue obj)
 	return obj;
 
     if (ttispair(obj) && kis_immutable(obj)) {
-	(void)check_list(K, name, obj);
+	int32_t dummy;
+	(void)check_list(K, name, true, obj, &dummy);
 	return obj;
     } else {
 	TValue dummy = kcons(K, KINERT, KNIL);
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -287,8 +287,8 @@ void finite_listp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 {
     UNUSED(xparams);
     UNUSED(denv);
-
-    int32_t pairs = check_list(K, "finite-list?", ptree);
+    int32_t dummy;
+    int32_t pairs = check_list(K, "finite-list?", true, ptree, &dummy);
 
     TValue res = KTRUE;
     TValue tail = ptree;
@@ -317,8 +317,8 @@ void countable_listp(klisp_State *K, TValue *xparams, TValue ptree,
 {
     UNUSED(xparams);
     UNUSED(denv);
-
-    int32_t pairs = check_list(K, "countable-list?", ptree);
+    int32_t dummy;
+    int32_t pairs = check_list(K, "countable-list?", true, ptree, &dummy);
 
     TValue res = KTRUE;
     TValue tail = ptree;