klisp

commit da488957c16e1aa47c6302e3ea902ccdda09ede3
parent a4b85984484ede70a1d23f5b8bb40503f6f8e652
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 18 Mar 2011 16:54:55 -0300

Added a typed binary predicate helper (for char<? and numeric <?, etc)

Diffstat:
M
src/kgchars.c
 | 
1
-
M
src/kghelpers.c
 | 
57
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kghelpers.h
 | 
13
++++++++++++-

3 files changed, 69 insertions(+), 2 deletions(-)
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -90,7 +90,6 @@ void kchar_downcase(klisp_State *K, TValue *xparams, TValue ptree,
     ch = tolower(ch);
     kapply_cc(K, ch2tv(ch));
 }
-/* TODO */
 
 /* 14.2.1? char=? */
 /* TODO */
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -127,3 +127,60 @@ void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     }
     kapply_cc(K, b2tv(res));
 }
+
+void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    (void) denv;
+    /*
+    ** xparams[0]: name symbol
+    ** xparams[1]: type fn pointer (as a void * in a user TValue)
+    ** xparams[2]: fn pointer (as a void * in a user TValue)
+    */
+    char *name = ksymbol_buf(xparams[0]);
+    bool (*typep)(TValue obj) = pvalue(xparams[1]);
+    bool (*predp)(TValue obj1, TValue obj2) = pvalue(xparams[2]);
+
+    /* check the ptree is a list first to allow the structure
+       errors to take precedence over the type errors. */
+    TValue tail = ptree;
+    int32_t pairs = 0;
+
+    while(ttispair(tail) && kis_unmarked(tail)) {
+	pairs++;
+	kmark(tail);
+	tail = kcdr(tail);
+    }
+    unmark_list(K, ptree);
+    int32_t comps;
+    if (ttisnil(tail)) {
+	comps = pairs - 1;
+    } else if (ttispair(tail)) {
+	/* cyclical list require an extra comparison of the last
+	  & first element of the cycle */
+	comps = pairs;
+    } else {
+	klispE_throw_extra(K, name, ": expected list");
+	return;
+    }
+
+    tail = ptree;
+    bool res = true;
+
+    /* check the type while checking the predicate.
+       Keep going even if the result is false to catch errors in 
+       type */
+    /* it checks > 0 because if ptree is nil comps = -1 */
+    while(comps-- > 0) {
+	TValue first = kcar(tail);
+	tail = kcdr(tail); /* tail only advances one place per iteration */
+	TValue second = kcar(tail);
+
+	if (!(*typep)(first) && !(*typep)(second)) {
+	    /* TODO show expected type */
+	    klispE_throw_extra(K, name, ": bad argument type");
+	    return;
+	}
+	res &= (*predp)(first, second);
+    }
+    kapply_cc(K, b2tv(res));
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -336,10 +336,21 @@ void ftypep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /*
 ** Generic function for typed predicates (like char-alphabetic? or finite?)
-** A type predicate is a predicate that requires its arguments to be a certain
+** A typed predicate is a predicate that requires its arguments to be a certain
 ** type. This takes a function pointer for the type & one for the predicate,
 ** both of the same type: bool (*fn)(TValue o).
+** On zero operands this return true
 */
 void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
+/*
+** Generic function for typed binary predicates (like =? & char<?)
+** A typed predicate is a predicate that requires its arguments to be a certain
+** type. This takes a function pointer for the type bool (*typep)(TValue o) 
+** & one for the predicate: bool (*fn)(TValue o1, TValue o2).
+** This assumes the predicate is transitive and works even in cyclic lists
+** On zero and one operand this return true
+*/
+void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
 #endif