The functions truncate, round, floor, and ceiling return inexact results
when
given exact inputs. From I see in R5RS, these functions should return
exact results when given exact inputs. I've modified guile to do this.
The diffs are appended to this email. Personally I'm of the opinion
that
these four functions should return exact results on any legal input, but
that's not what the standard says...
Eric
[elorenzo@localhost libguile]$ diff -u numbers-old.c numbers.c
--- numbers-old.c Mon Mar 27 04:58:11 2000
+++ numbers.c Mon Mar 27 05:28:33 2000
@@ -4140,34 +4140,175 @@
-SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)())
scm_truncate, g_truncate);
+SCM_GPROC (s_truncate, "truncate", 1, 0, 0, scm_truncate, g_truncate);
-double
+SCM
scm_truncate (x)
- double x;
+ SCM x;
{
- if (x < 0.0)
- return -floor (-x);
- return floor (x);
+#ifdef SCM_FLOATS
+ double r, i;
+
+#endif
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_truncate, x, SCM_ARG1, s_truncate);
+
+ if ( SCM_INUMP (x) ) return x;
+
+#ifdef SCM_BIGDIG
+ if ( SCM_NIMP(x) && SCM_BIGP (x) ) return x;
+#endif
+
+#ifdef SCM_FLOATS
+ SCM_GASSERT1 (SCM_INEXP (x), g_truncate, x, SCM_ARG1, s_truncate);
+
+ if (!SCM_REALP (x))
+ {
+ r = SCM_REAL (x);
+ i = SCM_IMAG (x);
+
+ if ( r < 0 )
+ r = -floor( -r );
+ else
+ r = floor ( r );
+
+ if ( i < 0 )
+ i = -floor ( -i );
+ else
+ i = floor ( i );
+
+ return scm_makdbl ( r, i );
+ }
+
+ r = SCM_REALPART (x);
+ if ( r < 0 )
+ r = -floor( -r );
+ else
+ r = floor ( r );
+
+ return scm_makdbl ( r, 0 );
+#else
+ SCM_WTA_DISPATCH_1 (g_truncate, x, SCM_ARG1, s_truncate);
+#endif
}
-SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round,
g_round);
+SCM_GPROC (s_round, "round", 1, 0, 0, scm_round, g_round);
-double
+SCM
scm_round (x)
- double x;
+ SCM x;
{
- double plus_half = x + 0.5;
- double result = floor (plus_half);
+#ifdef SCM_FLOATS
+ double r, i, plus_half;
+
+#endif
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_round, x, SCM_ARG1, s_round);
+
+ if ( SCM_INUMP (x) ) return x;
+
+#ifdef SCM_BIGDIG
+ if ( SCM_NIMP(x) && SCM_BIGP (x) ) return x;
+#endif
+
+#ifdef SCM_FLOATS
+ SCM_GASSERT1 (SCM_INEXP (x), g_round, x, SCM_ARG1, s_round);
+
+ if (!SCM_REALP (x))
+ {
+ r = SCM_REAL (x);
+ plus_half = r + 0.5;
+ r = floor (plus_half);
+ /* Adjust so that the scm_round is towards even. */
+ r = (plus_half == r && plus_half / 2 != floor (plus_half / 2)) ?
r - 1 : r;
+
+ i = SCM_IMAG (x);
+ plus_half = i + 0.5;
+ i = floor (plus_half);
+ /* Adjust so that the scm_round is towards even. */
+ i = (plus_half == i && plus_half / 2 != floor (plus_half / 2)) ?
i - 1 : i;
+
+ return scm_makdbl ( r, i );
+ }
+
+ r = SCM_REALPART (x);
+ plus_half = r + 0.5;
+ r = floor (plus_half);
/* Adjust so that the scm_round is towards even. */
- return (plus_half == result && plus_half / 2 != floor (plus_half /
2))
- ? result - 1 : result;
+ r = (plus_half == r && plus_half / 2 != floor (plus_half / 2)) ? r -
1 : r;
+
+ return scm_makdbl ( r, 0 );
+
+#else
+ SCM_WTA_DISPATCH_1 (g_round, x, SCM_ARG1, s_round);
+#endif
}
+
+SCM_GPROC (s_floor, "floor", 1, 0, 0, scm_floor, g_floor);
+
+SCM
+scm_floor (x)
+ SCM x;
+{
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_floor, x, SCM_ARG1, s_floor);
+
+ if ( SCM_INUMP (x) ) return x;
+
+#ifdef SCM_BIGDIG
+ if ( SCM_NIMP(x) && SCM_BIGP (x) ) return x;
+#endif
+
+#ifdef SCM_FLOATS
+ SCM_GASSERT1 (SCM_INEXP (x), g_floor, x, SCM_ARG1, s_floor);
+
+ if (!SCM_REALP (x))
+ {
+ return scm_makdbl ( floor (SCM_REAL (x)), floor (SCM_IMAG (x)) );
+ }
+
+ return scm_makdbl ( floor (SCM_REALPART (x)), 0);
+#else
+ SCM_WTA_DISPATCH_1 (g_floor, x, SCM_ARG1, s_floor);
+#endif
+}
+
+
+
+
+SCM_GPROC (s_ceiling, "ceiling", 1, 0, 0, scm_ceiling, g_ceiling);
+
+SCM
+scm_ceiling (x)
+ SCM x;
+{
+ SCM_GASSERT1 (SCM_NUMBERP (x), g_ceiling, x, SCM_ARG1, s_ceiling);
+
+ if ( SCM_INUMP (x) ) return x;
+
+#ifdef SCM_BIGDIG
+ if ( SCM_NIMP(x) && SCM_BIGP (x) ) return x;
+#endif
+
+#ifdef SCM_FLOATS
+ SCM_GASSERT1 (SCM_INEXP (x), g_ceiling, x, SCM_ARG1, s_ceiling);
+
+ if (!SCM_REALP (x))
+ {
+ return scm_makdbl ( ceil (SCM_REAL (x)), ceil (SCM_IMAG (x)) );
+ }
+
+ return scm_makdbl (ceil (SCM_REALPART (x)), 0);
+#else
+ SCM_WTA_DISPATCH_1 (g_ceiling, x, SCM_ARG1, s_ceiling);
+#endif
+}
+
+
+
+
SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM
(*)()) scm_exact_to_inexact, g_exact_to_inexact);
double
@@ -4178,8 +4319,6 @@
}
-SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor,
g_i_floor);
-SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil,
g_i_ceil);
SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt,
g_i_sqrt);
SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
[elorenzo@localhost libguile]$ diff -u numbers-old.h numbers.h
--- numbers-old.h Mon Mar 27 04:58:11 2000
+++ numbers.h Mon Mar 27 01:54:13 2000
@@ -314,8 +314,10 @@
extern double scm_asinh SCM_P ((double x));
extern double scm_acosh SCM_P ((double x));
extern double scm_atanh SCM_P ((double x));
-extern double scm_truncate SCM_P ((double x));
-extern double scm_round SCM_P ((double x));
+extern SCM scm_truncate SCM_P ((SCM x));
+extern SCM scm_round SCM_P ((SCM x));
+extern SCM scm_floor SCM_P ((SCM x));
+extern SCM scm_ceiling SCM_P ((SCM x));
extern double scm_exact_to_inexact SCM_P ((double z));
extern SCM scm_sys_expt SCM_P ((SCM z1, SCM z2));
extern SCM scm_sys_atan2 SCM_P ((SCM z1, SCM z2));
