klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/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? */