X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/fc2157cb0f852c92ad5515a1f918326c6731b53c..8bb1c0421032b7f841f13c337afaa77071c6d2a4:/src/floatfns.c diff --git a/src/floatfns.c b/src/floatfns.c index 6b0f68585c..459f4d63fa 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,12 +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 -#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) && !defined (logb) extern double logb (); -#endif +#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. */ @@ -158,14 +175,39 @@ 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) >= (((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. */ @@ -175,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); } @@ -402,10 +444,10 @@ 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 accumulating */ + EMACS_INT acc, x, y; /* some binary powers of x then accumulating */ Lisp_Object val; x = XINT (arg1); @@ -423,7 +465,6 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, } else { - for (; y > 0; y--) while (y > 0) { if (y & 1) @@ -432,11 +473,11 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0, y = (unsigned)y >> 1; } } - XSET (val, Lisp_Int, acc); + 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; @@ -444,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); } @@ -604,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; } @@ -619,38 +660,57 @@ 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; { Lisp_Object val; - int value; + EMACS_INT value; double f = extract_float (arg); + if (f == 0.0) + value = -(VALMASK >> 1); + else + { #ifdef HAVE_LOGB - IN_FLOAT (value = logb (f), "logb", arg); - XSET (val, Lisp_Int, value); + IN_FLOAT (value = logb (f), "logb", arg); #else #ifdef HAVE_FREXP - { - int exp; - - IN_FLOAT (frexp (f, &exp), "logb", arg); - XSET (val, Lisp_Int, exp-1); - } + int ivalue; + IN_FLOAT (frexp (f, &ivalue), "logb", arg); + value = ivalue - 1; #else - Well, what *do* you have? + 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; } @@ -663,8 +723,13 @@ 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); + if (FLOATP (arg)) + { + double d; + + IN_FLOAT (d = ceil (XFLOAT (arg)->data), "ceiling", arg); + FLOAT_TO_INT (d, arg, "ceiling", arg); + } return arg; } @@ -682,23 +747,22 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.") if (! NILP (divisor)) { - int i1, i2; + EMACS_INT i1, i2; CHECK_NUMBER_OR_FLOAT (divisor, 1); #ifdef LISP_FLOAT_TYPE - if (XTYPE (arg) == Lisp_Float || XTYPE (divisor) == Lisp_Float) + if (FLOATP (arg) || FLOATP (divisor)) { double f1, f2; - f1 = XTYPE (arg) == Lisp_Float ? XFLOAT (arg)->data : XINT (arg); - f2 = (XTYPE (divisor) == Lisp_Float - ? XFLOAT (divisor)->data : XINT (divisor)); + 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 (XSET (arg, Lisp_Int, floor (f1 / f2)), - "floor", arg, divisor); + IN_FLOAT2 (f1 = floor (f1 / f2), "floor", arg, divisor); + FLOAT_TO_INT2 (f1, arg, "floor", arg, divisor); return arg; } #endif @@ -715,13 +779,17 @@ With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.") ? (i1 <= 0 ? -i1 / -i2 : -1 - ((i1 - 1) / -i2)) : (i1 < 0 ? -1 - ((-1 - i1) / i2) : i1 / i2)); - XSET (arg, Lisp_Int, i1); + XSETINT (arg, i1); return arg; } #ifdef LISP_FLOAT_TYPE - if (XTYPE (arg) == Lisp_Float) - IN_FLOAT (XSET (arg, Lisp_Int, floor (XFLOAT (arg)->data)), "floor", arg); + if (FLOATP (arg)) + { + double d; + IN_FLOAT (d = floor (XFLOAT (arg)->data), "floor", arg); + FLOAT_TO_INT (d, arg, "floor", arg); + } #endif return arg; @@ -736,9 +804,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; } @@ -751,13 +824,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, @@ -788,7 +865,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); } @@ -802,10 +879,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 @@ -907,11 +983,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);