klisp

commit 342e17f8127bbce99c439ce72040623d6385c1a0
parent 75feefbe3784a24b36a0cd3a0643e24f9e9b940e
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Mon, 21 Mar 2011 17:38:32 -0300

Added min and max to the ground environment.

Diffstat:
M
src/kghelpers.c
 | 
31
+++++++++++++++++++++++++++++++
M
src/kghelpers.h
 | 
8
++++++++
M
src/kgnumbers.c
 | 
54
++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
9
+++++++++
M
src/kground.c
 | 
6
+++++-

5 files changed, 107 insertions(+), 1 deletion(-)
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -198,3 +198,34 @@ void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 	kapply_cc(K, b2tv(res));
     }
 }
+
+/* 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)
+{
+    TValue tail = obj;
+    int 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));
+	kmark(tail);
+	tail = kcdr(tail);
+	++pairs;
+    }
+    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 if (type_errorp) {
+	/* TODO put type name too */
+	klispE_throw_extra(K, name , ": bad operand type"); 
+	return 0;
+    }
+    return pairs;
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -231,6 +231,14 @@ inline void unmark_tree(klisp_State *K, TValue obj)
 
 /*
 ** Structure checking and copying
+*/
+
+/* 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);
+
+
+/*
 ** MAYBE: These shouldn't be inline really.
 */
 
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -292,6 +292,8 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     char *name = ksymbol_buf(xparams[0]);
     int32_t flags = ivalue(xparams[1]);
 
+    UNUSED(denv);
+
     bind_2tp(K, name, ptree, "number", knumberp, tv_n,
 	     "number", knumberp, tv_d);
 
@@ -360,3 +362,55 @@ void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     }
 }
 
+/* 12.5.13 min, max */
+/* NOTE: this does two passes, one for error checking and one for doing
+ the actual work */
+void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    /*
+    ** xparams[0]: symbol name
+    ** xparams[1]: bool: true min, false max
+    */
+    UNUSED(denv);
+    
+    char *name = ksymbol_buf(xparams[0]);
+    bool minp = bvalue(xparams[1]);
+
+    /* cycles are allowed, loop counting pairs */
+    int32_t pairs = check_typed_list(K, name, "number", knumberp, true, ptree);
+    
+    TValue res;
+    bool one_finite = false;
+    TValue break_val;
+    if (minp) {
+	res = KEPINF;
+	break_val = KEMINF; /* min possible number */
+    } else {
+	res = KEMINF;
+	break_val = KEPINF; /* max possible number */
+    }
+
+    TValue tail = ptree;
+    while(pairs--) {
+	TValue first = kcar(tail);
+	tail = kcdr(tail);
+
+	if (ttiseinf(first)) {
+	    if (tv_equal(first, break_val)) {
+		res = first;
+		break;
+	    }
+	} else if (!one_finite) {
+	    res = first;
+	    one_finite = true;
+	} else if (minp) {
+	    if (ivalue(first) < ivalue(res))
+		res = first;
+	} else { /* maxp */
+	    if (ivalue(first) > ivalue(res))
+		res = first;
+	}
+    }
+    kapply_cc(K, res);
+}
+
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -97,6 +97,15 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 /* 12.5.12 abs */
 void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
+/* 12.5.13 min, max */
+/* use kmin_max */
+
+/* Helper */
+#define FMIN (true)
+#define FMAX (false)
+void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+
 /* Misc Helpers */
 inline bool kfast_zerop(TValue n) { return ttisfixint(n) && ivalue(n) == 0; }
 /* TEMP: only exact infinties */
diff --git a/src/kground.c b/src/kground.c
@@ -552,7 +552,11 @@ void kinit_ground_env(klisp_State *K)
     /* 12.5.12 abs */
     add_applicative(K, ground_env, "abs", kabs, 0);
 
-    /* ... TODO */
+    /* 12.5.13 min, max */
+    add_applicative(K, ground_env, "min", kmin_max, 2, symbol, b2tv(FMIN));
+    add_applicative(K, ground_env, "max", kmin_max, 2, symbol, b2tv(FMAX));
+
+/* ... TODO */
 
     /*
     **