klisp

commit 1c79e8289790fd9211da39f31e35de4c9b3215bb
parent a14371dccd8e7752b495f846e9c3874004f417de
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sun, 20 Mar 2011 03:19:48 -0300

Added * (2 args) to the ground environment.

Diffstat:
M
src/kgnumbers.c
 | 
34
++++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
7
+++++++
M
src/kground.c
 | 
4
++++

3 files changed, 45 insertions(+), 0 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -150,3 +150,37 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     }
 }
 
+
+/* 12.5.5 * */
+/* TEMP: for now only accept two arguments */
+void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(denv);
+    UNUSED(xparams);
+
+    bind_2tp(K, "*", ptree, "number", knumberp, n1, "number", knumberp, n2);
+
+    switch(max_ttype(n1, n2)) {
+    case K_TFIXINT: {
+	int32_t i1 = ivalue(n1);
+	int32_t i2 = ivalue(n2);
+	/* TODO: check for overflow and create bigint */
+	kapply_cc(K, i2tv(i1*i2));
+    } 
+    case K_TEINF: {
+	if (kfast_zerop(n1) || kfast_zerop(n2)) {
+	    /* TEMP: we don't have reals with no prim value yet */
+	    /* also no strict arithmetic variable for now */
+	    klispE_throw(K, "*: result has no primary value");
+	    return;
+	} else {
+	    /* use the fact that infinities have ivalues 1 & -1 */
+	    kapply_cc(K, (ivalue(n1) ^ ivalue(n2)) < 0? KEMINF : KEPINF);
+	}
+    }
+    default:
+	/* shouldn't happen */
+	assert(0);
+	return;
+    }
+}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -48,4 +48,11 @@ bool knum_gep(TValue n1, TValue n2);
 /* TEMP: for now only accept two arguments */
 void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
+/* 12.5.5 * */
+/* TEMP: for now only accept two arguments */
+void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* Helper */
+inline bool kfast_zerop(TValue n) { return ttisfixint(n) && ivalue(n) == 0; }
+
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -509,6 +509,10 @@ void kinit_ground_env(klisp_State *K)
     /* TEMP: for now only accept two arguments */
     add_applicative(K, ground_env, "+", kplus, 0);
 
+    /* 12.5.5 * */
+    /* TEMP: for now only accept two arguments */
+    add_applicative(K, ground_env, "*", ktimes, 0);
+
     /* ... TODO */
 
     /*