diff --git a/src/lisp/GNUmakefile b/src/lisp/GNUmakefile index c557d3be43f8d8d90c497d81b57aadfc2027ffcb..056e9ea32eac5f2a58fdcc587da6a67603699985 100644 --- a/src/lisp/GNUmakefile +++ b/src/lisp/GNUmakefile @@ -12,7 +12,7 @@ FDLIBM = k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c \ e_acosh.c s_asinh.c e_atanh.c \ e_atan2.c \ e_rem_pio2.c k_rem_pio2.c \ - setexception.c + setexception.c double-values.c SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ vars.c parse.c interrupt.c search.c validate.c globals.c \ diff --git a/src/lisp/double-values.c b/src/lisp/double-values.c new file mode 100644 index 0000000000000000000000000000000000000000..79d59214d1a36880b7666142d2bbe68c55cdf65c --- /dev/null +++ b/src/lisp/double-values.c @@ -0,0 +1,40 @@ +/* + * Some helper functions to return specific double values for use by + * fdlibm_setexceptions on NetBSD. Currently, NetBSD doesn't have + * feraiseexcept so we have to do something special. See + * fdlibm_setexceptions. + */ + +#include "fdlibm.h" + +double +double_zero() +{ + return 0.0; +} + +/* + * Return most-positive-double-float + */ +double +double_huge() +{ + union { int i[2]; double d; } ux; + ux.i[HIWORD] = 0x7fefffff; + ux.i[LOWORD] = 0xffffffff; + + return ux.d; +} + +/* + * Return least-positive-double-float + */ +double +double_tiny() +{ + union { int i[2]; double d; } ux; + ux.i[HIWORD] = 0; + ux.i[LOWORD] = 1; + + return ux.d; +} diff --git a/src/lisp/setexception.c b/src/lisp/setexception.c index a77a9d8fa247629dd794c590181a48e307769ec3..d0f45199edcd1c5d92d4dd7a10170524f71a5cc0 100644 --- a/src/lisp/setexception.c +++ b/src/lisp/setexception.c @@ -1,4 +1,25 @@ +#if defined(__NetBSD__) +/* + * NetBSD doesn't have fenv.h. At least the version currently being + * used to build cmucl doesn't. Assume this also means we don't have + * feraiseexcept. So, to generate the desired exceptions, we have to + * create the appropriate operations to generate the desired + * exceptions. + */ +#undef HAVE_FERAISEEXCEPT + +extern double double_zero(); +extern double double_huge(); +extern double double_tiny(); + +#else +#define HAVE_FERAISEEXCEPT +#endif + +#ifdef HAVE_FERAISEEXCEPT #include <fenv.h> +#endif + #include <math.h> #include <stdio.h> @@ -50,32 +71,48 @@ fdlibm_setexception(double x, enum FDLIBM_EXCEPTION type) /* Division by zero. Use the sign of x to get the correct * signed infinity */ +#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_DIVBYZERO); - ret = copysign(INFINITY, x); +#else + ret = copysign(1, x) / double_zero(); +#endif + break; case 1: /* Underflow. Use the sign of x to get a signed zero. */ +#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_UNDERFLOW); ret = copysign(0.0, x); +#else + ret = double_tiny() * double_tiny();; +#endif break; case 2: /* overflow */ +#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_OVERFLOW); ret = copysign(INFINITY, x); +#else + ret = double_huge() * copysign(double_huge(), x); +#endif break; case 3: { - /* invalid */ + /* if */ if (!isQNaN(x)) { /* * If it's not a quiet NaN, we want to signal an invalid * operation. Otherwise, we silently return a NaN. */ +#ifdef HAVE_FERAISEEXCEPT feraiseexcept(FE_INVALID); +#else + ret = double_zero() / double_zero(); + return ret; +#endif } - /* * FIXME: Of the many NaN values that we have, what NaN * should we return?