commit 8b7448513049c48bad659906b321f76376ab192c
parent 641b5ac451f08a28afaf736b5db525b8b538c733
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 20 May 2011 00:30:25 -0300
Merged inexact branch.
Diffstat:
18 files changed, 2445 insertions(+), 428 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -11,7 +11,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
kencapsulation.o kpromise.o kport.o kinteger.o krational.o \
- ktable.o kgc.o imath.o imrat.o \
+ kreal.o ktable.o kgc.o imath.o imrat.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
@@ -45,21 +45,22 @@ klisp.o: klisp.c klisp.h kobject.h kread.h kwrite.h klimits.h kstate.h kmem.h \
kapplicative.h koperative.h keval.h krepl.h kground.h
kobject.o: kobject.c kobject.h klimits.h klispconf.h
ktoken.o: ktoken.c ktoken.h kobject.h kstate.h kpair.h kstring.h ksymbol.h \
- kerror.h klisp.h kinteger.h krational.h kport.h
+ kerror.h klisp.h kinteger.h krational.h kreal.h kport.h
kinteger.o: kinteger.c kinteger.h kobject.h kstate.h kmem.h klisp.h imath.h \
kgc.h
-krational.o: krational.c krational.h kinteger.h kobject.h kstate.h kmem.h klisp.h \
- imrat.h kgc.h
+krational.o: krational.c krational.h kinteger.h kobject.h kstate.h kmem.h \
+ klisp.h imrat.h kgc.h
+kreal.o: kreal.c kreal.h krational.h kinteger.h kobject.h kstate.h kmem.h \
+ klisp.h imrat.h kgc.h kerror.h kpair.h
kpair.o: kpair.c kpair.h kobject.h kstate.h kmem.h klisp.h kgc.h
kstring.o: kstring.c kstring.h kobject.h kstate.h kmem.h klisp.h kgc.h
-# XXX: kpair.h because of use of list as symbol table
-ksymbol.o: ksymbol.c ksymbol.h kobject.h kpair.h kstring.h kstate.h kmem.h \
+ksymbol.o: ksymbol.c ksymbol.h kobject.h kstring.h kstate.h kmem.h \
klisp.h kgc.h
kread.o: kread.c kread.h kobject.h ktoken.h kpair.h kstate.h kerror.h klisp.h \
kport.h ktable.h klispconf.h
kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h \
- klisp.h kport.h kinteger.h krational.h ktable.h klispconf.h \
- kenvironment.h
+ klisp.h kport.h kinteger.h krational.h kreal.h ktable.h klispconf.h \
+ kenvironment.h
# XXX: now that all dealloc code is in gc, many of these are unnecessary
kstate.o: kstate.c kstate.h klisp.h kobject.h kmem.h kstring.h klisp.h \
kenvironment.h kpair.h keval.h koperative.h kground.h \
@@ -103,7 +104,7 @@ kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h ksymbol.h
kgeqp.o: kgeqp.c kgeqp.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h kapplicative.h \
- kinteger.h krational.h
+ kinteger.h krational.h kreal.h
kgequalp.o: kgequalp.c kgequalp.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h kgeqp.h kstring.h
kgsymbols.o: kgsymbols.c kgsymbols.c kghelpers.h kstate.h klisp.h \
@@ -114,7 +115,8 @@ kgpairs_lists.o: kgpairs_lists.c kgpairs_lists.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h kgequalp.h \
kenvironment.h kgnumbers.h kinteger.h
kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \
- kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h kgeqp.h
+ kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h kgeqp.h \
+ kgnumbers.h
kgenvironments.o: kgenvironments.c kgenvironments.h kghelpers.h kstate.h \
klisp.h kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h \
kenvironment.h kgenv_mut.h kgpair_mut.h kgcontrol.h
@@ -148,11 +150,11 @@ kgchars.o: kgchars.c kgchars.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h
kgnumbers.o: kgnumbers.c kgnumbers.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
- ksymbol.h kinteger.h krational.h
+ ksymbol.h kinteger.h krational.h kreal.h kgkd_vars.h
kgstrings.o: kgstrings.c kgstrings.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
kstring.h ksymbol.h kgnumbers.h
imath.o: kobject.h kstate.h kmem.h kerror.h
imrath.o: kobject.h kstate.h kmem.h kerror.h
kgc.o: kgc.c kgc.h kobject.h kmem.h kstate.h kport.h imath.h imrat.h \
- ktable.h kstring.h kerror.h
+ ktable.h kstring.h kerror.h kinteger.h krational.h
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -25,7 +25,7 @@ TValue kget_keyed_static_var(klisp_State *K, TValue env, TValue key);
/* environments with hashtable bindings */
/* TEMP: for now only for ground environment
TODO: Should profile too see when it makes sense & should add code
- to all operatives creating environments to see when it's appropiate
+ to all operatives creating environments to see when it's appropriate
or should add code to add binding to at certain point move over to
hashtable */
TValue kmake_table_environment(klisp_State *K, TValue parents);
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -54,7 +54,7 @@ void kinteger_to_char(klisp_State *K, TValue *xparams, TValue ptree,
{
UNUSED(xparams);
UNUSED(denv);
- bind_1tp(K, ptree, "integer", ttisinteger, itv);
+ bind_1tp(K, ptree, "exact integer", ttiseinteger, itv);
if (ttisbigint(itv)) {
klispE_throw_simple(K, "integer out of ASCII range [0 - 127]");
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -4,6 +4,11 @@
** See Copyright Notice in klisp.h
*/
+/*
+** TODO: Many real operations are done by converting to bigint/bigrat
+** (like numerator and gcd), these should be done in doubles directly
+*/
+
#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
@@ -19,287 +24,522 @@
#include "ksymbol.h"
#include "kinteger.h"
#include "krational.h"
+#include "kreal.h"
#include "kghelpers.h"
#include "kgnumbers.h"
+#include "kgkd_vars.h" /* for strict arith flag */
/* 15.5.1? number?, finite?, integer? */
/* use ftypep & ftypep_predp */
/* Helpers for typed predicates */
-bool knumberp(TValue obj) { return ttype(obj) <= K_LAST_NUMBER_TYPE; }
+bool knumberp(TValue obj) { return ttisnumber(obj); }
+/* TEMP used in =? for type predicate (XXX it's not actually a type
+ error, but it's close enough and otherwise should define a
+ new bpredp for numeric predicates...) */
+bool knumber_wpvp(TValue obj)
+{
+ return ttisnumber(obj) && !ttisrwnpv(obj) && !ttisundef(obj);
+}
/* This is used in gcd & lcm */
-bool kimp_intp(TValue obj) { return ttisinteger(obj) || ttiseinf(obj); }
+bool kimp_intp(TValue obj) { return ttisinteger(obj) || ttisinf(obj); }
/* obj is known to be a number */
-bool kfinitep(TValue obj) { return (!ttiseinf(obj) && !ttisiinf(obj)); }
-/* TEMP: for now only fixint, bigints & rational, should also include inexact
- integers */
+bool kfinitep(TValue obj) { return !ttisinf(obj); }
+/* fixint, bigints & inexact integers */
bool kintegerp(TValue obj) { return ttisinteger(obj); }
+/* only exact integers (like for indices), bigints & fixints */
+bool keintegerp(TValue obj) { return ttiseinteger(obj); }
bool krationalp(TValue obj) { return ttisrational(obj); }
-/* all real are rationals in klisp */
-bool krealp(TValue obj)
+bool krealp(TValue obj) { return ttisreal(obj); }
+/* TEMP used in <? & co for type predicate (XXX it's not actually a type
+ error, but it's close enough and otherwise should define a
+ new bpredp for numeric predicates...) */
+bool kreal_wpvp(TValue obj) { return ttisreal(obj) && !ttisrwnpv(obj); }
+
+bool kexactp(TValue obj) { return ttisexact(obj); }
+bool kinexactp(TValue obj) { return ttisinexact(obj); }
+bool kundefinedp(TValue obj) { return ttisundef(obj); }
+bool krobustp(TValue obj) { return ttisrobust(obj); }
+
+/* 12.5.2 =? */
+/* uses typed_bpredp */
+
+/* 12.5.3 <?, <=?, >?, >=? */
+/* use typed_bpredp */
+
+/* Helpers for typed binary predicates */
+/* XXX: this should probably be in a file knumber.h but there is no real need for
+ that file yet */
+
+/* this will come handy when there are more numeric types,
+ it is intended to be used in switch */
+/* MAYBE: change to return -1, 0, 1 to indicate which type is bigger, and
+ return min & max in two extra pointers passed in. Change name to
+ classify_types */
+inline int32_t max_ttype(TValue obj1, TValue obj2)
+{
+ int32_t t1 = ttype(obj1);
+ int32_t t2 = ttype(obj2);
+
+ return (t1 > t2? t1 : t2);
+}
+
+inline int32_t min_ttype(TValue obj1, TValue obj2)
+{
+ int32_t t1 = ttype(obj1);
+ int32_t t2 = ttype(obj2);
+
+ return (t1 < t2? t1 : t2);
+}
+
+/* helper to make both arguments inexact if one of them is,
+ n1 & n2 should be variable names that may be overwritten */
+/* GC: There is no problem because for now all inexact are stack
+ allocated */
+#define kensure_same_exactness(K, n1, n2) \
+ ({if (ttisinexact(n1) || ttisinexact(n2)) { \
+ n1 = kexact_to_inexact(K, n1); \
+ n2 = kexact_to_inexact(K, n2); \
+ }})
+
+
+/* ASK John: this isn't quite right I think. The problem is with implicit
+ conversion to inexact. This can cause issues for example if two different
+ exact numbers are compared with an inexact number that could correspong to
+ both (because it is too big and lacks precission for example), this would
+ behave differently depending on the order (=? #e1 #i #e2) would return
+ true & (=? #e1 #e2 #i) wourld return false. Maybe all numbers should be
+ converted to inexact. Also what happens with over & underflows? */
+
+/* ASK John: the same will probably apply to many combiners..., MAYBE shuld
+ check scheme implementations... */
+
+/* TEMP: for now only reals, no complex numbers */
+bool knum_eqp(klisp_State *K, TValue n1, TValue n2)
+{
+ /* for simplicity if one is inexact convert the other to inexact */
+ /* ASK John what happens on under & overflow, probably an error shouldn't
+ be signaled but instead inexact should be converted to exact to perform
+ the check?? */
+ kensure_same_exactness(K, n1, n2);
+
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT:
+ return ivalue(n1) == ivalue(n2);
+ case K_TBIGINT:
+ if (min_ttype(n1, n2) != K_TBIGINT) {
+ /* NOTE: no fixint is =? to a bigint */
+ return false;
+ } else {
+ /* both are bigints */
+ return kbigint_eqp(n1, n2);
+ }
+ case K_TBIGRAT:
+ if (min_ttype(n1, n2) != K_TBIGRAT) {
+ /* NOTE: no fixint or bigint is =? to a bigrat */
+ return false;
+ } else {
+ /* both are bigints */
+ return kbigrat_eqp(K, n1, n2);
+ }
+ case K_TEINF:
+ return (tv_equal(n1, n2));
+ case K_TDOUBLE:
+ return (tv_equal(n1, n2));
+ case K_TIINF: /* if the other was exact it was converted already */
+ return (tv_equal(n1, n2));
+ case K_TRWNPV:
+ case K_TUNDEFINED: /* no primary value, should throw an error */
+ /* TEMP: this was already contemplated in type predicate */
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return false;
+ }
+}
+
+bool knum_ltp(klisp_State *K, TValue n1, TValue n2)
+{
+ /* for simplicity if one is inexact convert the other to inexact */
+ kensure_same_exactness(K, n1, n2);
+
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT:
+ return ivalue(n1) < ivalue(n2);
+ case K_TBIGINT: {
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_ltp(n1, n2);
+ }
+ case K_TBIGRAT: {
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_ltp(K, n1, n2);
+ }
+ case K_TDOUBLE: /* both must be double, all inferior types
+ convert to either double or inexact infinity */
+ return (dvalue(n1) < dvalue(n2));
+ case K_TEINF:
+ return !tv_equal(n1, n2) && (tv_equal(n1, KEMINF) ||
+ tv_equal(n2, KEPINF));
+ case K_TIINF: /* if the other was exact it was converted already */
+ return !tv_equal(n1, n2) && (tv_equal(n1, KIMINF) ||
+ tv_equal(n2, KIPINF));
+ case K_TRWNPV:
+ case K_TUNDEFINED: /* no primary value, should throw an error */
+ /* TEMP: this was already contemplated in type predicate */
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return false;
+ }
+}
+
+bool knum_lep(klisp_State *K, TValue n1, TValue n2)
+{
+ return !knum_ltp(K, n2, n1);
+}
+bool knum_gtp(klisp_State *K, TValue n1, TValue n2)
+{
+ return knum_ltp(K, n2, n1);
+}
+bool knum_gep(klisp_State *K, TValue n1, TValue n2)
{
- return ttisrational(obj) || ttiseinf(obj) || ttisiinf(obj);
+ return !knum_ltp(K, n1, n2);
+}
+
+/*
+** Helper to check strict arithmetic flag if the result may not
+** have a primary value
+*/
+/* may evaluate K & n more than once */
+#define arith_return(K, n) \
+ ({ if (ttisnwnpv(n) && kcurr_strict_arithp(K)) { \
+ klispE_throw_simple_with_irritants(K, "result has no " \
+ "primary value", \
+ 1, n); \
+ return KINERT; \
+ } else { return n;}})
+
+/* may evaluate K & n more than once */
+#define arith_kapply_cc(K, n) \
+ ({ if (ttisnwnpv(n) && kcurr_strict_arithp(K)) { \
+ klispE_throw_simple_with_irritants(K, "result has no " \
+ "primary value", \
+ 1, n); \
+ return; \
+ } else { kapply_cc(K, n); return;}})
+
+
+
+/* REFACTOR/MAYBE: add small inlineable plus that
+ first tries fixint addition and if that fails calls knum_plus */
+
+/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
+TValue knum_plus(klisp_State *K, TValue n1, TValue n2)
+{
+ kensure_same_exactness(K, n1, n2);
+ TValue res; /* used for results with no primary value */
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT: {
+ int64_t res = (int64_t) ivalue(n1) + (int64_t) ivalue(n2);
+ if (res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
+ }
+ case K_TBIGINT: {
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_plus(K, n1, n2);
+ }
+ case K_TBIGRAT: {
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_plus(K, n1, n2);
+ }
+ case K_TDOUBLE: {
+ double res = dvalue(n1) + dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != -dvalue(n2)) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
+ }
+ case K_TEINF:
+ if (!ttiseinf(n1))
+ return n2;
+ else if (!ttiseinf(n2))
+ return n1;
+ if (tv_equal(n1, n2))
+ return n1;
+ else { /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ }
+ case K_TIINF:
+ if (!ttisiinf(n1))
+ return n2;
+ else if (!ttisiinf(n2))
+ return n1;
+ if (tv_equal(n1, n2))
+ return n1;
+ else { /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ }
+ case K_TRWNPV: /* no primary value */
+ res = KRWNPV;
+ break;
+ case K_TUNDEFINED: /* undefined */
+ res = KUNDEF;
+ break;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
+ }
+
+ /* check for no primary value and value of strict arith */
+ arith_return(K, res);
+}
+
+/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
+TValue knum_times(klisp_State *K, TValue n1, TValue n2)
+{
+ kensure_same_exactness(K, n1, n2);
+ TValue res; /* used for results with no primary value */
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT: {
+ int64_t res = (int64_t) ivalue(n1) * (int64_t) ivalue(n2);
+ if (res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
+ }
+ case K_TBIGINT: {
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_times(K, n1, n2);
+ }
+ case K_TBIGRAT: {
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_times(K, n1, n2);
+ }
+ case K_TDOUBLE: {
+ double res = dvalue(n1) * dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != 0.0 && dvalue(n2) != 0.00) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
+ }
+ case K_TEINF:
+ if (!ttiseinf(n1) || !ttiseinf(n2)) {
+ if (kfast_zerop(n1) || kfast_zerop(n2)) {
+ /* report: #e+infinity * 0 has no primary value */
+ res = KRWNPV;
+ break;
+ } else if (ttisexact(n1) && ttisexact(n2))
+ return knum_same_signp(K, n1, n2)? KEPINF : KEMINF;
+ else
+ return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
+ } else
+ return (tv_equal(n1, n2))? KEPINF : KEMINF;
+ case K_TIINF:
+ if (!ttisiinf(n1) || !ttisiinf(n2)) {
+ if (kfast_zerop(n1) || kfast_zerop(n2)) {
+ /* report: #i[+-]infinity * 0 has no primary value */
+ res = KRWNPV;
+ break;
+ } else
+ return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
+ } else
+ return (tv_equal(n1, n2))? KIPINF : KIMINF;
+ case K_TRWNPV:
+ res = KRWNPV;
+ break;
+ case K_TUNDEFINED:
+ res = KUNDEF;
+ break;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
+ }
+
+ /* check for no primary value and value of strict arith */
+ arith_return(K, res);
}
- /* 12.5.2 =? */
- /* uses typed_bpredp */
-
- /* 12.5.3 <?, <=?, >?, >=? */
- /* use typed_bpredp */
-
- /* Helpers for typed binary predicates */
- /* XXX: this should probably be in a file knumber.h but there is no real need for
- that file yet */
-
- /* this will come handy when there are more numeric types,
- it is intended to be used in switch */
- /* MAYBE: change to return -1, 0, 1 to indicate which type is bigger, and
- return min & max in two extra pointers passed in. Change name to
- classify_types */
- inline int32_t max_ttype(TValue obj1, TValue obj2)
- {
- int32_t t1 = ttype(obj1);
- int32_t t2 = ttype(obj2);
-
- return (t1 > t2? t1 : t2);
- }
-
- inline int32_t min_ttype(TValue obj1, TValue obj2)
- {
- int32_t t1 = ttype(obj1);
- int32_t t2 = ttype(obj2);
-
- return (t1 < t2? t1 : t2);
- }
-
- /* TEMP: for now only fixints, bigints, bigrats and exact infinities */
- bool knum_eqp(klisp_State *K, TValue n1, TValue n2)
- {
- switch(max_ttype(n1, n2)) {
- case K_TFIXINT:
- return ivalue(n1) == ivalue(n2);
- case K_TBIGINT:
- if (min_ttype(n1, n2) != K_TBIGINT) {
- /* NOTE: no fixint is =? to a bigint */
- return false;
- } else {
- /* both are bigints */
- return kbigint_eqp(n1, n2);
- }
- case K_TBIGRAT:
- if (min_ttype(n1, n2) != K_TBIGRAT) {
- /* NOTE: no fixint or bigint is =? to a bigrat */
- return false;
- } else {
- /* both are bigints */
- return kbigrat_eqp(K, n1, n2);
- }
- case K_TEINF:
- return (tv_equal(n1, n2));
- default:
- /* shouldn't happen */
- assert(0);
- return false;
- }
- }
-
- bool knum_ltp(klisp_State *K, TValue n1, TValue n2)
- {
- switch(max_ttype(n1, n2)) {
- case K_TFIXINT:
- return ivalue(n1) < ivalue(n2);
- case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_ltp(n1, n2);
- }
- case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_ltp(K, n1, n2);
- }
- case K_TEINF:
- return !tv_equal(n1, n2) && (tv_equal(n1, KEMINF) ||
- tv_equal(n2, KEPINF));
- default:
- /* shouldn't happen */
- assert(0);
- return false;
- }
- }
-
- bool knum_lep(klisp_State *K, TValue n1, TValue n2)
- {
- return !knum_ltp(K, n2, n1);
- }
- bool knum_gtp(klisp_State *K, TValue n1, TValue n2)
- {
- return knum_ltp(K, n2, n1);
- }
- bool knum_gep(klisp_State *K, TValue n1, TValue n2)
- {
- return !knum_ltp(K, n1, n2);
- }
-
- /* REFACTOR/MAYBE: add small inlineable plus that
- first tries fixint addition and if that fails calls knum_plus */
-
- /* May throw an error */
- /* GC: assumes n1 & n2 rooted */
- TValue knum_plus(klisp_State *K, TValue n1, TValue n2)
- {
- switch(max_ttype(n1, n2)) {
- case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) + (int64_t) ivalue(n2);
- if (res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
- }
- case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_plus(K, n1, n2);
- }
- case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_plus(K, n1, n2);
- }
- case K_TEINF:
- if (!ttiseinf(n1))
- return n2;
- else if (!ttiseinf(n2))
- return n1;
- if (tv_equal(n1, n2))
- return n1;
- else {
- klispE_throw_simple(K, "no primary value");
- return KINERT;
- }
- default:
- klispE_throw_simple(K, "unsopported type");
- return KINERT;
- }
- }
-
- /* May throw an error */
- /* GC: assumes n1 & n2 rooted */
- TValue knum_times(klisp_State *K, TValue n1, TValue n2)
- {
- switch(max_ttype(n1, n2)) {
- case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) * (int64_t) ivalue(n2);
- if (res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
- }
- case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_times(K, n1, n2);
- }
- case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_times(K, n1, n2);
- }
- case K_TEINF:
- if (!ttiseinf(n1) || !ttiseinf(n2)) {
- if (kfast_zerop(n1) || kfast_zerop(n2)) {
- /* report: #e+infinity * 0 has no primary value */
- klispE_throw_simple(K, "result has no primary value");
- return KINERT;
- } else
- return knum_same_signp(n1, n2)? KEPINF : KEMINF;
- } else
- return (tv_equal(n1, n2))? KEPINF : KEMINF;
- default:
- klispE_throw_simple(K, "unsopported type");
- return KINERT;
- }
- }
-
- /* May throw an error */
- /* GC: assumes n1 & n2 rooted */
- TValue knum_minus(klisp_State *K, TValue n1, TValue n2)
- {
- switch(max_ttype(n1, n2)) {
- case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) - (int64_t) ivalue(n2);
- if (res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
- }
- case K_TBIGINT: {
- kensure_bigint(n1);
- kensure_bigint(n2);
- return kbigint_minus(K, n1, n2);
- }
- case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_minus(K, n1, n2);
- }
- case K_TEINF:
- if (!ttiseinf(n1))
- return kneg_inf(n2);
- else if (!ttiseinf(n2))
- return n1;
- if (tv_equal(n1, n2)) {
- klispE_throw_simple(K, "no primary value");
- return KINERT;
+/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
+TValue knum_minus(klisp_State *K, TValue n1, TValue n2)
+{
+ kensure_same_exactness(K, n1, n2);
+ TValue res; /* used for results with no primary value */
+
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT: {
+ int64_t res = (int64_t) ivalue(n1) - (int64_t) ivalue(n2);
+ if (res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
+ }
+ case K_TBIGINT: {
+ kensure_bigint(n1);
+ kensure_bigint(n2);
+ return kbigint_minus(K, n1, n2);
+ }
+ case K_TBIGRAT: {
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_minus(K, n1, n2);
+ }
+ case K_TDOUBLE: {
+ /* both are double */
+ double res = dvalue(n1) - dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != dvalue(n2)) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
+ }
+ case K_TEINF:
+ if (!ttiseinf(n1))
+ return kneg_inf(n2);
+ else if (!ttiseinf(n2))
+ return n1;
+ if (tv_equal(n1, n2)) {
+ /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
} else
return n1;
+ case K_TIINF:
+ if (!ttisiinf(n1))
+ return kneg_inf(n2);
+ else if (!ttisiinf(n2))
+ return n1;
+ if (tv_equal(n1, n2)) {
+ /* no primary value; handle error at the end of function */
+ res = KRWNPV;
+ break;
+ } else
+ return n1;
+ case K_TRWNPV: /* no primary value */
+ res = KRWNPV;
+ break;
+ case K_TUNDEFINED: /* undefined */
+ res = KUNDEF;
+ break;
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
+
+ /* check for no primary value and value of strict arith */
+ arith_return(K, res);
}
- /* May throw an error */
- /* GC: assumes n1 & n2 rooted */
- TValue knum_divided(klisp_State *K, TValue n1, TValue n2)
- {
- /* first check the most common error, division by zero */
- if (kfast_zerop(n2)) {
- klispE_throw_simple(K, "division by zero (no primary value)");
- return KINERT;
- }
-
- switch(max_ttype(n1, n2)) {
- case K_TFIXINT: {
- int64_t res = (int64_t) ivalue(n1) / (int64_t) ivalue(n2);
- int64_t rem = (int64_t) ivalue(n1) % (int64_t) ivalue(n2);
- if (rem == 0 && res >= (int64_t) INT32_MIN &&
- res <= (int64_t) INT32_MAX) {
- return i2tv((int32_t) res);
- } /* else fall through */
- }
- case K_TBIGINT: /* just handle it as a rational */
- case K_TBIGRAT: {
- kensure_bigrat(n1);
- kensure_bigrat(n2);
- return kbigrat_divided(K, n1, n2);
- }
- case K_TEINF: {
- if (ttiseinf(n1) && ttiseinf(n2)) {
- klispE_throw_simple(K, "(infinity divided by infinity) "
- "no primary value");
- return KINERT;
- } else if (ttiseinf(n1)) {
- return knum_same_signp(n1, n2)? KEPINF : KEMINF;
- } else { /* ttiseinf(n2) */
- return i2tv(0);
- }
- }
- default:
- klispE_throw_simple(K, "unsopported type");
- return KINERT;
- }
+/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
+TValue knum_divided(klisp_State *K, TValue n1, TValue n2)
+{
+ kensure_same_exactness(K, n1, n2);
+ TValue res; /* used for results with no primary value */
+
+ /* first check the most common error, division by zero */
+ if (kfast_zerop(n2)) {
+ klispE_throw_simple(K, "division by zero");
+ return KINERT;
+ }
+
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT: {
+ int64_t res = (int64_t) ivalue(n1) / (int64_t) ivalue(n2);
+ int64_t rem = (int64_t) ivalue(n1) % (int64_t) ivalue(n2);
+ if (rem == 0 && res >= (int64_t) INT32_MIN &&
+ res <= (int64_t) INT32_MAX) {
+ return i2tv((int32_t) res);
+ } /* else fall through */
+ }
+ case K_TBIGINT: /* just handle it as a rational */
+ case K_TBIGRAT: {
+ kensure_bigrat(n1);
+ kensure_bigrat(n2);
+ return kbigrat_divided(K, n1, n2);
+ }
+ case K_TDOUBLE: {
+ double res = dvalue(n1) / dvalue(n2);
+ /* check under & overflow */
+ if (kcurr_strict_arithp(K)) {
+ if (res == 0 && dvalue(n1) != 0.0) {
+ klispE_throw_simple(K, "underflow");
+ return KINERT;
+ } else if (isinf(res)) {
+ klispE_throw_simple(K, "overflow");
+ return KINERT;
+ }
+ }
+ /* correctly encapsulate infinities and -0.0 */
+ return ktag_double(res);
+ }
+ case K_TEINF: {
+ if (ttiseinf(n1) && ttiseinf(n2)) {
+ klispE_throw_simple(K, "infinity divided by infinity");
+ return KINERT;
+ } else if (ttiseinf(n1)) {
+ return knum_same_signp(K, n1, n2)? KEPINF : KEMINF;
+ } else { /* ttiseinf(n2) */
+ return i2tv(0);
+ }
+ }
+ case K_TIINF:
+ if (ttisiinf(n1) && ttisiinf(n2)) {
+ klispE_throw_simple(K, "infinity divided by infinity");
+ return KINERT;
+ } else if (ttisiinf(n1)) {
+ return knum_same_signp(K, n1, n2)? KIPINF : KIMINF;
+ } else { /* ttiseinf(n2) */
+ /* NOTE: I guess this doens't count as underflow */
+ return d2tv(0.0);
+ }
+ case K_TRWNPV:
+ res = KRWNPV;
+ break;
+ case K_TUNDEFINED:
+ res = KUNDEF;
+ break;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return KINERT;
+ }
+
+ /* check for no primary value and value of strict arith */
+ arith_return(K, res);
}
/* GC: assumes n rooted */
@@ -312,32 +552,44 @@ TValue knum_abs(klisp_State *K, TValue n)
return (i < 0? i2tv(-i) : n);
/* if i == INT32_MIN, fall through */
/* MAYBE: we could cache the bigint INT32_MAX+1 */
+ /* else fall through */
}
case K_TBIGINT: {
- /* this is needed for INT32_MIN, can't be in previous
- case because it should be in the same block, remember
- the bigint is allocated on the stack. */
+ /* this is needed for INT32_MIN, can't be in previous
+ case because it should be in the same block, remember
+ the bigint is allocated on the stack. */
kensure_bigint(n);
return kbigint_abs(K, n);
}
case K_TBIGRAT: {
- kensure_bigrat(n);
return kbigrat_abs(K, n);
}
+ case K_TDOUBLE: {
+ return ktag_double(fabs(dvalue(n)));
+ }
case K_TEINF:
return KEPINF;
+ case K_TIINF:
+ return KIPINF;
+ case K_TRWNPV:
+ /* ASK John: is the error here okay */
+ arith_return(K, KRWNPV);
default:
/* shouldn't happen */
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
/* unlike the kernel gcd this returns |n| for gcd(n, 0) and gcd(0, n) and
- 0 for gcd(0, 0) */
+ 0 for gcd(0, 0) */
/* GC: assumes n1 & n2 rooted */
TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
{
+ /* this is not so nice but simplifies some cases */
+ /* XXX: this may cause overflows! */
+ kensure_same_exactness(K, n1, n2);
+
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
int64_t gcd = kgcd32_64(ivalue(n1), ivalue(n2));
@@ -352,6 +604,19 @@ TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
kensure_bigint(n2);
return kbigint_gcd(K, n1, n2);
}
+ case K_TDOUBLE: {
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_gcd(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
+ }
case K_TEINF:
if (kfast_zerop(n2) || !ttiseinf(n1))
return knum_abs(K, n1);
@@ -359,8 +624,15 @@ TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
return knum_abs(K, n2);
else
return KEPINF;
+ case K_TIINF:
+ if (kfast_zerop(n2) || !ttisiinf(n1))
+ return knum_abs(K, n1);
+ else if (kfast_zerop(n1) || !ttisiinf(n2))
+ return knum_abs(K, n2);
+ else
+ return KIPINF;
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
@@ -369,16 +641,19 @@ TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
/* GC: assumes n1 & n2 rooted */
TValue knum_lcm(klisp_State *K, TValue n1, TValue n2)
{
+ /* this is not so nice but simplifies some cases */
+ /* XXX: this may cause overflows! */
+ kensure_same_exactness(K, n1, n2);
+
/* get this out of the way first */
if (kfast_zerop(n1) || kfast_zerop(n2)) {
- klispE_throw_simple(K, "no primary value");
- return KINERT;
+ arith_return(K, KRWNPV);
}
switch(max_ttype(n1, n2)) {
case K_TFIXINT: {
int64_t lcm = klcm32_64(ivalue(n1), ivalue(n2));
- /* May fail for lcm(INT32_MIN, 1) because
+ /* May fail for lcm(INT32_MIN, 1) because
it would return INT32_MAX+1 */
if (kfit_int32_t(lcm))
return i2tv((int32_t) lcm);
@@ -389,10 +664,25 @@ TValue knum_lcm(klisp_State *K, TValue n1, TValue n2)
kensure_bigint(n2);
return kbigint_lcm(K, n1, n2);
}
+ case K_TDOUBLE: {
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_lcm(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
+ }
case K_TEINF:
return KEPINF;
+ case K_TIINF:
+ return KIPINF;
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
@@ -406,9 +696,17 @@ TValue knum_numerator(klisp_State *K, TValue n)
return n;
case K_TBIGRAT:
return kbigrat_numerator(K, n);
+ case K_TDOUBLE: {
+ TValue res = kinexact_to_exact(K, n);
+ krooted_vars_push(K, &res);
+ res = knum_numerator(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_vars_pop(K);
+ return res;
+ }
/* case K_TEINF: infinities are not rational! */
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
@@ -422,9 +720,17 @@ TValue knum_denominator(klisp_State *K, TValue n)
return i2tv(1); /* denominator of integer is always (+)1 */
case K_TBIGRAT:
return kbigrat_denominator(K, n);
+ case K_TDOUBLE: {
+ TValue res = kinexact_to_exact(K, n);
+ krooted_vars_push(K, &res);
+ res = knum_denominator(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_vars_pop(K);
+ return res;
+ }
/* case K_TEINF: infinities are not rational! */
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
@@ -438,21 +744,33 @@ TValue knum_real_to_integer(klisp_State *K, TValue n, kround_mode mode)
return n; /* integers are easy */
case K_TBIGRAT:
return kbigrat_to_integer(K, n, mode);
+ case K_TDOUBLE:
+ return kdouble_to_integer(K, n, mode);
case K_TEINF:
klispE_throw_simple(K, "infinite value");
return KINERT;
+ case K_TIINF:
+ klispE_throw_simple(K, "infinite value");
+ return KINERT;
+ case K_TRWNPV:
+ arith_return(K, KRWNPV);
+ case K_TUNDEFINED:
+ /* undefined in not a real, shouldn't get here, fall through */
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
{
+ /* this is not so nice but simplifies some cases */
+ /* XXX: this may cause overflows! */
+ kensure_same_exactness(K, n1, n2);
+
/* first check that case that n1 > n2 */
if (knum_gtp(K, n1, n2)) {
- klispE_throw_simple(K, "result with no primary value "
- "(n1 > n2)");
+ klispE_throw_simple(K, "x0 doesn't exists (n1 > n2)");
return KINERT;
}
@@ -466,14 +784,47 @@ TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
kensure_bigrat(n2);
return kbigrat_simplest_rational(K, n1, n2);
}
+ case K_TDOUBLE: {
+ /* both are double, for now just convert to rational */
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_simplest_rational(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
+ }
case K_TEINF:
/* we know that n1 <= n2 */
if (tv_equal(n1, n2)) {
- klispE_throw_simple(K, "result with no primary value");
+ klispE_throw_simple(K, "x0 doesn't exists (n1 == n2 & "
+ "irrational)");
return KINERT;
- } else if (knegativep(n1) && kpositivep(n2)) {
+ } else if (knegativep(K, n1) && kpositivep(K, n2)) {
return i2tv(0);
- } else if (knegativep(n1)) {
+ } else if (knegativep(K, n1)) {
+ /* n1 -inf, n2 finite negative */
+ /* ASK John: is this behaviour for infinities ok? */
+ /* Also in the report example both 1/3 & 1/2 are simpler than
+ 2/5... */
+ return knum_real_to_integer(K, n2, K_FLOOR);
+ } else {
+ /* n1 finite positive, n2 +inf */
+ /* ASK John: is this behaviour for infinities ok? */
+ return knum_real_to_integer(K, n1, K_CEILING);
+ }
+ case K_TIINF:
+ /* we know that n1 <= n2 */
+ if (tv_equal(n1, n2)) {
+ klispE_throw_simple(K, "result with no primary value");
+ return KINERT;
+ } else if (knegativep(K, n1) && kpositivep(K, n2)) {
+ return d2tv(0.0);
+ } else if (knegativep(K, n1)) {
/* n1 -inf, n2 finite negative */
/* ASK John: is this behaviour for infinities ok? */
/* Also in the report example both 1/3 & 1/2 are simpler than
@@ -484,14 +835,21 @@ TValue knum_simplest_rational(klisp_State *K, TValue n1, TValue n2)
/* ASK John: is this behaviour for infinities ok? */
return knum_real_to_integer(K, n1, K_CEILING);
}
+ case K_TRWNPV:
+ arith_return(K, KRWNPV);
+ /* complex and undefined should be captured by type predicate */
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
TValue knum_rationalize(klisp_State *K, TValue n1, TValue n2)
{
+ /* this is not so nice but simplifies some cases */
+ /* XXX: this may cause overflows! */
+ kensure_same_exactness(K, n1, n2);
+
switch(max_ttype(n1, n2)) {
case K_TFIXINT:
case K_TBIGINT: /* for now do all with bigrat */
@@ -501,16 +859,38 @@ TValue knum_rationalize(klisp_State *K, TValue n1, TValue n2)
kensure_bigrat(n2);
return kbigrat_rationalize(K, n1, n2);
}
+ case K_TDOUBLE: {
+ /* both are double, for now just convert to rational */
+ krooted_vars_push(K, &n1);
+ krooted_vars_push(K, &n2);
+ n1 = kinexact_to_exact(K, n1);
+ n2 = kinexact_to_exact(K, n2);
+ TValue res = knum_rationalize(K, n1, n2);
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return res;
+ }
case K_TEINF:
if (kfinitep(n1) || !kfinitep(n2)) {
return i2tv(0);
} else { /* infinite n1, finite n2 */
/* ASK John: is this behaviour for infinities ok? */
- klispE_throw_simple(K, "result with no primary value");
+ klispE_throw_simple(K, "x0 doesn't exists");
+ return KINERT;
+ }
+ case K_TIINF:
+ if (kfinitep(n1) || !kfinitep(n2)) {
+ return d2tv(0.0);
+ } else { /* infinite n1, finite n2 */
+ /* ASK John: is this behaviour for infinities ok? */
+ klispE_throw_simple(K, "x0 doesn't exists");
return KINERT;
}
default:
- klispE_throw_simple(K, "unsopported type");
+ klispE_throw_simple(K, "unsupported type");
return KINERT;
}
}
@@ -522,8 +902,8 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue 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 pairs = check_typed_list(K, "+", "number", knumberp,
+ true, ptree, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -544,12 +924,14 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* next the cyclic part */
TValue cres = i2tv(0); /* push it only if needed */
- if (cpairs == 0) {
- /* speed things up if there is no cycle */
+ if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
+ /* speed things up if there is no cycle and
+ no possible error (on no primary value) */
res = ares;
krooted_vars_pop(K);
} else {
bool all_zero = true;
+ bool all_exact = true;
krooted_vars_push(K, &cres);
while(cpairs--) {
@@ -557,18 +939,22 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
tail = kcdr(tail);
all_zero = all_zero && kfast_zerop(first);
+ all_exact = all_exact && ttisexact(first);
cres = knum_plus(K, cres, first);
}
- if (kfast_zerop(cres)) {
- if (!all_zero) {
- /* report */
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
- } else
- cres = knegativep(cres)? KEMINF : KEPINF;
+ if (ttisnwnpv(cres)) /* #undefined or #real */
+ ; /* do nothing, check is made later */
+ else if (kfast_zerop(cres)) {
+ if (!all_zero)
+ cres = KRWNPV; /* check is made later */
+ } else if (all_exact)
+ cres = knegativep(K, cres)? KEMINF : KEPINF;
+ else
+ cres = knegativep(K, cres)? KIMINF : KIPINF;
+
+ /* here if any of the two has no primary an error is signaled */
res = knum_plus(K, ares, cres);
krooted_vars_pop(K);
krooted_vars_pop(K);
@@ -603,43 +989,50 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* next the cyclic part */
TValue cres = i2tv(1);
- if (cpairs == 0) {
+ if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
/* speed things up if there is no cycle */
res = ares;
krooted_vars_pop(K);
} else {
bool all_one = true;
+ bool all_exact = true;
krooted_vars_push(K, &cres);
while(cpairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
all_one = all_one && kfast_onep(first);
+ all_exact = all_exact && ttisexact(first);
cres = knum_times(K, cres, first);
}
/* think of cres as the product of an infinite series */
+ if (ttisnwnpv(ares))
+ ; /* do nothing */
if (kfast_zerop(cres))
; /* do nothing */
- else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1)))
- cres = i2tv(0);
+ else if (kpositivep(K, cres) && knum_ltp(K, cres, i2tv(1))) {
+ if (all_exact)
+ cres = i2tv(0);
+ else
+ cres = d2tv(0.0);
+ }
else if (kfast_onep(cres)) {
- if (all_one)
- cres = i2tv(1);
- else {
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
+ if (all_one) {
+ if (all_exact)
+ cres = i2tv(1);
+ else
+ cres = d2tv(1.0);
+ } else
+ cres = KRWNPV;
} else if (knum_gtp(K, cres, i2tv(1))) {
/* ASK JOHN: this is as per the report, but maybe we should check
that all elements are positive... */
- cres = KEPINF;
- } else {
- /* cycle result less than zero */
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
+ cres = all_exact? KEPINF : KIPINF;
+ } else
+ cres = KRWNPV;
+ /* this will throw error if necessary on no primary value */
res = knum_times(K, ares, cres);
krooted_vars_pop(K);
krooted_vars_pop(K);
@@ -683,35 +1076,43 @@ void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* next the cyclic part */
- TValue cres = i2tv(0);
+ TValue cres = i2tv(0); /* push it only if needed */
- if (cpairs == 0) {
- /* speed things up if there is no cycle */
+ if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
+ /* speed things up if there is no cycle and
+ no possible error (on no primary value) */
res = ares;
krooted_vars_pop(K);
} else {
bool all_zero = true;
+ bool all_exact = true;
krooted_vars_push(K, &cres);
while(cpairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
+
all_zero = all_zero && kfast_zerop(first);
+ all_exact = all_exact && ttisexact(first);
+
cres = knum_plus(K, cres, first);
}
- if (kfast_zerop(cres)) {
- if (!all_zero) {
- /* report */
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
- } else
- cres = knegativep(cres)? KEMINF : KEPINF;
+ if (ttisnwnpv(cres)) /* #undefined or #real */
+ ; /* do nothing, check is made later */
+ else if (kfast_zerop(cres)) {
+ if (!all_zero)
+ cres = KRWNPV; /* check is made later */
+ } else if (all_exact)
+ cres = knegativep(K, cres)? KEMINF : KEPINF;
+ else
+ cres = knegativep(K, cres)? KIMINF : KIPINF;
+
+ /* here if any of the two has no primary an error is signaled */
res = knum_plus(K, ares, cres);
krooted_vars_pop(K);
krooted_vars_pop(K);
- }
+ }
/* now substract the sum of all the elements in the list to the first
value */
krooted_tvs_push(K, res);
@@ -807,6 +1208,8 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue tv_div, tv_mod;
+ kensure_same_exactness(K, tv_n, tv_d);
+
if (kfast_zerop(tv_d)) {
klispE_throw_simple(K, "division by zero");
return;
@@ -849,6 +1252,17 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
else
tv_div = kbigrat_div0_mod0(K, tv_n, tv_d, &tv_mod);
break;
+ case K_TDOUBLE: {
+ /* both are double */
+ double div, mod;
+ if ((flags & FDIV_ZERO) == 0)
+ div = kdouble_div_mod(dvalue(tv_n), dvalue(tv_d), &mod);
+ else
+ div = kdouble_div0_mod0(dvalue(tv_n), dvalue(tv_d), &mod);
+ tv_div = ktag_double(div);
+ tv_mod = ktag_double(mod);
+ break;
+ }
case K_TEINF:
if (ttiseinf(tv_n)) {
klispE_throw_simple(K, "non finite dividend");
@@ -874,10 +1288,49 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
klispE_throw_simple(K, "non finite divisor");
return;
}
- default:
- klispE_throw_simple(K, "unsopported type");
- return;
- }
+ case K_TIINF:
+ if (ttisiinf(tv_n)) {
+ klispE_throw_simple(K, "non finite dividend");
+ return;
+ } else { /* if (ttiseinf(tv_d)) */
+ /* The semantics here are unclear, following the general
+ guideline of the report that says that if an infinity is
+ involved it should be understand as a limit. In that
+ case once the divisor is greater in magnitude than the
+ dividend the division stabilizes itself at q = 0; r = n
+ if both have the same sign, and q = 1; r = +infinity if
+ both have different sign (but in that case !(r < |d|)
+ !!) */
+ /* RATIONALE: if q were 0 we can't accomplish
+ q * d + r = n because q * d is undefined, if q isn't zero
+ then, either q*d + r is infinite or undefined so
+ there's no good q. on the other hand if we want
+ n - q*d = r & 0 <= r < d, r can't be infinite because it
+ would be equal to d, but q*d is infinite, so there's no
+ way out */
+ /* throw an exception, until this is resolved */
+ /* ASK John */
+ klispE_throw_simple(K, "non finite divisor");
+ return;
+ }
+ case K_TRWNPV: { /* no primary value */
+ /* ASK John: what happens with undefined & real with no primary values */
+ TValue n = ttisrwnpv(tv_n)? tv_n : tv_d;
+ if (kcurr_strict_arithp(K)) {
+ klispE_throw_simple_with_irritants(K, "operand has no primary "
+ "value", 1, n);
+ return;
+ } else {
+ tv_div = KRWNPV;
+ tv_mod = KRWNPV;
+ break;
+ }
+ }
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+
TValue res;
if (flags & FDIV_DIV) {
@@ -903,41 +1356,53 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* use ftyped_predp */
/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(TValue n)
+bool kpositivep(klisp_State *K, TValue n)
{
switch (ttype(n)) {
case K_TFIXINT:
case K_TEINF:
+ case K_TIINF:
return ivalue(n) > 0;
case K_TBIGINT:
return kbigint_positivep(n);
case K_TBIGRAT:
return kbigrat_positivep(n);
+ case K_TDOUBLE:
+ return dvalue(n) > 0.0;
+ case K_TRWNPV:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return false;
+ /* complex and undefined should be captured by type predicate */
default:
- /* shouldn't happen */
- assert(0);
+ klispE_throw_simple(K, "unsupported type");
return false;
}
}
-bool knegativep(TValue n)
+bool knegativep(klisp_State *K, TValue n)
{
switch (ttype(n)) {
case K_TFIXINT:
case K_TEINF:
+ case K_TIINF:
return ivalue(n) < 0;
case K_TBIGINT:
return kbigint_negativep(n);
case K_TBIGRAT:
return kbigrat_negativep(n);
+ case K_TDOUBLE:
+ return dvalue(n) < 0.0;
+ case K_TRWNPV:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return false;
+ /* complex and undefined should be captured by type predicate */
default:
- /* shouldn't happen */
- assert(0);
+ klispE_throw_simple(K, "unsupported type");
return false;
}
}
-/* n is finite */
+/* n is finite, integer */
bool koddp(TValue n)
{
switch (ttype(n)) {
@@ -945,8 +1410,9 @@ bool koddp(TValue n)
return (ivalue(n) & 1) != 0;
case K_TBIGINT:
return kbigint_oddp(n);
+ case K_TDOUBLE:
+ return fmod(dvalue(n), 2.0) != 0.0;
default:
- /* shouldn't happen */
assert(0);
return false;
}
@@ -959,8 +1425,9 @@ bool kevenp(TValue n)
return (ivalue(n) & 1) == 0;
case K_TBIGINT:
return kbigint_evenp(n);
+ case K_TDOUBLE:
+ return fmod(dvalue(n), 2.0) == 0.0;
default:
- /* shouldn't happen */
assert(0);
return false;
}
@@ -980,7 +1447,7 @@ void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 12.5.13 min, max */
/* NOTE: this does two passes, one for error checking and one for doing
- the actual work */
+ the actual work */
void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
/*
@@ -995,7 +1462,7 @@ void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* cycles are allowed, loop counting pairs */
int32_t dummy; /* don't care about count of cycle pairs */
int32_t pairs = check_typed_list(K, name, "number", knumberp, true, ptree,
- &dummy);
+ &dummy);
TValue res;
@@ -1041,19 +1508,16 @@ void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue first = kcar(tail);
tail = kcdr(tail);
seen_finite_non_zero |=
- (!ttiseinf(first) && !kfast_zerop(first));
+ (!ttisinf(first) && !kfast_zerop(first));
res = knum_gcd(K, res, first);
}
- if (!seen_finite_non_zero) {
- /* report */
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
+ if (!seen_finite_non_zero)
+ res = KRWNPV;
}
krooted_vars_pop(K);
- kapply_cc(K, res);
+ arith_kapply_cc(K, res);
}
void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
@@ -1081,7 +1545,142 @@ void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
-/* TODO: remaining of rational module */
+/* 12.6.1 exact?, inexact?, robust?, undefined? */
+/* use fyped_predp */
+
+/* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
+void kget_real_internal_bounds(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ bind_1tp(K, ptree, "real", krealp, tv_n);
+ /* TEMP: do it here directly, for now all inexact objects have
+ [-inf, +inf] bounds */
+ TValue res;
+ if (ttisexact(tv_n)) {
+ res = klist(K, 2, tv_n, tv_n);
+ } else {
+ res = klist(K, 2, KIMINF, KIPINF);
+ }
+ kapply_cc(K, res);
+}
+
+void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ bind_1tp(K, ptree, "real", krealp, tv_n);
+ /* TEMP: do it here directly, for now all inexact objects have
+ [-inf, +inf] bounds, when bounded reals are implemented this
+ should take care to round the min towards -inf and the max towards
+ +inf when converting to exact */
+ TValue res;
+ if (ttisexact(tv_n)) {
+ res = klist(K, 2, tv_n, tv_n);
+ } else {
+ res = klist(K, 2, KEMINF, KEPINF);
+ }
+ kapply_cc(K, res);
+}
+
+/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
+void kget_real_internal_primary(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ bind_1tp(K, ptree, "real", krealp, tv_n);
+ /* TEMP: do it here directly */
+ if (ttisrwnpv(tv_n)) {
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, tv_n);
+ return;
+ } else {
+ kapply_cc(K, tv_n);
+ }
+}
+
+void kget_real_exact_primary(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ bind_1tp(K, ptree, "real", krealp, tv_n);
+
+ /* NOTE: this handles no primary value errors & exact cases just fine */
+ TValue res = kinexact_to_exact(K, tv_n);
+ kapply_cc(K, res);
+}
+
+/* 12.6.4 make-inexact */
+void kmake_inexact(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ bind_3tp(K, ptree, "real", krealp, real1,
+ "real", krealp, real2, "real", krealp, real3);
+
+ TValue res;
+ UNUSED(real1);
+ UNUSED(real3);
+ if (ttisinexact(real2)) {
+ res = real2;
+ } else {
+ /* TEMP: for now bounds are ignored */
+ /* NOTE: this handles overflow and underflow */
+ res = kexact_to_inexact(K, real2);
+ }
+ kapply_cc(K, res);
+}
+
+/* 12.6.5 real->inexact, real->exact */
+void kreal_to_inexact(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_1tp(K, ptree, "real", krealp, tv_n);
+
+ /* NOTE: this handles overflow and underflow */
+ TValue res = kexact_to_inexact(K, tv_n);
+ kapply_cc(K, res);
+}
+
+void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_1tp(K, ptree, "real", krealp, tv_n);
+
+ TValue res = kinexact_to_exact(K, tv_n);
+ kapply_cc(K, res);
+}
+
+/* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
+void kwith_strict_arithmetic(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ bind_2tp(K, ptree, "bool", ttisboolean, strictp,
+ "combiner", ttiscombiner, comb);
+
+ TValue op = kmake_operative(K, do_bind, 1, K->kd_strict_arith_key);
+ krooted_tvs_push(K, op);
+
+ TValue args = klist(K, 2, strictp, comb);
+
+ krooted_tvs_pop(K);
+
+ /* even if we call with denv, do_bind calls comb in an empty env */
+ /* XXX: what to pass for source info?? */
+ ktail_call(K, op, args, denv);
+}
+
+void kget_strict_arithmeticp(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ check_0p(K, ptree);
+
+ /* can access directly, no need to call do_access */
+ TValue res = b2tv(kcurr_strict_arithp(K));
+ kapply_cc(K, res);
+}
/* 12.8.1 rational? */
/* uses ftypep */
@@ -1124,47 +1723,55 @@ void kdivided(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* next the cyclic part */
TValue cres = i2tv(1);
- if (cpairs == 0) {
+ if (cpairs == 0 && !ttisnwnpv(ares)) { /* #undefined or #real */
/* speed things up if there is no cycle */
res = ares;
krooted_vars_pop(K);
} else {
bool all_one = true;
+ bool all_exact = true;
krooted_vars_push(K, &cres);
while(cpairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
all_one = all_one && kfast_onep(first);
+ all_exact = all_exact && ttisexact(first);
cres = knum_times(K, cres, first);
}
/* think of cres as the product of an infinite series */
+ if (ttisnwnpv(ares))
+ ; /* do nothing */
if (kfast_zerop(cres))
; /* do nothing */
- else if (kpositivep(cres) && knum_ltp(K, cres, i2tv(1)))
- cres = i2tv(0);
+ else if (kpositivep(K, cres) && knum_ltp(K, cres, i2tv(1))) {
+ if (all_exact)
+ cres = i2tv(0);
+ else
+ cres = d2tv(0.0);
+ }
else if (kfast_onep(cres)) {
- if (all_one)
- cres = i2tv(1);
- else {
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
+ if (all_one) {
+ if (all_exact)
+ cres = i2tv(1);
+ else
+ cres = d2tv(1.0);
+ } else
+ cres = KRWNPV;
} else if (knum_gtp(K, cres, i2tv(1))) {
/* ASK JOHN: this is as per the report, but maybe we should check
that all elements are positive... */
- cres = KEPINF;
- } else {
- /* cycle result less than zero */
- klispE_throw_simple(K, "result has no primary value");
- return;
- }
+ cres = all_exact? KEPINF : KIPINF;
+ } else
+ cres = KRWNPV;
+ /* this will throw error if necessary on no primary value */
res = knum_times(K, ares, cres);
krooted_vars_pop(K);
krooted_vars_pop(K);
}
+
/* now divide first value by the product of all the elements in the list */
krooted_tvs_push(K, res);
res = knum_divided(K, first_val, res);
@@ -1239,3 +1846,370 @@ void ksimplest_rational(klisp_State *K, TValue *xparams, TValue ptree,
TValue res = knum_simplest_rational(K, n1, n2);
kapply_cc(K, res);
}
+
+void kexp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_1tp(K, ptree, "number", knumberp, n);
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d = exp(dvalue(n));
+ res = ktag_double(d);
+ break;
+ }
+ case K_TEINF: /* in any case return inexact result (e is inexact) */
+ case K_TIINF:
+ res = kpositivep(K, n)? KIPINF : d2tv(0.0);
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ /* complex and undefined should be captured by type predicate */
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ kapply_cc(K, res);
+}
+
+void klog(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_1tp(K, ptree, "number", knumberp, n);
+
+ /* ASK John: error or no primary value, or undefined */
+ if (kfast_zerop(n)) {
+ klispE_throw_simple_with_irritants(K, "zero argument", 1, n);
+ return;
+ } else if (knegativep(K, n)) {
+ klispE_throw_simple_with_irritants(K, "negative argument", 1, n);
+ return;
+ }
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d = log(dvalue(n));
+ res = ktag_double(d);
+ break;
+ }
+ case K_TEINF: /* in any case return inexact result (e is inexact) */
+ case K_TIINF:
+ /* is this ok? */
+ res = KIPINF;
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ /* complex and undefined should be captured by type predicate */
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ kapply_cc(K, res);
+}
+
+void ktrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: trig function
+ */
+ double (*fn)(double) = pvalue(xparams[0]);
+
+ bind_1tp(K, ptree, "number", knumberp, n);
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d = (*fn)(dvalue(n));
+ res = ktag_double(d);
+ break;
+ }
+ case K_TEINF:
+ case K_TIINF:
+ /* is this ok? */
+ res = KRWNPV;
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ arith_kapply_cc(K, res);
+}
+
+void katrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: trig function
+ */
+ double (*fn)(double) = pvalue(xparams[0]);
+
+ bind_1tp(K, ptree, "number", knumberp, n);
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d = dvalue(n);
+ if (d >= -1.0 && d <= 1.0) {
+ d = (*fn)(dvalue(n));
+ res = ktag_double(d);
+ } else {
+ res = KUNDEF; /* ASK John: is this ok, or should throw error? */
+ }
+ break;
+ }
+ case K_TEINF:
+ case K_TIINF:
+ /* ASK John: is this ok? */
+ res = KRWNPV;
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ arith_kapply_cc(K, res);
+}
+
+void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_al1tp(K, ptree, "number", knumberp, n1, rest);
+ bool two_params;
+ TValue n2;
+ if (ttisnil(rest)) {
+ two_params = false;
+ n2 = n1;
+ } else {
+ two_params = true;
+ if (!ttispair(rest) || !ttisnil(kcdr(rest))) {
+ klispE_throw_simple(K, "Bad ptree structure (in optional "
+ "argument)");
+ return;
+ } else if (!ttisnumber(kcar(rest))) {
+ klispE_throw_simple(K, "Bad type on optional argument "
+ "(expected number)");
+ return;
+ } else {
+ n2 = kcar(rest);
+ kensure_same_exactness(K, n1, n2);
+ }
+ }
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* for now, all go to double */
+ n1 = kexact_to_inexact(K, n1); /* no need to root it */
+ if (two_params)
+ n2 = kexact_to_inexact(K, n2); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d1 = dvalue(n1);
+ if (two_params) {
+ double d2 = dvalue(n2);
+ d1 = atan2(d1, d2);
+ } else {
+ d1 = atan(d1);
+ }
+ res = ktag_double(d1);
+ break;
+ }
+ case K_TEINF:
+ case K_TIINF:
+ /* ASK John: is this ok? */
+ if (two_params) {
+ if (kfinitep(n1)) {
+ res = ktag_double(0.0);
+ } else if (!kfinitep(n2)) {
+ klispE_throw_simple_with_irritants(K, "infinite divisor & "
+ "dividend", 2, n1, n2);
+ return;
+ } else {
+ /* XXX either pi/2 or -pi/2, but we don't have the constant */
+ double d = knum_same_signp(K, n1, n2)? atan(INFINITY) :
+ atan(-INFINITY);
+ res = ktag_double(d);
+ }
+ } else {
+ /* XXX either pi/2 or -pi/2, but we don't have the constant */
+ double d = kpositivep(K, n1)? atan(INFINITY) : atan(-INFINITY);
+ res = ktag_double(d);
+ }
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ if (two_params) {
+ klispE_throw_simple_with_irritants(K, "no primary value", 2,
+ n1, n2);
+ } else {
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n1);
+ }
+ return;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ arith_kapply_cc(K, res);
+}
+
+void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_1tp(K, ptree, "number", knumberp, n);
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* TEMP: for now, all go to double */
+ n = kexact_to_inexact(K, n); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d = dvalue(n);
+ if (d < 0.0)
+ res = KUNDEF; /* ASK John: is this ok, or should throw error? */
+ else {
+ d = sqrt(d);
+ res = ktag_double(d);
+ }
+ break;
+ }
+ case K_TEINF:
+ case K_TIINF:
+ res = knegativep(K, n)? KUNDEF : KIPINF;
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ arith_kapply_cc(K, res);
+}
+
+void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_2tp(K, ptree, "number", knumberp, n1,
+ "number", knumberp, n2);
+
+ kensure_same_exactness(K, n1, n2);
+
+ /* TEMP: do it inline for now */
+ TValue res = i2tv(0);
+ switch(max_ttype(n1, n2)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ /* TEMP: for now, all go to double */
+ n1 = kexact_to_inexact(K, n1); /* no need to root it */
+ n2 = kexact_to_inexact(K, n2); /* no need to root it */
+ /* fall through */
+ case K_TDOUBLE: {
+ double d1 = dvalue(n1);
+ double d2 = dvalue(n2);
+ d1 = pow(d1, d2);
+ res = ktag_double(d1);
+ break;
+ }
+ case K_TEINF:
+ case K_TIINF:
+ if (ttisinf(n1) && ttisinf(n2)) {
+ if (knegativep(K, n1) && knegativep(K, n2))
+ res = d2tv(0.0);
+ else if (knegativep(K, n1) || knegativep(K, n2))
+ res = KUNDEF; /* ASK John: is this ok? */
+ else
+ res = KIPINF;
+ } else if (ttisinf(n1)) {
+ if (knegativep(K, n1)) {
+ if (knegativep(K, n2))
+ res = d2tv(0.0);
+ else {
+ TValue num = knum_numerator(K, n2);
+ krooted_tvs_push(K, num);
+ res = kevenp(num)? KIPINF : KIMINF;
+ krooted_tvs_pop(K);
+ }
+ } else {
+ res = KIPINF;
+ }
+ } else { /* ttisinf(n2) */
+ if (knegativep(K, n2))
+ res = d2tv(0.0);
+ else if (knegativep(K, n1))
+ res = KUNDEF; /* ASK John: is this ok? */
+ else
+ res = KIPINF;
+ }
+ break;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 2,
+ n1, n2);
+ return;
+ default:
+ klispE_throw_simple(K, "unsupported type");
+ return;
+ }
+ arith_kapply_cc(K, res);
+}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -25,10 +25,17 @@
/* XXX: this should probably be in a file knumber.h but there is no real need for
that file yet */
bool knumberp(TValue obj);
+bool knumber_wpvp(TValue obj);
bool kfinitep(TValue obj);
bool kintegerp(TValue obj);
+bool keintegerp(TValue obj);
bool krationalp(TValue obj);
bool krealp(TValue obj);
+bool kreal_wpvp(TValue obj);
+bool kexactp(TValue obj);
+bool kinexactp(TValue obj);
+bool kundefinedp(TValue obj);
+bool krobustp(TValue obj);
/* 12.5.2 =? */
@@ -77,8 +84,8 @@ bool kzerop(TValue n);
/* use ftyped_predp */
/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(TValue n);
-bool knegativep(TValue n);
+bool kpositivep(klisp_State *K, TValue n);
+bool knegativep(klisp_State *K, TValue n);
bool koddp(TValue n);
bool kevenp(TValue n);
@@ -111,6 +118,37 @@ void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+/* 12.6.1 exact?, inexact?, robust?, undefined? */
+/* use fyped_predp */
+
+/* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
+void kget_real_internal_bounds(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
+void kget_real_internal_primary(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv);
+void kget_real_exact_primary(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv);
+
+/* 12.6.4 make-inexact */
+void kmake_inexact(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 12.6.5 real->inexact, real->exact */
+void kreal_to_inexact(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
+void kwith_strict_arithmetic(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+void kget_strict_arithmeticp(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
/* 12.8.1 rational? */
/* uses ftypep */
@@ -132,21 +170,55 @@ void krationalize(klisp_State *K, TValue *xparams, TValue ptree,
void ksimplest_rational(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
+
+/* 12.9.1 real? */
+/* uses ftypep */
+
+/* 12.9.2 exp, log */
+void kexp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void klog(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 12.9.3 sin, cos, tan */
+void ktrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 12.9.4 asin, acos, atan */
+void katrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 12.9.5 sqrt */
+void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 12.9.6 expt */
+void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+
/* REFACTOR: These should be in a knumber.h header */
/* Misc Helpers */
-/* TEMP: only infinities, fixints and bigints for now */
-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 */
+/* TEMP: only reals (no complex numbers) */
+inline bool kfast_zerop(TValue n)
+{
+ return (ttisfixint(n) && ivalue(n) == 0) ||
+ (ttisdouble(n) && dvalue(n) == 0.0);
+}
+
+inline bool kfast_onep(TValue n)
+{
+ return (ttisfixint(n) && ivalue(n) == 1) ||
+ (ttisdouble(n) && dvalue(n) == 1.0);
+}
+
inline TValue kneg_inf(TValue i)
{
- return tv_equal(i, KEPINF)? KEMINF : KEPINF;
+ if (ttiseinf(i))
+ return tv_equal(i, KEPINF)? KEMINF : KEPINF;
+ else /* ttisiinf(i) */
+ return tv_equal(i, KIPINF)? KIMINF : KIPINF;
}
-inline bool knum_same_signp(TValue n1, TValue n2)
+inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
{
- return kpositivep(n1) == kpositivep(n2);
+ return kpositivep(K, n1) == kpositivep(K, n2);
}
#endif
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -20,7 +20,7 @@
#include "kghelpers.h"
#include "kgpair_mut.h"
#include "kgeqp.h" /* eq? checking in memq and assq */
-#include "kgnumbers.h" /* for kpositivep and kintegerp */
+#include "kgnumbers.h" /* for kpositivep and keintegerp */
/* 4.7.1 set-car!, set-cdr! */
void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
@@ -167,10 +167,10 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, obj,
- "integer", kintegerp, tk1,
- "integer", kintegerp, tk2);
+ "exact integer", keintegerp, tk1,
+ "exact integer", keintegerp, tk2);
- if (knegativep(tk1) || knegativep(tk2)) {
+ if (knegativep(K, tk1) || knegativep(K, tk2)) {
klispE_throw_simple(K, "negative index");
return;
}
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -239,9 +239,9 @@ void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "any", anytype, obj,
- "integer", kintegerp, tk);
+ "exact integer", keintegerp, tk);
- if (knegativep(tk)) {
+ if (knegativep(K, tk)) {
klispE_throw_simple(K, "negative index");
return;
}
@@ -292,9 +292,9 @@ void list_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(xparams);
bind_2tp(K, ptree, "any", anytype, obj,
- "integer", kintegerp, tk);
+ "exact integer", keintegerp, tk);
- if (knegativep(tk)) {
+ if (knegativep(K, tk)) {
klispE_throw_simple(K, "negative index");
return;
}
diff --git a/src/kground.c b/src/kground.c
@@ -9,6 +9,7 @@
#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>
+#include <math.h>
#include "kstate.h"
#include "kobject.h"
@@ -46,6 +47,7 @@
#include "keval.h"
#include "krepl.h"
+
/*
** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
** "value", both of type TValue. symbol will be bound to a symbol named by
@@ -735,17 +737,17 @@ void kinit_ground_env(klisp_State *K)
/* 12.5.2 =? */
add_applicative(K, ground_env, "=?", ftyped_kbpredp, 3,
- symbol, p2tv(knumberp), p2tv(knum_eqp));
+ symbol, p2tv(knumber_wpvp), p2tv(knum_eqp));
/* 12.5.3 <?, <=?, >?, >=? */
add_applicative(K, ground_env, "<?", ftyped_kbpredp, 3,
- symbol, p2tv(krealp), p2tv(knum_ltp));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_ltp));
add_applicative(K, ground_env, "<=?", ftyped_kbpredp, 3,
- symbol, p2tv(krealp), p2tv(knum_lep));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_lep));
add_applicative(K, ground_env, ">?", ftyped_kbpredp, 3,
- symbol, p2tv(krealp), p2tv(knum_gtp));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_gtp));
add_applicative(K, ground_env, ">=?", ftyped_kbpredp, 3,
- symbol, p2tv(krealp), p2tv(knum_gep));
+ symbol, p2tv(kreal_wpvp), p2tv(knum_gep));
/* 12.5.4 + */
add_applicative(K, ground_env, "+", kplus, 0);
@@ -800,6 +802,45 @@ void kinit_ground_env(klisp_State *K)
add_applicative(K, ground_env, "lcm", klcm, 0);
/*
+ ** 12.8 Inexact features
+ */
+
+ /* 12.6.1 exact?, inexact?, robust?, undefined? */
+ add_applicative(K, ground_env, "exact?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kexactp));
+ add_applicative(K, ground_env, "inexact?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kinexactp));
+ add_applicative(K, ground_env, "robust?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(krobustp));
+ add_applicative(K, ground_env, "undefined?", ftyped_predp, 3, symbol,
+ p2tv(knumberp), p2tv(kundefinedp));
+
+ /* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
+ add_applicative(K, ground_env, "get-real-internal-bounds",
+ kget_real_internal_bounds, 0);
+ add_applicative(K, ground_env, "get-real-exact-bounds",
+ kget_real_exact_bounds, 0);
+
+ /* 12.6.3 get-real-internal-primary, get-real-exact-primary */
+ add_applicative(K, ground_env, "get-real-internal-primary",
+ kget_real_internal_primary, 0);
+ add_applicative(K, ground_env, "get-real-exact-primary",
+ kget_real_exact_primary, 0);
+
+ /* 12.6.4 make-inexact */
+ add_applicative(K, ground_env, "make-inexact", kmake_inexact, 0);
+
+ /* 12.6.5 real->inexact, real->exact */
+ add_applicative(K, ground_env, "real->inexact", kreal_to_inexact, 0);
+ add_applicative(K, ground_env, "real->exact", kreal_to_exact, 0);
+
+ /* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
+ add_applicative(K, ground_env, "with-strict-arithmetic",
+ kwith_strict_arithmetic, 0);
+ add_applicative(K, ground_env, "get-strict-arithmetic?",
+ kget_strict_arithmeticp, 0);
+
+ /*
** 12.8 Rational features
*/
@@ -828,6 +869,34 @@ void kinit_ground_env(klisp_State *K)
add_applicative(K, ground_env, "rationalize", krationalize, 0);
add_applicative(K, ground_env, "simplest-rational", ksimplest_rational, 0);
+ /*
+ ** 12.9 Real features
+ */
+
+ /* 12.9.1 real? */
+ add_applicative(K, ground_env, "real?", ftypep, 2, symbol,
+ p2tv(krealp));
+
+ /* 12.9.2 exp, log */
+ add_applicative(K, ground_env, "exp", kexp, 0);
+ add_applicative(K, ground_env, "log", klog, 0);
+
+ /* 12.9.3 sin, cos, tan */
+ add_applicative(K, ground_env, "sin", ktrig, 1, sin);
+ add_applicative(K, ground_env, "cos", ktrig, 1, cos);
+ add_applicative(K, ground_env, "tan", ktrig, 1, tan);
+
+ /* 12.9.4 asin, acos, atan */
+ add_applicative(K, ground_env, "asin", katrig, 1, asin);
+ add_applicative(K, ground_env, "acos", katrig, 1, acos);
+ add_applicative(K, ground_env, "atan", katan, 0);
+
+ /* 12.9.5 sqrt */
+ add_applicative(K, ground_env, "sqrt", ksqrt, 0);
+
+ /* 12.9.6 expt */
+ add_applicative(K, ground_env, "expt", kexpt, 0);
+
/*
**
** 13 Strings
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -24,7 +24,7 @@
#include "kghelpers.h"
#include "kgchars.h" /* for kcharp */
#include "kgstrings.h"
-#include "kgnumbers.h" /* for kintegerp & knegativep */
+#include "kgnumbers.h" /* for keintegerp & knegativep */
/* 13.1.1? string? */
/* uses typep */
@@ -34,14 +34,14 @@ void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
UNUSED(denv);
- bind_al1tp(K, ptree, "integer", kintegerp, tv_s,
+ bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
maybe_char);
char fill = ' ';
if (get_opt_tpar(K, "make-string", K_TCHAR, &maybe_char))
fill = chvalue(maybe_char);
- if (knegativep(tv_s)) {
+ if (knegativep(K, tv_s)) {
klispE_throw_simple(K, "negative size");
return;
} else if (!ttisfixint(tv_s)) {
@@ -71,7 +71,7 @@ void string_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, str,
- "integer", kintegerp, tv_i);
+ "exact integer", keintegerp, tv_i);
if (!ttisfixint(tv_i)) {
/* TODO show index */
@@ -96,7 +96,7 @@ void string_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "string", ttisstring, str,
- "integer", kintegerp, tv_i, "char", ttischar, tv_ch);
+ "exact integer", keintegerp, tv_i, "char", ttischar, tv_ch);
if (!ttisfixint(tv_i)) {
/* TODO show index */
@@ -245,8 +245,8 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "string", ttisstring, str,
- "integer", kintegerp, tv_start,
- "integer", kintegerp, tv_end);
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
ivalue(tv_start) > kstring_size(str)) {
diff --git a/src/kobject.c b/src/kobject.c
@@ -20,6 +20,10 @@ const TValue ktrue = KTRUE_;
const TValue kfalse = KFALSE_;
const TValue kepinf = KEPINF_;
const TValue keminf = KEMINF_;
+const TValue kipinf = KIPINF_;
+const TValue kiminf = KIMINF_;
+const TValue krwnpv = KRWNPV_;
+const TValue kundef = KUNDEF_;
const TValue kspace = KSPACE_;
const TValue knewline = KNEWLINE_;
const TValue kfree = KFREE_;
@@ -36,7 +40,9 @@ char *ktv_names[] = {
[K_TDOUBLE] = "double",
[K_TBDOUBLE] = "bdouble",
[K_TIINF] = "iinf",
- [K_TRWNPN] = "rwnpn",
+
+ [K_TRWNPV] = "rwnpv",
+ [K_TUNDEFINED] = "undefined",
[K_TCOMPLEX] = "complex",
[K_TNIL] = "nil",
diff --git a/src/kobject.h b/src/kobject.h
@@ -31,6 +31,7 @@
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
+#include <math.h>
#include "klimits.h"
#include "klispconf.h"
@@ -130,12 +131,13 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TBIGINT 1
#define K_TFIXRAT 2
#define K_TBIGRAT 3
-#define K_TEINF 4
-#define K_TDOUBLE 5
-#define K_TBDOUBLE 6
+#define K_TDOUBLE 4
+#define K_TBDOUBLE 5
+#define K_TEINF 6
#define K_TIINF 7
-#define K_TRWNPN 8
+#define K_TRWNPV 8
#define K_TCOMPLEX 9
+#define K_TUNDEFINED 10
#define K_TNIL 20
#define K_TIGNORE 21
@@ -164,7 +166,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TDEADKEY 60
/* this is used to test for numbers, as returned by ttype */
-#define K_LAST_NUMBER_TYPE K_TCOMPLEX
+#define K_LAST_NUMBER_TYPE K_TUNDEFINED
/* this is used to if the object is collectable */
#define K_FIRST_GC_TYPE K_TPAIR
@@ -176,13 +178,15 @@ typedef struct __attribute__ ((__packed__)) GCheader {
**
** - decide if inexact infinities and reals with no
** primary values are included in K_TDOUBLE
-** - For now we will only use fixints, bigints, bigrats and exact infinities
+** - All types except complexs, bounded reals and fixrats
*/
#define K_TAG_FIXINT K_MAKE_VTAG(K_TFIXINT)
#define K_TAG_BIGINT K_MAKE_VTAG(K_TBIGINT)
#define K_TAG_BIGRAT K_MAKE_VTAG(K_TBIGRAT)
#define K_TAG_EINF K_MAKE_VTAG(K_TEINF)
#define K_TAG_IINF K_MAKE_VTAG(K_TIINF)
+#define K_TAG_RWNPV K_MAKE_VTAG(K_TRWNPV)
+#define K_TAG_UNDEFINED K_MAKE_VTAG(K_TUNDEFINED)
#define K_TAG_NIL K_MAKE_VTAG(K_TNIL)
#define K_TAG_IGNORE K_MAKE_VTAG(K_TIGNORE)
@@ -229,15 +233,38 @@ typedef struct __attribute__ ((__packed__)) GCheader {
/* Simple types (value in TValue struct) */
#define ttisfixint(o) (tbasetype_(o) == K_TAG_FIXINT)
#define ttisbigint(o) (tbasetype_(o) == K_TAG_BIGINT)
-#define ttisinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
+#define ttiseinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
t_ == K_TAG_FIXINT || t_ == K_TAG_BIGINT;})
+#define ttisinteger(o) ({ TValue o__ = (o); \
+ (ttiseinteger(o__) || \
+ (ttisdouble(o__) && (floor(dvalue(o__)) == dvalue(o__))));})
#define ttisbigrat(o) (tbasetype_(o) == K_TAG_BIGRAT)
-#define ttisrational(o_) ({ int32_t t_ = tbasetype_(o_); \
- t_ == K_TAG_BIGRAT || t_== K_TAG_BIGINT || \
- t_ == K_TAG_FIXINT;})
-#define ttisnumber(o) (ttype(o) <= K_LAST_NUMBER_TYPE); })
+#define ttisrational(o_) \
+ ({ TValue t_ = o_; \
+ (ttype(t_) <= K_TBIGRAT) || ttisdouble(t_); })
+#define ttisdouble(o) ((ttag(o) & K_TAG_BASE_MASK) != K_TAG_TAGGED)
+#define ttisreal(o) (ttype(o) < K_TCOMPLEX)
+#define ttisexact(o_) \
+ ({ TValue t_ = o_; \
+ (ttiseinf(t_) || ttype(t_) <= K_TBIGRAT); })
+/* MAYBE this is ugly..., maybe add exact/inexact flag, real, rational flag */
+#define ttisinexact(o_) \
+ ({ TValue t_ = o_; \
+ (ttisundef(t_) || ttisdouble(t_) || ttisrwnpv(t_) || ttisiinf(t_)); })
+/* For now, all inexact numbers are not robust and have -inf & +inf bounds */
+#define ttisrobust(o) (ttisexact(o))
+#define ttisnumber(o) (ttype(o) <= K_LAST_NUMBER_TYPE)
#define ttiseinf(o) (tbasetype_(o) == K_TAG_EINF)
#define ttisiinf(o) (tbasetype_(o) == K_TAG_IINF)
+#define ttisinf(o_) \
+ ({ TValue t_ = o_; \
+ (ttiseinf(t_) || ttisiinf(t_)); })
+#define ttisrwnpv(o) (tbasetype_(o) == K_TAG_RWNPV)
+#define ttisundef(o) (tbasetype_(o) == K_TAG_UNDEFINED)
+#define ttisnwnpv(o_) \
+ ({ TValue t_ = o_; \
+ (ttisundef(t_) || ttisrwnpv(t_)); })
+
#define ttisnil(o) (tbasetype_(o) == K_TAG_NIL)
#define ttisignore(o) (tbasetype_(o) == K_TAG_IGNORE)
#define ttisinert(o) (tbasetype_(o) == K_TAG_INERT)
@@ -245,7 +272,6 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisboolean(o) (tbasetype_(o) == K_TAG_BOOLEAN)
#define ttischar(o) (tbasetype_(o) == K_TAG_CHAR)
#define ttisfree(o) (tbasetype_(o) == K_TAG_FREE)
-#define ttisdouble(o) ((ttag(o) & K_TAG_BASE_MASK) != K_TAG_TAGGED)
/* Complex types (value in heap),
(bigints, rationals, etc could be collectable)
@@ -524,6 +550,10 @@ union GCObject {
#define KFALSE_ {.tv = {.t = K_TAG_BOOLEAN, .v = { .b = false }}}
#define KEPINF_ {.tv = {.t = K_TAG_EINF, .v = { .i = 1 }}}
#define KEMINF_ {.tv = {.t = K_TAG_EINF, .v = { .i = -1 }}}
+#define KIPINF_ {.tv = {.t = K_TAG_IINF, .v = { .i = 1 }}}
+#define KIMINF_ {.tv = {.t = K_TAG_IINF, .v = { .i = -1 }}}
+#define KRWNPV_ {.tv = {.t = K_TAG_RWNPV, .v = { .i = 0 }}}
+#define KUNDEF_ {.tv = {.t = K_TAG_UNDEFINED, .v = { .i = 0 }}}
#define KSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = ' ' }}}
#define KNEWLINE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\n' }}}
#define KFREE_ {.tv = {.t = K_TAG_FREE, .v = { .i = 0 }}}
@@ -538,6 +568,10 @@ union GCObject {
#define KFALSE ((TValue) KFALSE_)
#define KEPINF ((TValue) KEPINF_)
#define KEMINF ((TValue) KEMINF_)
+#define KIPINF ((TValue) KIPINF_)
+#define KIMINF ((TValue) KIMINF_)
+#define KRWNPV ((TValue) KRWNPV_)
+#define KUNDEF ((TValue) KUNDEF_)
#define KSPACE ((TValue) KSPACE_)
#define KNEWLINE ((TValue) KNEWLINE_)
#define KFREE ((TValue) KFREE_)
@@ -551,6 +585,10 @@ const TValue ktrue;
const TValue kfalse;
const TValue kepinf;
const TValue keminf;
+const TValue kipinf;
+const TValue kiminf;
+const TValue krwnpv;
+const TValue kundef;
const TValue kspace;
const TValue knewline;
const TValue kfree;
@@ -560,12 +598,24 @@ const TValue kfree;
#define i2tv_(i_) {.tv = {.t = K_TAG_FIXINT, .v = { .i = (i_) }}}
#define b2tv_(b_) {.tv = {.t = K_TAG_BOOLEAN, .v = { .b = (b_) }}}
#define p2tv_(p_) {.tv = {.t = K_TAG_USER, .v = { .p = (p_) }}}
+#define d2tv_(d_) {.d = d_}
+#define ktag_double(d_) \
+ ({ double d__ = d_; \
+ TValue res__; \
+ if (isnan(d__)) res__ = KRWNPV; \
+ else if (isinf(d__)) res__ = (d__ == INFINITY)? \
+ KIPINF : KIMINF; \
+ /* +0.0 == -0.0 too, but that doesn't hurt */ \
+ else if (d__ == -0.0) res__ = d2tv(+0.0); \
+ else res__ = d2tv(d__); \
+ res__;})
/* Macros to create TValues of non-heap allocated types */
#define ch2tv(ch_) ((TValue) ch2tv_(ch_))
#define i2tv(i_) ((TValue) i2tv_(i_))
#define b2tv(b_) ((TValue) b2tv_(b_))
#define p2tv(p_) ((TValue) p2tv_(p_))
+#define d2tv(d_) ((TValue) d2tv_(d_))
/* Macros to convert a GCObject * into a tagged value */
/* TODO: add assertions */
@@ -620,6 +670,7 @@ const TValue kfree;
#define chvalue(o_) ((o_).tv.v.ch)
#define gcvalue(o_) ((o_).tv.v.gc)
#define pvalue(o_) ((o_).tv.v.p)
+#define dvalue(o_) ((o_).d)
/* Macro to obtain a string describing the type of a TValue */#
#define ttname(tv_) (ktv_names[ttype(tv_)])
diff --git a/src/kreal.c b/src/kreal.c
@@ -0,0 +1,743 @@
+/*
+** kreal.c
+** Kernel Reals (doubles)
+** See Copyright Notice in klisp.h
+*/
+
+#include <stdbool.h>
+#include <stdint.h>
+#include <string.h>
+#include <inttypes.h>
+#include <ctype.h>
+#include <math.h>
+#include <fenv.h> /* for setting round direction */
+
+#include "kreal.h"
+#include "krational.h"
+#include "kinteger.h"
+#include "kobject.h"
+#include "kstate.h"
+#include "kmem.h"
+#include "kgc.h"
+#include "kpair.h" /* for list in throw error */
+#include "kerror.h"
+
+double kbigint_to_double(Bigint *bigint)
+{
+ double radix = (double) UINT32_MAX + 1.0;
+ uint32_t ndigits = bigint->used;
+ double accum = 0.0;
+
+ /* bigint is in little endian format, but we traverse in
+ big endian */
+ do {
+ --ndigits;
+ accum = accum * radix + (double) bigint->digits[ndigits];
+ } while (ndigits > 0); /* have to compare like this, it's unsigned */
+ return mp_int_compare_zero(bigint) < 0? -accum : accum;
+}
+
+/* bigrat is rooted */
+double kbigrat_to_double(klisp_State *K, Bigrat *bigrat)
+{
+ /* TODO: check rounding in extreme cases */
+ TValue tv_rem = kbigrat_copy(K, gc2bigrat(bigrat));
+ krooted_tvs_push(K, tv_rem);
+ Bigrat *rem = tv2bigrat(tv_rem);
+ UNUSED(mp_rat_abs(K, rem, rem));
+
+ TValue int_radix = kbigint_make_simple(K);
+ krooted_tvs_push(K, int_radix);
+ /* cant do UINT32_MAX and then +1 because _value functions take
+ int32_t arguments */
+ UNUSED(mp_int_set_value(K, tv2bigint(int_radix), INT32_MAX));
+ UNUSED(mp_int_add_value(K, tv2bigint(int_radix), 1,
+ tv2bigint(int_radix)));
+ UNUSED(mp_int_add(K, tv2bigint(int_radix), tv2bigint(int_radix),
+ tv2bigint(int_radix)));
+
+ TValue int_part = kbigint_make_simple(K);
+ krooted_tvs_push(K, int_part);
+
+ double accum = 0.0;
+ double radix = (double) UINT32_MAX + 1.0;
+ uint32_t digit = 0;
+ /* inside there is a check to avoid problem with continuing fractions */
+ while(mp_rat_compare_zero(rem) > 0) {
+ UNUSED(mp_int_div(K, MP_NUMER_P(rem), MP_DENOM_P(rem),
+ tv2bigint(int_part), NULL));
+
+ double di = kbigint_to_double(tv2bigint(int_part));
+ bool was_zero = di == 0.0;
+ for (uint32_t i = 0; i < digit; i++) {
+ di /= radix;
+ }
+ /* if last di became 0.0 we will exit next loop,
+ this is to avoid problem with continuing fractions */
+ if (!was_zero && di == 0.0)
+ break;
+
+ ++digit;
+ accum += di;
+
+ UNUSED(mp_rat_sub_int(K, rem, tv2bigint(int_part), rem));
+ UNUSED(mp_rat_mul_int(K, rem, tv2bigint(int_radix), rem));
+ }
+ krooted_tvs_pop(K); /* int_part */
+ krooted_tvs_pop(K); /* int_radix */
+ krooted_tvs_pop(K); /* rem */
+
+ return mp_rat_compare_zero(bigrat) < 0? -accum : accum;
+}
+
+/* TODO test strict arithmetic and throw errors on overflow and underflow?
+ if set */
+TValue kexact_to_inexact(klisp_State *K, TValue n)
+{
+ bool strictp = kcurr_strict_arithp(K);
+
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ /* NOTE: can't over or underflow, and can't give NaN */
+ return d2tv((double) ivalue(n));
+ case K_TBIGINT: {
+ Bigint *bigint = tv2bigint(n);
+ double d = kbigint_to_double(bigint);
+ if (strictp && (d == 0.0 || isinf(d) || isnan(d))) {
+ /* NOTE: bigints can't be zero */
+ char *msg;
+ if (isnan(d))
+ msg = "unexpected error";
+ else if (isinf(d))
+ msg = "overflow";
+ else
+ msg = "undeflow";
+ klispE_throw_simple_with_irritants(K, msg, 1, n);
+ return KUNDEF;
+ } else {
+ /* d may be inf, ktag_double will handle it */
+ return ktag_double(d);
+ }
+ }
+ case K_TBIGRAT: {
+ Bigrat *bigrat = tv2bigrat(n);
+ double d = kbigrat_to_double(K, bigrat);
+ /* REFACTOR: this code is the same for bigints... */
+ if (strictp && (d == 0.0 || isinf(d) || isnan(d))) {
+ /* NOTE: bigrats can't be zero */
+ char *msg;
+ if (isnan(d))
+ msg = "unexpected error";
+ else if (isinf(d))
+ msg = "overflow";
+ else
+ msg = "undeflow";
+ klispE_throw_simple_with_irritants(K, msg, 1, n);
+ return KUNDEF;
+ } else {
+ /* d may be inf, ktag_double will handle it */
+ return ktag_double(d);
+ }
+ }
+ case K_TEINF:
+ return tv_equal(n, KEPINF)? KIPINF : KIMINF;
+ /* all of these are already inexact */
+ case K_TDOUBLE:
+ case K_TIINF:
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ return n;
+ default:
+ klisp_assert(0);
+ return KUNDEF;
+ }
+}
+
+/* assume d is integer and doesn't fit in a fixint */
+TValue kdouble_to_bigint(klisp_State *K, double d)
+{
+ bool neg = d < 0;
+ if (neg)
+ d = -d;
+
+ TValue tv_res = kbigint_make_simple(K);
+ krooted_tvs_push(K, tv_res);
+ Bigint *res = tv2bigint(tv_res);
+ mp_int_set_value(K, res, 0);
+
+ TValue tv_digit = kbigint_make_simple(K);
+ krooted_tvs_push(K, tv_digit);
+ Bigint *digit = tv2bigint(tv_digit);
+
+ /* do it 32 bits at a time */
+ double radix = ((double) UINT32_MAX) + 1.0;
+ int power = 0;
+ while(d > 0) {
+ double dd = fmod(d, radix);
+ d = floor(d / radix);
+ /* load in two moves because set_value takes signed ints */
+ uint32_t id = (uint32_t) dd;
+ int32_t id1 = (int32_t) (id >> 1);
+ int32_t id2 = (int32_t) (id - id1);
+
+ mp_int_set_value(K, digit, id1);
+ mp_int_add_value(K, digit, id2, digit);
+
+ mp_int_mul_pow2(K, digit, power, digit);
+ mp_int_add(K, res, digit, res);
+
+ power += 32;
+ }
+
+ if (neg)
+ mp_int_neg(K, res, res);
+
+ krooted_tvs_pop(K); /* digit */
+ krooted_tvs_pop(K); /* res */
+
+ return tv_res; /* can't be fixint except when coming from
+ kdouble_to_bigrat, so don't convert */
+}
+
+/* TODO: should do something like rationalize with range +/- 1/2ulp) */
+TValue kdouble_to_bigrat(klisp_State *K, double d)
+{
+ bool neg = d < 0;
+ if (neg)
+ d = -d;
+
+ /* find an integer, convert it and divide by
+ an adequate power of 2 */
+ TValue tv_res = kbigrat_make_simple(K);
+ krooted_tvs_push(K, tv_res);
+ Bigrat *res = tv2bigrat(tv_res);
+ UNUSED(mp_rat_set_value(K, res, 0, 1));
+
+ TValue tv_den = kbigint_make_simple(K);
+ krooted_tvs_push(K, tv_den);
+ Bigint *den = tv2bigint(tv_den);
+ UNUSED(mp_int_set_value(K, den, 1));
+
+ /* XXX could be made a lot more efficiently reading ieee
+ fields directly */
+ int ie;
+ d = frexp(d, &ie);
+
+ while(d != floor(d)) {
+ d *= 2.0;
+ --ie;
+ }
+ UNUSED(mp_int_mul_pow2(K, den, -ie, den));
+
+ TValue tv_num = kdouble_to_bigint(K, d);
+ krooted_tvs_push(K, tv_num);
+ Bigint *num = tv2bigint(tv_num);
+
+ TValue tv_den2 = kbigrat_make_simple(K);
+ krooted_tvs_push(K, tv_den2);
+ Bigrat *den2 = tv2bigrat(tv_den2);
+
+ UNUSED(mp_rat_set_value(K, den2, 0, 1));
+ UNUSED(mp_rat_add_int(K, den2, den, den2));
+ UNUSED(mp_rat_set_value(K, res, 0, 1));
+ UNUSED(mp_rat_add_int(K, res, num, res));
+ UNUSED(mp_rat_div(K, res, den2, res));
+
+ if (neg)
+ UNUSED(mp_rat_neg(K, res, res));
+
+ /* now create a value corresponding to 1/2 ulp
+ for rationalize */
+ UNUSED(mp_int_mul_pow2(K, den, 1, den));
+ UNUSED(mp_rat_set_value(K, den2, 0, 1));
+ UNUSED(mp_rat_add_int(K, den2, den, den2));
+ UNUSED(mp_rat_recip(K, den2, den2));
+ /* den2 now has 1/2 ulp */
+
+ TValue rationalized = kbigrat_rationalize(K, tv_res, tv_den2);
+
+ krooted_tvs_pop(K); /* den2 */
+ krooted_tvs_pop(K); /* num */
+ krooted_tvs_pop(K); /* den */
+ krooted_tvs_pop(K); /* res */
+
+ return rationalized;
+}
+
+TValue kinexact_to_exact(klisp_State *K, TValue n)
+{
+ switch(ttype(n)) {
+ case K_TFIXINT:
+ case K_TBIGINT:
+ case K_TBIGRAT:
+ case K_TEINF:
+ /* all of these are already exact */
+ return n;
+ case K_TDOUBLE: {
+ double d = dvalue(n);
+ klisp_assert(!isnan(d) && !isinf(d));
+ if (d == floor(d)) { /* integer */
+ if (d <= (double) INT32_MAX &&
+ d >= (double) INT32_MIN) {
+ return i2tv((int32_t) d); /* fixint */
+ } else {
+ return kdouble_to_bigint(K, d);
+ }
+ } else { /* non integer rational */
+ return kdouble_to_bigrat(K, d);
+ }
+ }
+ case K_TIINF:
+ return tv_equal(n, KIPINF)? KEPINF : KEMINF;
+ case K_TRWNPV:
+ case K_TUNDEFINED:
+ klispE_throw_simple_with_irritants(K, "no primary value", 1, n);
+ return KUNDEF;
+ default:
+ klisp_assert(0);
+ return KUNDEF;
+ }
+}
+
+/*
+** read/write interface
+*/
+
+/*
+** SOURCE NOTE: This is a more or less vanilla implementation of the algorithm
+** described in "How to Print Floating-Point Numbers Accurately" by
+** Guy L. Steele Jr. & John L. White.
+*/
+
+/*
+** TODO add awareness of read rounding (e.g. problem with 1.0e23)
+** TODO add exponent if too small or too big
+*/
+
+mp_result shift_2(klisp_State *K, Bigint *x, Bigint *n, Bigint *r)
+{
+ mp_small nv;
+ mp_result res = mp_int_to_int(n, &nv);
+ klisp_assert(res == MP_OK);
+
+ if (nv >= 0)
+ return mp_int_mul_pow2(K, x, nv, r);
+ else
+ return mp_int_div_pow2(K, x, -nv, r, NULL);
+}
+
+/* returns k, modifies all parameters (except f & p) */
+int32_t simple_fixup(klisp_State *K, Bigint *f, Bigint *p, Bigint *r,
+ Bigint *s, Bigint *mm, Bigint *mp)
+{
+ mp_result res;
+ Bigint tmpz, tmpz2;
+ Bigint *tmp = &tmpz;
+ Bigint *tmp2 = &tmpz2;
+ Bigint onez;
+ Bigint *one = &onez;
+ res = mp_int_init(tmp);
+ res = mp_int_init(tmp2);
+ res = mp_int_init_value(K, one, 1);
+ res = mp_int_sub(K, p, one, tmp);
+ res = shift_2(K, one, tmp, tmp);
+
+ if (mp_int_compare(f, tmp) == 0) {
+ res = shift_2(K, mp, one, mp);
+ res = shift_2(K, r, one, r);
+ res = shift_2(K, s, one, s);
+ }
+
+ int k = 0;
+
+ /* tmp = ceiling (s/10), for while guard */
+ res = mp_int_add_value(K, s, 9, tmp);
+ res = mp_int_div_value(K, tmp, 10, tmp, NULL);
+
+ while(mp_int_compare(r, tmp) < 0) {
+ --k;
+ res = mp_int_mul_value(K, r, 10, r);
+ res = mp_int_mul_value(K, mm, 10, mm);
+ res = mp_int_mul_value(K, mp, 10, mp);
+ /* tmp = ceiling (s/10), for while guard */
+ res = mp_int_add_value(K, s, 9, tmp);
+ res = mp_int_div_value(K, tmp, 10, tmp, NULL);
+ }
+
+ /* tmp = 2r + mp; tmp2 = 2s */
+ res = mp_int_mul_value(K, r, 2, tmp);
+ res = mp_int_add(K, tmp, mp, tmp);
+ res = mp_int_mul_value(K, s, 2, tmp2);
+ while(mp_int_compare(tmp, tmp2) >= 0) {
+
+ res = mp_int_mul_value(K, s, 10, s);
+ ++k;
+
+ /* tmp = 2r + mp; tmp2 = 2s */
+ res = mp_int_mul_value(K, r, 2, tmp);
+ res = mp_int_add(K, tmp, mp, tmp);
+ res = mp_int_mul_value(K, s, 2, tmp2);
+ }
+
+ mp_int_clear(K, tmp);
+ mp_int_clear(K, tmp2);
+ mp_int_clear(K, one);
+ return k;
+}
+
+/* TEMP: for now upoint is passed indicating where the least significant
+ integer digit should be (10^0 position) */
+#define digit_pos(k_, upoint_) ((k_) + (upoint_))
+
+bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
+ int32_t *out_k)
+{
+ assert(sizeof(mp_small) == 4);
+ mp_result res;
+ Bigint e, p, f;
+
+ assert(d > 0.0);
+
+ /* convert d to three bigints m: significand, e: exponent & p: precision */
+ /* d = m^(e-p) & m < 2^p */
+ int ie, ip;
+ double mantissa = frexp(d, &ie);
+ ip = 0;
+
+ klisp_assert(mantissa * pow(2.0, ie) == d);
+ /* now 0.5 <= mantissa < 1 & mantissa * 2^expt = d */
+/* this could be a binary search, it could also be done reading the exponent
+ field of ieee754 directly... */
+ while(mantissa != floor(mantissa)) {
+ mantissa *= 2.0;
+ ++ip;
+ }
+
+ /* mantissa is int & < 2^ip (was < 1=2^0 and by induction...) */
+ klisp_assert(mantissa * pow(2.0, ie - ip) == d);
+ /* mantissa is at most 53 bits long as an int, load it in two parts
+ to f */
+ int64_t im = (int64_t) mantissa;
+ /* f */
+ /* cant load 32 bits at a time, second param is signed!,
+ but we know it's positive so load 32 then 31 */
+ res = mp_int_init_value(K, &f, (mp_small) (im >> 31));
+ res = mp_int_mul_pow2(K, &f, 31, &f);
+ res = mp_int_add_value(K, &f, (mp_small) im & 0x7fffffff, &f);
+
+ /* adjust f & p so that p is 53 TODO do in one step */
+ /* XXX: is this is ok for denorms?? */
+ while(ip < 53) {
+ ++ip;
+ res = mp_int_mul_value(K, &f, 2, &f);
+ }
+
+ /* e */
+ res = mp_int_init_value(K, &e, (mp_small) ie);
+
+ /* p */
+ res = mp_int_init_value(K, &p, (mp_small) ip);
+
+ /* start of FPP^2 algorithm */
+ Bigint r, s;
+ Bigint mp, mm;
+ Bigint e_p;
+ Bigint zero, one;
+
+ res = mp_int_init_value(K, &zero, 0);
+ res = mp_int_init_value(K, &one, 1);
+
+ res = mp_int_init(&r);
+ res = mp_int_init(&s);
+ res = mp_int_init(&mm);
+ res = mp_int_init(&mp);
+ res = mp_int_init(&e_p);
+
+ res = mp_int_sub(K, &e, &p, &e_p);
+
+// shift_2(f, max(e-p, 0), r);
+// shift_2(1, max(-(e-p), 0), r);
+ if (mp_int_compare_zero(&e_p) >= 0) {
+ res = shift_2(K, &f, &e_p, &r);
+ res = shift_2(K, &one, &zero, &s); /* nop */
+ res = shift_2(K, &one, &e_p, &mm);
+ } else {
+ res = shift_2(K, &f, &zero, &r); /* nop */
+ res = mp_int_neg(K, &e_p, &e_p);
+ res = shift_2(K, &one, &e_p, &s);
+ res = shift_2(K, &one, &zero, &mm);
+ }
+ mp_int_copy(K, &mm, &mp);
+
+ int32_t k = simple_fixup(K, &f, &p, &r, &s, &mm, &mp);
+ int32_t h = k-1;
+
+ Bigint u, tmp, tmp2;
+ res = mp_int_init(&u);
+ res = mp_int_init(&tmp);
+ res = mp_int_init(&tmp2);
+ bool low, high;
+
+ do {
+ --k;
+ res = mp_int_mul_value(K, &r, 10, &tmp);
+ res = mp_int_div(K, &tmp, &s, &u, &r);
+ res = mp_int_mul_value(K, &mm, 10, &mm);
+ res = mp_int_mul_value(K, &mp, 10, &mp);
+
+ /* low/high flags */
+ /* XXX try to make 1e23 round correctly,
+ it causes tmp == tmp2 but should probably
+ check oddness of digit and (may result in a digit
+ with value 10?, needing to backtrack)
+ In general make it so that if rounding done at reading
+ (should be round to even) is accounted for and the minimal
+ length number is generated */
+
+ res = mp_int_mul_value(K, &r, 2, &tmp);
+
+ low = mp_int_compare(&tmp, &mm) < 0;
+
+ res = mp_int_mul_value(K, &s, 2, &tmp2);
+ res = mp_int_sub(K, &tmp2, &mp, &tmp2);
+
+ high = mp_int_compare(&tmp, &tmp2) > 0;
+
+ if (!low && !high) {
+ mp_small digit;
+ res = mp_int_to_int(&u, &digit);
+ klisp_assert(res == MP_OK);
+ klisp_assert(digit >= 0 && digit <= 9);
+ buf[digit_pos(k, upoint)] = '0' + digit;
+ }
+ } while(!low && !high);
+
+ mp_small digit;
+ res = mp_int_to_int(&u, &digit);
+ klisp_assert(res == MP_OK);
+ klisp_assert(digit >= 0 && digit <= 9);
+
+ if (low && high) {
+ res = mp_int_mul_value(K, &r, 2, &tmp);
+ int cmp = mp_int_compare(&tmp, &s);
+ if ((cmp == 0 && (digit & 1) != 0) || cmp > 0)
+ ++digit;
+ } else if (low) {
+ /* nothing */
+ } else if (high) {
+ ++digit;
+ } else {
+ assert(0);
+ }
+ /* double check in case there was an increment */
+ klisp_assert(digit >= 0 && digit <= 9);
+ buf[digit_pos(k, upoint)] = '0' + digit;
+
+ *out_h = h;
+ *out_k = k;
+ /* add '\0' to both sides */
+ buf[digit_pos(k-1, upoint)] = '\0';
+ buf[digit_pos(h+1, upoint)] = '\0';
+
+ mp_int_clear(K, &f);
+ mp_int_clear(K, &e);
+ mp_int_clear(K, &p);
+ mp_int_clear(K, &r);
+ mp_int_clear(K, &s);
+ mp_int_clear(K, &mp);
+ mp_int_clear(K, &mm);
+ mp_int_clear(K, &e_p);
+ mp_int_clear(K, &zero);
+ mp_int_clear(K, &one);
+ mp_int_clear(K, &u);
+ mp_int_clear(K, &tmp);
+ mp_int_clear(K, &tmp2);
+
+ /* NOTE: digits are reversed! */
+ return true;
+}
+
+
+/* TEMP: this is a stub for now, always return sufficiently large
+ number */
+int32_t kdouble_print_size(TValue tv_double)
+{
+ UNUSED(tv_double);
+ return 1024;
+}
+
+void kdouble_print_string(klisp_State *K, TValue tv_double,
+ char *buf, int32_t limit)
+{
+ /* TODO: add exponent to values too large or too small */
+ /* TEMP */
+ int32_t h = 0;
+ int32_t k = 0;
+ int32_t upoint = limit/2;
+ double od = dvalue(tv_double);
+ klisp_assert(!isnan(od) && !isinf(od));
+ klisp_assert(limit > 10);
+
+ /* dtoa only works for d > 0 */
+ if (od == 0.0) {
+ buf[0] = '0';
+ buf[1] = '.';
+ buf[2] = '0';
+ buf[3] = '\0';
+ return;
+ }
+
+ double d;
+ if (od < 0.0)
+ d = -od;
+ else d = od;
+
+ /* XXX this doesn't check limit, it should be large enough */
+ UNUSED(dtoa(K, d, buf, upoint, &h, &k));
+
+ klisp_assert(upoint + k >= 0 && upoint + h + 1 < limit);
+
+ /* rearrange the digits */
+ /* TODO do this more efficiently */
+
+
+ int32_t size = h - k + 1;
+ int32_t start = upoint+k;
+ /* first reverse the digits */
+ for (int32_t i = upoint+k, j = upoint+h; i < j; i++, j--) {
+ char ch = buf[i];
+ buf[i] = buf[j];
+ buf[j] = ch;
+ }
+
+ /* TODO use exponents */
+
+ /* if necessary make room for leading zeros and sign,
+ move all to the left */
+
+ int extra_size = (od < 0? 1 : 0) + (h < 0? 2 + (-h-1) : 0);
+
+ klisp_assert(extra_size + size + 2 < limit);
+ memmove(buf+extra_size, buf+start, size);
+
+ int32_t i = 0;
+ if (od < 0)
+ buf[i++] = '-';
+
+ if (h < 0) {
+ /* fraction with leading 0. and with possibly more leading zeros */
+ buf[i++] = '0';
+ buf[i++] = '.';
+ for (int32_t j = -1; j > h; j--) {
+ buf[i++] = '0';
+ }
+ int frac_size = size;
+ i += frac_size;
+ buf[i++] = '\0';
+ } else if (k >= 0) {
+ /* integer with possibly trailing zeros */
+ klisp_assert(size+extra_size+k+4 < limit);
+ int int_size = size;
+ i += int_size;
+ for (int32_t j = 0; j < k; j++) {
+ buf[i++] = '0';
+ }
+ buf[i++] = '.';
+ buf[i++] = '0';
+ buf[i++] = '\0';
+ } else { /* both integer and fractional part, make room for the point */
+ /* k < 0, h >= 0 */
+ int32_t int_size = h+1;
+ int32_t frac_size = -k;
+ memmove(buf+i+int_size+1, buf+i+int_size, frac_size);
+ i += int_size;
+ buf[i++] = '.';
+ i += frac_size;
+ buf[i++] = '\0';
+ }
+ return;
+}
+
+double kdouble_div_mod(double n, double d, double *res_mod)
+{
+ double div = floor(n / d);
+ double mod = fmod(n, d);
+
+ /* div, mod or div-and-mod */
+ /* 0 <= mod0 < |d| */
+ if (mod < 0.0) {
+ if (d < 0.0) {
+ mod -= d;
+ div += 1.0;
+ } else {
+ mod += d;
+ div -= 1.0;
+ }
+ }
+ *res_mod = mod;
+ return div;
+}
+
+double kdouble_div0_mod0(double n, double d, double *res_mod)
+{
+ double div = floor(n / d);
+ double mod = fmod(n, d);
+
+ /* div0, mod0 or div-and-mod0 */
+ /*
+ ** Adjust q and r so that:
+ ** -|d/2| <= mod0 < |d/2| which is the same as
+ ** dmin <= mod0 < dmax, where
+ ** dmin = -|d/2| and dmax = |d/2|
+ */
+ double dmin = -((d<0.0? -d : d) / 2.0);
+ double dmax = (d<0.0? -d : d) / 2.0;
+
+ if (mod < dmin) {
+ if (d < 0) {
+ mod -= d;
+ div += 1.0;
+ } else {
+ mod += d;
+ div -= 1.0;
+ }
+ } else if (mod >= dmax) {
+ if (d < 0) {
+ mod += d;
+ div += 1.0;
+ } else {
+ mod -= d;
+ div -= 1.0;
+ }
+ }
+ *res_mod = mod;
+ return div;
+}
+
+TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode)
+{
+ double d = dvalue(tv_double);
+ switch(mode) {
+ case K_TRUNCATE:
+ d = trunc(d);
+ break;
+ case K_CEILING:
+ d = ceil(d);
+ break;
+ case K_FLOOR:
+ d = floor(d);
+ break;
+ case K_ROUND_EVEN: {
+ int res = fesetround(FE_TONEAREST); /* REFACTOR: should be done once only... */
+ klisp_assert(res == 0);
+ d = nearbyint(d);
+ }
+ }
+ /* ASK John: we currently return inexact if given inexact is this ok?
+ or should it return an exact integer? */
+ return ktag_double(d);
+#if 0
+ tv_double = ktag_double(d); /* won't alloc mem so no need to root */
+ return kinexact_to_exact(K, tv_double);
+#endif
+}
diff --git a/src/kreal.h b/src/kreal.h
@@ -0,0 +1,38 @@
+/*
+** kreal.c
+** Kernel Reals (doubles)
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kreal_h
+#define kreal_h
+
+#include <stdbool.h>
+#include <stdint.h>
+#include <inttypes.h>
+
+#include "kobject.h"
+#include "kstate.h"
+#include "kinteger.h"
+#include "krational.h"
+#include "imrat.h"
+
+/* REFACTOR rename. These can take any real, but
+ kreal_to_... is taken by kgnumbers... */
+TValue kexact_to_inexact(klisp_State *K, TValue n);
+TValue kinexact_to_exact(klisp_State *K, TValue n);
+
+
+double kdouble_div_mod(double n, double d, double *res_mod);
+double kdouble_div0_mod0(double n, double d, double *res_mod);
+
+TValue kdouble_to_integer(klisp_State *K, TValue tv_double, kround_mode mode);
+
+/*
+** read/write interface
+*/
+int32_t kdouble_print_size(TValue tv_double);
+void kdouble_print_string(klisp_State *K, TValue tv_double,
+ char *buf, int32_t limit);
+
+#endif
diff --git a/src/kstate.c b/src/kstate.c
@@ -91,6 +91,10 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->kd_in_port_key = KINERT;
K->kd_out_port_key = KINERT;
+ /* strict arithmetic dynamic key */
+ /* this is init later */
+ K->kd_strict_arith_key = KINERT;
+
/* GC */
K->currentwhite = bit2mask(WHITE0BIT, FIXEDBIT);
K->gcstate = GCSpause;
@@ -188,6 +192,9 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->kd_in_port_key = kcons(K, KTRUE, in_port);
K->kd_out_port_key = kcons(K, KTRUE, out_port);
+ /* strict arithmetic key, (starts as false) */
+ K->kd_strict_arith_key = kcons(K, KTRUE, KFALSE);
+
/* create the ground environment and the eval operative */
int32_t line_number;
TValue si;
diff --git a/src/kstate.h b/src/kstate.h
@@ -107,6 +107,9 @@ struct klisp_State {
TValue kd_in_port_key;
TValue kd_out_port_key;
+ /* for strict-arithmetic */
+ TValue kd_strict_arith_key;
+
/* Strings */
TValue empty_string;
@@ -485,5 +488,14 @@ void klisp_close (klisp_State *K);
void do_interception(klisp_State *K, TValue *xparams, TValue obj);
+/* simple accessors for dynamic keys */
+
+/* XXX: this is ugly but we can't include kpair.h here so... */
+/* MAYBE: move car & cdr to kobject.h */
+/* TODO: use these where appropriate */
+#define kcurr_input_port(K) (tv2pair((K)->kd_in_port_key)->cdr)
+#define kcurr_output_port(K) (tv2pair((K)->kd_out_port_key)->cdr)
+#define kcurr_strict_arithp(K) bvalue(tv2pair((K)->kd_strict_arith_key)->cdr)
+
#endif
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -10,7 +10,6 @@
#include "kobject.h"
/* for identifier checking */
#include "ktoken.h"
-#include "kpair.h"
#include "kstate.h"
#include "kmem.h"
#include "kgc.h"
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -38,6 +38,7 @@
#include "kstate.h"
#include "kinteger.h"
#include "krational.h"
+#include "kreal.h"
#include "kpair.h"
#include "kstring.h"
#include "ksymbol.h"
@@ -399,14 +400,19 @@ TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
{
UNUSED(len); /* not needed really, buf ends with '\0' */
TValue n;
- if (has_exactp && radix == 10) {
- /* TEMP: while there are no inexacts */
- /* allow decimals if has #e prefix */
- if (!krational_read_decimal(K, buf, radix, &n, NULL, NULL)) {
+ if (radix == 10) {
+ /* only allow decimals with radix 10 */
+ bool decimalp = false;
+ if (!krational_read_decimal(K, buf, radix, &n, NULL, &decimalp)) {
/* TODO throw meaningful error msgs, use last param */
ktok_error(K, "Bad format in number");
return KINERT;
}
+ if (decimalp && !has_exactp) {
+ /* handle decimal format as an explicit #i */
+ has_exactp = true;
+ exactp = false;
+ }
} else {
if (!krational_read(K, buf, radix, &n, NULL)) {
/* TODO throw meaningful error msgs, use last param */
@@ -415,6 +421,12 @@ TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
}
}
ks_tbclear(K);
+
+ if (has_exactp && !exactp) {
+ krooted_tvs_push(K, n);
+ n = kexact_to_inexact(K, n);
+ krooted_tvs_pop(K);
+ }
return n;
}
@@ -518,8 +530,10 @@ struct kspecial_token {
{ "#inert", KINERT_ },
{ "#e+infinity", KEPINF_ },
{ "#e-infinity", KEMINF_ },
- /* TODO add undefined, real with on primary value,
- and inexact infinities */
+ { "#i+infinity", KIPINF_ },
+ { "#i-infinity", KIMINF_ },
+ { "#real", KRWNPV_ },
+ { "#undefined", KUNDEF_ },
{ "#\\space", KSPACE_ },
{ "#\\newline", KNEWLINE_ }
};
@@ -691,10 +705,7 @@ TValue ktok_read_special(klisp_State *K)
case '5': case '6': case '7': case '8': case '9':
case 'a': case 'b': case 'c': case 'd': case 'e':
case 'f': case '+': case '-': { /* read the number */
- if (has_exactp && !exactp) {
- ktok_error(K, "inexact numbers not supported");
- return KINERT;
- } else if (idx == buf_len) {
+ if (idx == buf_len) {
ktok_error(K, "no digits found in number");
} else {
return ktok_read_number(K, buf+idx, buf_len - idx,
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -8,11 +8,13 @@
#include <stdlib.h>
#include <assert.h>
#include <inttypes.h>
+#include <string.h>
#include "kwrite.h"
#include "kobject.h"
#include "kinteger.h"
#include "krational.h"
+#include "kreal.h"
#include "kpair.h"
#include "kstring.h"
#include "ksymbol.h"
@@ -90,6 +92,23 @@ void kw_print_bigrat(klisp_State *K, TValue bigrat)
krooted_tvs_pop(K);
}
+void kw_print_double(klisp_State *K, TValue tv_double)
+{
+ int32_t size = kdouble_print_size(tv_double);
+ krooted_tvs_push(K, tv_double);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ TValue buf_str = kstring_new_s(K, size);
+ krooted_tvs_push(K, buf_str);
+
+ char *buf = kstring_buf(buf_str);
+ kdouble_print_string(K, tv_double, buf, size);
+ kw_printf(K, "%s", buf);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+}
+
/*
** Helper for printing strings (correcly escapes backslashes and
** double quotes & prints embedded '\0's). It includes the surrounding
@@ -271,9 +290,6 @@ void kwrite_simple(klisp_State *K, TValue obj)
kwrite_error(K, "string type found in kwrite-simple");
/* avoid warning */
return;
- case K_TEINF:
- kw_printf(K, "#e%cinfinity", tv_equal(obj, KEPINF)? '+' : '-');
- break;
case K_TFIXINT:
kw_printf(K, "%" PRId32, ivalue(obj));
break;
@@ -283,6 +299,23 @@ void kwrite_simple(klisp_State *K, TValue obj)
case K_TBIGRAT:
kw_print_bigrat(K, obj);
break;
+ case K_TEINF:
+ kw_printf(K, "#e%cinfinity", tv_equal(obj, KEPINF)? '+' : '-');
+ break;
+ case K_TIINF:
+ kw_printf(K, "#i%cinfinity", tv_equal(obj, KIPINF)? '+' : '-');
+ break;
+ case K_TDOUBLE: {
+ kw_print_double(K, obj);
+ break;
+ }
+ case K_TRWNPV:
+ /* ASK John/TEMP: until John tells me what should this be... */
+ kw_printf(K, "#real");
+ break;
+ case K_TUNDEFINED:
+ kw_printf(K, "#undefined");
+ break;
case K_TNIL:
kw_printf(K, "()");
break;
