klisp

commit bc146bc5128a5fffaf4db62075832e958ac4c952
parent 9ea48b2648b3077624ef6a6f7c9cf11b34564e25
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri,  6 May 2011 12:45:36 -0300

Added strict arithmetic dynamic variable. Added with-strict-arithmetic & get-strict-arithmetic? to the ground environment. TODO make all the number procedures check the var for deciding when to throw certain errors (like under & overflow & no primary value result).

Diffstat:
M
src/Makefile
 | 
2
+-
M
src/kenvironment.h
 | 
2
+-
M
src/kgnumbers.c
 | 
32
+++++++++++++++++++++++++++++++-
M
src/kgnumbers.h
 | 
6
+++++-
M
src/kground.c
 | 
5
++++-
M
src/kstate.c
 | 
7
+++++++
M
src/kstate.h
 | 
12
++++++++++++

7 files changed, 61 insertions(+), 5 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -149,7 +149,7 @@ 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 kreal.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
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/kgnumbers.c b/src/kgnumbers.c
@@ -23,6 +23,7 @@
 
 #include "kghelpers.h"
 #include "kgnumbers.h"
+#include "kgkd_vars.h" /* for strict arith flag */
 
 /* 15.5.1? number?, finite?, integer? */
 /* use ftypep & ftypep_predp */
@@ -1190,7 +1191,36 @@ void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
 }
 
 /* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
-/* TODO */
+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 = kcurr_strict_arithp(K);
+    kapply_cc(K, res);
+}
 
 /* 12.8.1 rational? */
 /* uses ftypep */
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -140,7 +140,11 @@ void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
 		      TValue denv);
 
 /* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
-/* TODO */
+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 */
diff --git a/src/kground.c b/src/kground.c
@@ -833,7 +833,10 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "real->exact", kreal_to_exact, 0);
 
     /* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
-    /* TODO */
+    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
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) (tv2pair((K)->kd_strict_arith_key)->cdr)
+
 #endif