klisp

commit 269d72ce9a458fea31c7b1cdeb7c7d7374b84ba7
parent c60cfaed91573fae3b05857af07b8312f842d311
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 20 May 2011 00:29:22 -0300

Added expt to the ground environment. Module real is complete.

Diffstat:
M
src/kgnumbers.c
 | 
70
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
M
src/kground.c
 | 
5
+----

2 files changed, 71 insertions(+), 4 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -2143,3 +2143,73 @@ void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     }
     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/kground.c b/src/kground.c
@@ -895,10 +895,7 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "sqrt", ksqrt, 0);
 
     /* 12.9.6 expt */
-    /* TODO */
-
-
-    /* TODO complete all other bindings of module real */
+    add_applicative(K, ground_env, "expt", kexpt, 0);
 
     /*
     **