klisp

commit b205307761ad4928e6dca14f6c721c9ef6684d08
parent bc146bc5128a5fffaf4db62075832e958ac4c952
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri,  6 May 2011 19:05:34 -0300

Added underflow/overflow checking to real->inexact when strict-arithmetic dynamic variable is true.

Diffstat:
M
src/kreal.c
 | 
38
++++++++++++++++++++++++++++++++++----

1 file changed, 34 insertions(+), 4 deletions(-)
diff --git a/src/kreal.c b/src/kreal.c
@@ -93,20 +93,50 @@ double kbigrat_to_double(klisp_State *K, Bigrat *bigrat)
    if set */
 TValue kexact_to_inexact(klisp_State *K, TValue n)
 {
+    bool strictp = bvalue(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);
-	/* d may be inf, ktag_double will handle it */
-	/* MAYBE should throw an exception if strict is on */
-	return ktag_double(d);
+	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);
-	return ktag_double(d);
+	/* 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;