X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/f89182a25c6d5519abf1354ac39da67f0fd749c0..029c56f6adfe39a015740f2bae38ab7ec4747d3d:/src/floatfns.c diff --git a/src/floatfns.c b/src/floatfns.c index 7d741ff144..de3e811acf 100644 --- a/src/floatfns.c +++ b/src/floatfns.c @@ -1,5 +1,5 @@ /* Primitive operations on floating point for GNU Emacs Lisp interpreter. - Copyright (C) 1988, 1993 Free Software Foundation, Inc. + Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc. This file is part of GNU Emacs. @@ -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,10 +53,29 @@ Lisp_Object Qarith_error; #ifdef LISP_FLOAT_TYPE +#ifdef MSDOS +/* These are redefined (correctly, but differently) in values.h. */ +#undef INTBITS +#undef LONGBITS +#undef SHORTBITS +#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 -/* These declarations are omitted on some systems, like Ultrix. */ +/* This declaration is omitted on some systems, like Ultrix. */ +#if !defined (HPUX) && defined (HAVE_LOGB) && !defined (logb) extern double logb (); +#endif /* not HPUX and HAVE_LOGB and no logb macro */ #if defined(DOMAIN) && defined(SING) && defined(OVERFLOW) /* If those are defined, then this is probably a `matherr' machine. */ @@ -65,7 +84,7 @@ extern double logb (); # endif #endif -#ifndef NO_MATHERR +#ifdef NO_MATHERR #undef HAVE_MATHERR #endif @@ -152,17 +171,43 @@ static char *float_error_fn_name; } \ } while (0) #else +#define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0) #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) >= (((EMACS_INT) 1) << (VALBITS-1)) || \ + (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \ + range_error (name, num); \ + XSETINT (i, (EMACS_INT)(x)); \ + } \ + while (0) +#define FLOAT_TO_INT2(x, i, name, num1, num2) \ + do \ + { \ + if ((x) >= (((EMACS_INT) 1) << (VALBITS-1)) || \ + (x) <= - (((EMACS_INT) 1) << (VALBITS-1)) - 1) \ + range_error2 (name, num1, num2); \ + XSETINT (i, (EMACS_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. */ @@ -172,7 +217,7 @@ extract_float (num) { CHECK_NUMBER_OR_FLOAT (num, 0); - if (XTYPE (num) == Lisp_Float) + if (FLOATP (num)) return XFLOAT (num)->data; return (double) XINT (num); } @@ -399,11 +444,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 (INTEGERP (arg1) /* common lisp spec */ + && INTEGERP (arg2)) /* don't promote, if both are ints */ { /* this can be improved by pre-calculating */ - int acc, x, y; /* some binary powers of x then acumulating */ - /* these, therby saving some time. -wsr */ + int acc, x, y; /* some binary powers of x then accumulating */ + Lisp_Object val; + x = XINT (arg1); y = XINT (arg2); acc = 1; @@ -419,7 +465,6 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, } else { - for (; y > 0; y--) while (y > 0) { if (y & 1) @@ -428,11 +473,11 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, y = (unsigned)y >> 1; } } - XSET (x, Lisp_Int, acc); - return x; + XSETINT (val, acc); + return val; } - f1 = (XTYPE (arg1) == Lisp_Float) ? XFLOAT (arg1)->data : XINT (arg1); - f2 = (XTYPE (arg2) == Lisp_Float) ? XFLOAT (arg2)->data : XINT (arg2); + f1 = FLOATP (arg1) ? XFLOAT (arg1)->data : XINT (arg1); + f2 = FLOATP (arg2) ? XFLOAT (arg2)->data : XINT (arg2); /* Really should check for overflow, too */ if (f1 == 0.0 && f2 == 0.0) f1 = 1.0; @@ -440,7 +485,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); } @@ -469,7 +514,7 @@ If second optional argument BASE is given, return log ARG using that base.") if (b == 10.0) IN_FLOAT2 (d = log10 (d), "log", arg, base); else - IN_FLOAT2 (d = log (arg) / log (b), "log", arg, base); + IN_FLOAT2 (d = log (d) / log (b), "log", arg, base); } return make_float (d); } @@ -600,10 +645,10 @@ DEFUN ("abs", Fabs, Sabs, 1, 1, 0, { CHECK_NUMBER_OR_FLOAT (arg, 0); - if (XTYPE (arg) == Lisp_Float) + if (FLOATP (arg)) IN_FLOAT (arg = make_float (fabs (XFLOAT (arg)->data)), "abs", arg); else if (XINT (arg) < 0) - XSETINT (arg, - XFASTINT (arg)); + XSETINT (arg, - XINT (arg)); return arg; } @@ -615,14 +660,14 @@ DEFUN ("float", Ffloat, Sfloat, 1, 1, 0, { CHECK_NUMBER_OR_FLOAT (arg, 0); - if (XTYPE (arg) == Lisp_Int) + if (INTEGERP (arg)) return make_float ((double) XINT (arg)); else /* give 'em the same float back */ return arg; } 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; @@ -631,18 +676,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 +#ifdef HAVE_FREXP + IN_FLOAT (frexp (f, &value), "logb", arg); + value--; #else - IN_FLOAT (value = logb (f), "logb", arg); - XSET (val, Lisp_Int, value); + 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 + } + XSETINT (val, value); return val; } @@ -655,25 +722,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)), "celing", arg); + if (FLOATP (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 (XTYPE (arg) == Lisp_Float) - IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg); + if (! NILP (divisor)) + { + int i1, i2; + + CHECK_NUMBER_OR_FLOAT (divisor, 1); + +#ifdef LISP_FLOAT_TYPE + if (FLOATP (arg) || FLOATP (divisor)) + { + double f1, f2; + + f1 = FLOATP (arg) ? XFLOAT (arg)->data : XINT (arg); + f2 = (FLOATP (divisor) ? 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)); + + XSETINT (arg, i1); + return arg; + } + +#ifdef LISP_FLOAT_TYPE + if (FLOATP (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) @@ -681,9 +803,14 @@ 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); + if (FLOATP (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; } @@ -696,13 +823,17 @@ Rounds the value toward zero.") { CHECK_NUMBER_OR_FLOAT (arg, 0); - if (XTYPE (arg) == Lisp_Float) - XSET (arg, Lisp_Int, (int) XFLOAT (arg)->data); + if (FLOATP (arg)) + { + 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, @@ -733,7 +864,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); } @@ -747,10 +878,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 @@ -819,8 +949,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); @@ -844,11 +982,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); @@ -859,17 +997,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 */