klisp

commit a14371dccd8e7752b495f846e9c3874004f417de
parent 77b8aa5594386c25f2c3c0df60a081c79b04aee7
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sun, 20 Mar 2011 03:08:24 -0300

Added + (2 args only) to the ground environment.

Diffstat:
M
src/kgnumbers.c
 | 
35
+++++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
3
+++
M
src/kground.c
 | 
4
++++

3 files changed, 42 insertions(+), 0 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -113,5 +113,40 @@ bool knum_gep(TValue n1, TValue n2)
     }
 }
 
+/* 12.5.4 + */
+/* TEMP: for now only accept two arguments */
+void kplus(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 (ttiseinf(n1) && ttiseinf(n2)) {
+	    if (tv_equal(n1, n2)) {
+		kapply_cc(K, n1);
+	    } else {
+		/* 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 {
+	    kapply_cc(K, ttiseinf(n1)? n1 : n2);
+	}
+    }
+    default:
+	/* shouldn't happen */
+	assert(0);
+	return;
+    }
+}
 
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -44,5 +44,8 @@ bool knum_lep(TValue n1, TValue n2);
 bool knum_gtp(TValue n1, TValue n2);
 bool knum_gep(TValue n1, TValue n2);
 
+/* 12.5.4 + */
+/* TEMP: for now only accept two arguments */
+void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -505,6 +505,10 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, ">=?", ftyped_bpredp, 3,
 		    symbol, p2tv(knumberp), p2tv(knum_gep));
 
+    /* 12.5.4 + */
+    /* TEMP: for now only accept two arguments */
+    add_applicative(K, ground_env, "+", kplus, 0);
+
     /* ... TODO */
 
     /*