klisp

commit 2740797a4b72a9ddcca5e9696366a81bcc2b96df
parent c960fbc1e194da8cc447fea8fab1923c5aef1076
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 18 Mar 2011 15:35:49 -0300

Added helper for typed predicates (like char-numeric?).

Diffstat:
M
src/kghelpers.c
 | 
49
+++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kghelpers.h
 | 
8
++++++++
M
src/kground.c
 | 
4
++++

3 files changed, 61 insertions(+), 0 deletions(-)
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -78,3 +78,52 @@ void ftypep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 	return;
     }
 }
+
+void ftyped_predp(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 obj) = 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);
+
+    if (!ttispair(tail) && !ttisnil(tail)) {
+	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 */
+    while(pairs--) {
+	TValue first = kcar(tail);
+
+	if (!(*typep)(first)) {
+	    /* TODO show expected type */
+	    klispE_throw_extra(K, name, ": bad argument type");
+	    return;
+	}
+	res &= (*predp)(first);
+	tail = kcdr(tail);
+    }
+    kapply_cc(K, b2tv(res));
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -334,4 +334,12 @@ void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 */
 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
+** type. This takes a function pointer for the type & one for the predicate,
+** both of the same type: bool (*fn)(TValue o).
+*/
+void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -491,9 +491,13 @@ void kinit_ground_env(klisp_State *K)
 		    i2tv(K_TCHAR));
 
     /* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
+    /* unlike in r5rs these take an arbitrary number of chars
+       (even cyclical list) */
     /* TODO */
 
     /* 14.1.3? char-upper-case?, char-lower-case? */
+    /* unlike in r5rs these take an arbitrary number of chars
+       (even cyclical list) */
     /* TODO */
 
     /* 14.1.4? char->integer, integer->char */