klisp

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

commit 15aa218df4e1dc5f8a5d9b938630aba61eed9c32
parent 6333adde499e501eb7d18bcb720420122b4aa261
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Tue, 22 Mar 2011 18:05:04 -0300

Added support for arbitrary lists in *. Number module done.

Diffstat:
Msrc/kgnumbers.c | 163+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------
Msrc/kgnumbers.h | 1+
2 files changed, 141 insertions(+), 23 deletions(-)

diff --git a/src/kgnumbers.c b/src/kgnumbers.c @@ -114,6 +114,14 @@ bool knum_gep(TValue n1, TValue n2) } } +/* +** REFACTOR: all of *, -, and + should be refactored +** this will probably happen when bignums are introduced +** the idea is to have generic binary +, -, * and /, maybe +** inlineable. That would clear up all the border cases +** like infinities that are obscuring the code. +**/ + /* 12.5.4 + */ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { @@ -155,7 +163,7 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) if (!seen_infinity) ares = i2tv(accum); - /* next the acyclic part */ + /* next the cyclic part */ TValue cres = i2tv(0); if (cpairs == 0) { @@ -221,37 +229,146 @@ 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); + /* cycles are allowed, loop counting pairs */ + int32_t cpairs; + int32_t pairs = check_typed_list(K, "*", "number", knumberp, true, + ptree, &cpairs); + int32_t apairs = pairs - cpairs; - bind_2tp(K, "*", ptree, "number", knumberp, n1, "number", knumberp, n2); + TValue res; - 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 */ + /* first the acyclic part */ + TValue ares = i2tv(1); + int32_t accum = 1; + bool seen_zero = false; + TValue tail = ptree; + bool seen_infinity = false; + + while(apairs--) { + TValue first = kcar(tail); + tail = kcdr(tail); + + if (ttiseinf(first)) { + if (seen_zero) { + /* report: #e+infinity * 0 has no primary value */ + klispE_throw(K, "*: result has no primary value"); + return; + } else { + /* record which infinity we have seen */ + if (!seen_infinity) { + seen_infinity = true; + ares = first; + } else if (tv_equal(first, KEMINF)) + ares = kneg_inf(ares); + } + } else if (ivalue(first) == 0) { + if (seen_infinity) { + /* report: #e+infinity * 0 has no primary value */ + klispE_throw(K, "*: result has no primary value"); + return; + } + seen_zero = true; + accum = 0; + } else if (!seen_zero) { + accum *= ivalue(first); + } + } + + if (seen_infinity) + ares = (accum < 0)? kneg_inf(ares) : ares; + else + ares = i2tv(accum); + + /* next the cyclic part */ + TValue cres = i2tv(1); + + if (cpairs == 0) { + res = ares; + } else { + bool all_one = true; + seen_zero = false; + seen_infinity = false; + accum = 1; + + while(cpairs--) { + TValue first = kcar(tail); + tail = kcdr(tail); + + all_one = all_one && kfast_onep(first); + + if (ttiseinf(first)) { + if (seen_zero) { + /* report: 0 * #e+infinity has no primary value */ + klispE_throw(K, "*: result has no primary value"); + return; + } else { + /* record which infinity we have seen */ + if (!seen_infinity) { + seen_infinity = true; + cres = first; + } else if (tv_equal(first, KEMINF)) + cres = kneg_inf(cres); + } + } else if (kfast_zerop(first)) { + if (seen_infinity) { + /* report: 0 * #e+infinity has no primary value */ + klispE_throw(K, "*: result has no primary value"); + return; + } + seen_zero = true; + accum = 0; + } else if (!seen_zero) { + accum *= ivalue(first); + } + } + + /* think of accum as the product of an infinite series */ + if (seen_infinity) { + cres = (accum < 0)? kneg_inf(cres) : cres; + } else if (seen_zero || (accum >= 0 && accum < 1)) { + cres = i2tv(0); + } else if (accum == 1) { + if (all_one) + cres = i2tv(1); + else { + klispE_throw(K, "*: result has no primary value"); + return; + } + } else if (accum > 1) { + /* ASK JOHN: this is as per the report, but maybe we should check + that all elements are positive... */ + cres = KEPINF; + } else { klispE_throw(K, "*: result has no primary value"); return; + } + + if (ttiseinf(ares)) { + if (ttiseinf(cres)) { + res = tv_equal(cres, ares)? KEPINF : KEMINF; + } else if (ivalue(cres) == 0) { + klispE_throw(K, "*: result has no primary value"); + return; + } else { + res = ivalue(cres) < 0? kneg_inf(ares) : ares; + } } else { - /* use the fact that infinities have ivalues 1 & -1 */ - kapply_cc(K, (ivalue(n1) ^ ivalue(n2)) < 0? KEMINF : KEPINF); + if (ttiseinf(cres)) { + if (ivalue(ares) == 0) { + klispE_throw(K, "*: result has no primary value"); + return; + } else + res = ivalue(ares) < 0? kneg_inf(cres) : cres; + } else { + res = i2tv(ivalue(ares) * ivalue(cres)); + } } - } - default: - /* shouldn't happen */ - assert(0); - return; - } + } + kapply_cc(K, res); } /* 12.5.6 - */ @@ -306,7 +423,7 @@ void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) if (!seen_infinity) ares = i2tv(accum); - /* next the acyclic part */ + /* next the cyclic part */ TValue cres = i2tv(0); if (cpairs == 0) { diff --git a/src/kgnumbers.h b/src/kgnumbers.h @@ -111,6 +111,7 @@ void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv); /* Misc Helpers */ inline bool kfast_zerop(TValue n) { return ttisfixint(n) && ivalue(n) == 0; } +inline bool kfast_onep(TValue n) { return ttisfixint(n) && ivalue(n) == 1; } /* TEMP: only exact infinties */ inline TValue kneg_inf(TValue i) {