klisp

commit dc64313aac502c189571fe24cc5dd2f0605efb57
parent 9059985f07cb71c058ce8ae85de8540b3f25c129
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 19 May 2011 04:19:43 -0300

Added exp & log to the ground environment.

Diffstat:
M
src/kgnumbers.c
 | 
87
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
4
+++-
M
src/kground.c
 | 
4
++++

3 files changed, 94 insertions(+), 1 deletion(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -752,6 +752,8 @@ TValue knum_real_to_integer(klisp_State *K, TValue n, kround_mode mode)
     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:
@@ -833,6 +835,9 @@ 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, "unsupported type");
 	return KINERT;
@@ -1841,3 +1846,85 @@ 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, "real", krealp, 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:
+	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, "real", krealp, 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:
+	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);
+}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -174,7 +174,9 @@ void ksimplest_rational(klisp_State *K, TValue *xparams, TValue ptree,
 /* 12.9.1 real? */
 /* uses ftypep */
 
-/* TODO remaining of module real */
+/* 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);
 
 /* REFACTOR: These should be in a knumber.h header */
 
diff --git a/src/kground.c b/src/kground.c
@@ -875,6 +875,10 @@ void kinit_ground_env(klisp_State *K)
     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);
+
     /* TODO complete all other bindings of module real */
 
     /*