klisp

commit c60cfaed91573fae3b05857af07b8312f842d311
parent 88f0f86ade61079433cf73bba23f51dd2c50b99a
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 19 May 2011 23:42:35 -0300

Added sqrt to the ground environment.

Diffstat:
M
src/kgnumbers.c
 | 
41
+++++++++++++++++++++++++++++++++++++++++
M
src/kgnumbers.h
 | 
7
+++++++
M
src/kground.c
 | 
8
++++----

3 files changed, 52 insertions(+), 4 deletions(-)
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -2102,3 +2102,44 @@ void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
     }
     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);
+}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -185,6 +185,13 @@ void ktrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 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 */
diff --git a/src/kground.c b/src/kground.c
@@ -889,12 +889,12 @@ void kinit_ground_env(klisp_State *K)
     /* 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, 2, atan, atan2);
+    add_applicative(K, ground_env, "atan", katan, 0);
 
-    /* 12.9.5 cos, sin, tan */
-    /* TODO */
+    /* 12.9.5 sqrt */
+    add_applicative(K, ground_env, "sqrt", ksqrt, 0);
 
-    /* 12.9.6 cos, sin, tan */
+    /* 12.9.6 expt */
     /* TODO */