klisp

commit 6333adde499e501eb7d18bcb720420122b4aa261
parent d19e10b9bc8e5529d8a84587955828162e3c0cec
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Tue, 22 Mar 2011 17:20:31 -0300

Modified - to allow a list of arguments (of length at least 2).

Diffstat:
M
src/kgnumbers.c
 | 
140
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------

1 file changed, 118 insertions(+), 22 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -115,7 +115,6 @@ 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);
@@ -256,40 +255,137 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 }
 
 /* 12.5.6 - */
-/* TEMP: for now only accept two arguments */
 void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 {
     UNUSED(denv);
     UNUSED(xparams);
+    /* cycles are allowed, loop counting pairs */
+    int32_t cpairs;
+    
+    /* - in kernel (and unlike in scheme) requires at least 2 arguments */
+    if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
+	klispE_throw(K, "-: at least two values are required");
+	return;
+    } else if (!knumberp(kcar(ptree))) {
+	klispE_throw(K, "-: bad type on first argument (expected number)");
+	return;
+    }
+    TValue first_val = kcar(ptree);
 
-    bind_2tp(K, "-", ptree, "number", knumberp, n1, "number", knumberp, n2);
+    int32_t pairs = check_typed_list(K, "-", "number", knumberp, true,
+				     kcdr(ptree), &cpairs);
+    int32_t apairs = pairs - cpairs;
 
-    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)) {
-		/* TEMP: we don't have reals with no prim value yet */
-		/* also no strict arithmetic variable for now */
+    TValue res;
+
+    /* first the acyclic part */
+    TValue ares = i2tv(0);
+    int32_t accum = 0;
+    bool seen_infinity = false;
+    TValue tail = kcdr(ptree);
+
+    while(apairs--) {
+	TValue first = kcar(tail);
+	tail = kcdr(tail);
+
+	if (ttiseinf(first)) {
+	    if (seen_infinity && !tv_equal(first, ares)) {
+		/* report: #e+infinity + #e-infinity has no primary value */
 		klispE_throw(K, "-: result has no primary value");
 		return;
 	    } else {
-		kapply_cc(K, n1);
+		/* record which infinity we have seen */
+		seen_infinity = true;
+		ares = first;
 	    }
-	} else {
-	    kapply_cc(K, ttiseinf(n1)? n1 : kneg_inf(n2));
+	} else if (!seen_infinity) {
+	    accum += ivalue(first);
 	}
     }
-    default:
-	/* shouldn't happen */
-	assert(0);
-	return;
+
+    if (!seen_infinity)
+	ares = i2tv(accum);
+
+    /* next the acyclic part */
+    TValue cres = i2tv(0);
+
+    if (cpairs == 0) {
+	res = ares;
+    } else {
+	bool all_zero = true;
+
+	seen_infinity = false;
+	accum = 0;
+
+	while(cpairs--) {
+	    TValue first = kcar(tail);
+	    tail = kcdr(tail);
+
+	    all_zero = all_zero && kfast_zerop(first);
+
+	    if (ttiseinf(first)) {
+		if (seen_infinity && !tv_equal(first, cres)) {
+		    /* report: #e+infinity + #e-infinity has no primary value */
+		    klispE_throw(K, "-: result has no primary value");
+		    return;
+		} else {
+		    /* record which infinity we have seen */
+		    seen_infinity = true;
+		    cres = first;
+		}
+	    } else if (!seen_infinity) {
+		accum += ivalue(first);
+	    }
+	}
+
+	if (!seen_infinity) {
+	    if (accum == 0)  {
+		if (!all_zero) {
+		    /* report */
+		    klispE_throw(K, "-: result has no primary value");
+		    return;
+		} else {
+		    cres = i2tv(accum);
+		}
+	    } else {
+		cres = accum < 0? KEMINF : KEPINF;
+	    }
+	}
+
+	if (ttiseinf(ares)) {
+	    if (!ttiseinf(cres) || tv_equal(ares, cres))
+		res = ares;
+	    else {
+		/* report */
+		klispE_throw(K, "-: result has no primary value");
+		return;
+	    }
+	} else {
+	    if (ttiseinf(cres))
+		res = cres;
+	    else 
+		res = i2tv(ivalue(ares) + ivalue(cres));
+	}
+    } 
+
+    /* now substract the sum of all the elements in the list to the first 
+       value */
+    if (ttiseinf(first_val)) {
+	if (!ttiseinf(res) || !tv_equal(first_val, res)) {
+	    res = first_val;
+	} else {
+	    /* report */
+	    klispE_throw(K, "-: result has no primary value");
+	    return;
+	}
+    } else {
+	if (ttiseinf(res))
+	    res = kneg_inf(res);
+	else 
+	    res = i2tv(ivalue(first_val) - ivalue(res));
     }
+
+    kapply_cc(K, res);
 }
 
 /* 12.5.7 zero? */