X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/eb8c3be94e12644f506b8857e49ffef88046bb0b..81a63ccc739d542b689f12177d9de9dae0f0e480:/src/floatfns.c diff --git a/src/floatfns.c b/src/floatfns.c index ca50a920f3..145cae0474 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -45,7 +45,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include -#include "config.h" +#include #include "lisp.h" #include "syssignal.h" @@ -53,19 +53,41 @@ Lisp_Object Qarith_error; #ifdef LISP_FLOAT_TYPE +#if 0 /* That is untrue--XINT is used below, and it uses INTBITS. + What in the world is values.h, anyway? */ +#ifdef MSDOS +/* These are redefined in and not used here */ +#undef INTBITS +#undef LONGBITS +#undef SHORTBITS +#endif +#endif + +/* Work around a problem that happens because math.h on hpux 7 + defines two static variables--which, in Emacs, are not really static, + because `static' is defined as nothing. The problem is that they are + defined both here and in lread.c. + These macros prevent the name conflict. */ +#if defined (HPUX) && !defined (HPUX8) +#define _MAXLDBL floatfns_maxldbl +#define _NMAXLDBL floatfns_nmaxldbl +#endif + #include -#ifndef hpux -/* These declarations are omitted on some systems, like Ultrix. */ +/* This declaration is omitted on some systems, like Ultrix. */ +#if !defined (hpux) && defined (HAVE_LOGB) extern double logb (); -#endif +#endif /* !hpux && HAVE_LOGB */ +#ifndef MSDOS #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW) /* If those are defined, then this is probably a `matherr' machine. */ # ifndef HAVE_MATHERR # define HAVE_MATHERR # endif #endif +#endif #ifdef NO_MATHERR #undef HAVE_MATHERR @@ -158,14 +180,37 @@ static char *float_error_fn_name; #define IN_FLOAT2(d, name, num, num2) (in_float = 1, (d), in_float = 0) #endif +/* Convert float to Lisp_Int if it fits, else signal a range error + using the given arguments. */ +#define FLOAT_TO_INT(x, i, name, num) \ + do \ + { \ + if ((x) >= (1 << (VALBITS-1)) || (x) <= - (1 << (VALBITS-1)) - 1) \ + range_error (name, num); \ + XSET (i, Lisp_Int, (int)(x)); \ + } \ + while (0) +#define FLOAT_TO_INT2(x, i, name, num1, num2) \ + do \ + { \ + if ((x) >= (1 << (VALBITS-1)) || (x) <= - (1 << (VALBITS-1)) - 1) \ + range_error2 (name, num1, num2); \ + XSET (i, Lisp_Int, (int)(x)); \ + } \ + while (0) + #define arith_error(op,arg) \ Fsignal (Qarith_error, Fcons (build_string ((op)), Fcons ((arg), Qnil))) #define range_error(op,arg) \ Fsignal (Qrange_error, Fcons (build_string ((op)), Fcons ((arg), Qnil))) +#define range_error2(op,a1,a2) \ + Fsignal (Qrange_error, Fcons (build_string ((op)), \ + Fcons ((a1), Fcons ((a2), Qnil)))) #define domain_error(op,arg) \ Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((arg), Qnil))) #define domain_error2(op,a1,a2) \ - Fsignal (Qdomain_error, Fcons (build_string ((op)), Fcons ((a1), Fcons ((a2), Qnil)))) + Fsignal (Qdomain_error, Fcons (build_string ((op)), \ + Fcons ((a1), Fcons ((a2), Qnil)))) /* Extract a Lisp number as a `double', or signal an error. */ @@ -402,11 +447,12 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, CHECK_NUMBER_OR_FLOAT (arg1, 0); CHECK_NUMBER_OR_FLOAT (arg2, 0); - if ((XTYPE (arg1) == Lisp_Int) && /* common lisp spec */ - (XTYPE (arg2) == Lisp_Int)) /* don't promote, if both are ints */ + if (XTYPE (arg1) == Lisp_Int /* common lisp spec */ + && XTYPE (arg2) == Lisp_Int) /* don't promote, if both are ints */ { /* this can be improved by pre-calculating */ int acc, x, y; /* some binary powers of x then accumulating */ - /* these, thereby saving some time. -wsr */ + Lisp_Object val; + x = XINT (arg1); y = XINT (arg2); acc = 1; @@ -422,7 +468,6 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, } else { - for (; y > 0; y--) while (y > 0) { if (y & 1) @@ -431,8 +476,8 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, y = (unsigned)y >> 1; } } - XSET (x, Lisp_Int, acc); - return x; + XSET (val, Lisp_Int, acc); + return val; } f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1); f2 = (XTYPE (arg2) == Lisp_Float) ? XFLOAT (arg2)->data : XINT (arg2); @@ -443,7 +488,7 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2))) domain_error2 ("expt", arg1, arg2); #endif - IN_FLOAT (f1 = pow (f1, f2), "expt", arg1); + IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2); return make_float (f1); } @@ -625,7 +670,7 @@ DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, } DEFUN ("logb", Flogb, Slogb, 1, 1, 0, - "Returns the integer not greater than the base 2 log of the magnitude of ARG.\n\ + "Returns largest integer <= the base 2 log of the magnitude of ARG.\n\ This is the same as the exponent of a float.") (arg) Lisp_Object arg; @@ -634,18 +679,40 @@ This is the same as the exponent of a float.") int value; double f = extract_float (arg); -#ifdef USG - { - int exp; - - IN_FLOAT (frexp (f, &exp), "logb", arg); - XSET (val, Lisp_Int, exp-1); - } + if (f == 0.0) + value = -(VALMASK >> 1); + else + { +#ifdef HAVE_LOGB + IN_FLOAT (value = logb (f), "logb", arg); #else - IN_FLOAT (value = logb (f), "logb", arg); - XSET (val, Lisp_Int, value); +#ifdef HAVE_FREXP + IN_FLOAT (frexp (f, &value), "logb", arg); + value--; +#else + int i; + double d; + if (f < 0.0) + f = -f; + value = -1; + while (f < 0.5) + { + for (i = 1, d = 0.5; d * d >= f; i += i) + d *= d; + f /= d; + value -= i; + } + while (f >= 1.0) + { + for (i = 1, d = 2.0; d * d <= f; i += i) + d *= d; + f /= d; + value += i; + } #endif - +#endif + } + XSET (val, Lisp_Int, value); return val; } @@ -659,24 +726,80 @@ DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0, CHECK_NUMBER_OR_FLOAT (arg, 0); if (XTYPE (arg) == Lisp_Float) - IN_FLOAT (XSET (arg, Lisp_Int, ceil (XFLOAT (arg)->data)), "ceiling", arg); + { + double d; + + IN_FLOAT (d = ceil (XFLOAT (arg)->data), "ceiling", arg); + FLOAT_TO_INT (d, arg, "ceiling", arg); + } return arg; } -DEFUN ("floor", Ffloor, Sfloor, 1, 1, 0, - "Return the largest integer no greater than ARG. (Round towards -inf.)") - (arg) - register Lisp_Object arg; +#endif /* LISP_FLOAT_TYPE */ + + +DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0, + "Return the largest integer no greater than ARG. (Round towards -inf.)\n\ +With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.") + (arg, divisor) + register Lisp_Object arg, divisor; { CHECK_NUMBER_OR_FLOAT (arg, 0); + if (! NILP (divisor)) + { + int i1, i2; + + CHECK_NUMBER_OR_FLOAT (divisor, 1); + +#ifdef LISP_FLOAT_TYPE + if (XTYPE (arg) == Lisp_Float || XTYPE (divisor) == Lisp_Float) + { + double f1, f2; + + f1 = XTYPE (arg) == Lisp_Float ? XFLOAT (arg)->data : XINT (arg); + f2 = (XTYPE (divisor) == Lisp_Float + ? XFLOAT (divisor)->data : XINT (divisor)); + if (f2 == 0) + Fsignal (Qarith_error, Qnil); + + IN_FLOAT2 (f1 = floor (f1 / f2), "floor", arg, divisor); + FLOAT_TO_INT2 (f1, arg, "floor", arg, divisor); + return arg; + } +#endif + + i1 = XINT (arg); + i2 = XINT (divisor); + + if (i2 == 0) + Fsignal (Qarith_error, Qnil); + + /* With C's /, the result is implementation-defined if either operand + is negative, so use only nonnegative operands. */ + i1 = (i2 < 0 + ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) + : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); + + XSET (arg, Lisp_Int, i1); + return arg; + } + +#ifdef LISP_FLOAT_TYPE if (XTYPE (arg) == Lisp_Float) - IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg); + { + double d; + IN_FLOAT (d = floor (XFLOAT (arg)->data), "floor", arg); + FLOAT_TO_INT (d, arg, "floor", arg); + } +#endif return arg; } +#ifdef LISP_FLOAT_TYPE + DEFUN ("round", Fround, Sround, 1, 1, 0, "Return the nearest integer to ARG.") (arg) @@ -685,8 +808,13 @@ DEFUN ("round", Fround, Sround, 1, 1, 0, CHECK_NUMBER_OR_FLOAT (arg, 0); if (XTYPE (arg) == Lisp_Float) - /* Screw the prevailing rounding mode. */ - IN_FLOAT (XSET (arg, Lisp_Int, rint (XFLOAT (arg)->data)), "round", arg); + { + double d; + + /* Screw the prevailing rounding mode. */ + IN_FLOAT (d = rint (XFLOAT (arg)->data), "round", arg); + FLOAT_TO_INT (d, arg, "round", arg); + } return arg; } @@ -700,12 +828,16 @@ Rounds the value toward zero.") CHECK_NUMBER_OR_FLOAT (arg, 0); if (XTYPE (arg) == Lisp_Float) - XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data); + { + double d; + + d = XFLOAT (arg)->data; + FLOAT_TO_INT (d, arg, "truncate", arg); + } return arg; } -#if 0 /* It's not clear these are worth adding. */ DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0, @@ -736,7 +868,7 @@ DEFUN ("fround", Ffround, Sfround, 1, 1, 0, register Lisp_Object arg; { double d = extract_float (arg); - IN_FLOAT (d = rint (XFLOAT (arg)->data), "fround", arg); + IN_FLOAT (d = rint (d), "fround", arg); return make_float (d); } @@ -750,10 +882,9 @@ Rounds the value toward zero.") if (d >= 0.0) IN_FLOAT (d = floor (d), "ftruncate", arg); else - IN_FLOAT (d = ceil (d), arg); + IN_FLOAT (d = ceil (d), "ftruncate", arg); return make_float (d); } -#endif #ifdef FLOAT_CATCH_SIGILL static SIGTYPE @@ -822,8 +953,16 @@ init_floatfns () in_float = 0; } +#else /* not LISP_FLOAT_TYPE */ + +init_floatfns () +{} + +#endif /* not LISP_FLOAT_TYPE */ + syms_of_floatfns () { +#ifdef LISP_FLOAT_TYPE defsubr (&Sacos); defsubr (&Sasin); defsubr (&Satan); @@ -847,11 +986,11 @@ syms_of_floatfns () defsubr (&Serfc); defsubr (&Slog_gamma); defsubr (&Scube_root); +#endif defsubr (&Sfceiling); defsubr (&Sffloor); defsubr (&Sfround); defsubr (&Sftruncate); -#endif defsubr (&Sexp); defsubr (&Sexpt); defsubr (&Slog); @@ -862,17 +1001,8 @@ syms_of_floatfns () defsubr (&Sfloat); defsubr (&Slogb); defsubr (&Sceiling); - defsubr (&Sfloor); defsubr (&Sround); defsubr (&Struncate); +#endif /* LISP_FLOAT_TYPE */ + defsubr (&Sfloor); } - -#else /* not LISP_FLOAT_TYPE */ - -init_floatfns () -{} - -syms_of_floatfns () -{} - -#endif /* not LISP_FLOAT_TYPE */