HCoop / bpt / emacs.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
* gud.el (gud-def): Doc fix.
[bpt/emacs.git] / src / floatfns.c
diff --git a/src/floatfns.c b/src/floatfns.c
index 1cf132d..ca5b937 100644 (file)
--- a/src/floatfns.c
+++ b/src/floatfns.c
@@ -1,11 +1,11 @@
 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
 /* Primitive operations on floating point for GNU Emacs Lisp interpreter.
-   Copyright (C) 1988 Free Software Foundation, Inc.
+   Copyright (C) 1988, 1992 Free Software Foundation, Inc.
 
 This file is part of GNU Emacs.
 
 GNU Emacs is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
 
 This file is part of GNU Emacs.
 
 GNU Emacs is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
+the Free Software Foundation; either version 2, or (at your option)
 any later version.
 
 GNU Emacs is distributed in the hope that it will be useful,
 any later version.
 
 GNU Emacs is distributed in the hope that it will be useful,
@@ -22,11 +22,28 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
 
 #include "config.h"
 #include "lisp.h"
 
 #include "config.h"
 #include "lisp.h"
+#include "syssignal.h"
 
 Lisp_Object Qarith_error;
 
 #ifdef LISP_FLOAT_TYPE
 
 Lisp_Object Qarith_error;
 
 #ifdef LISP_FLOAT_TYPE
+
 #include <math.h>
 #include <math.h>
+#include <errno.h>
+
+extern int errno;
+
+/* Avoid traps on VMS from sinh and cosh.
+   All the other functions set errno instead.  */
+
+#ifdef VMS
+#undef cosh
+#undef sinh
+#define cosh(x) ((exp(x)+exp(-x))*0.5)
+#define sinh(x) ((exp(x)-exp(-x))*0.5)
+#endif /* VMS */
+
+static SIGTYPE float_error ();
 
 /* Nonzero while executing in floating point.
    This tells float_error what to do.  */
 
 /* Nonzero while executing in floating point.
    This tells float_error what to do.  */
@@ -34,13 +51,19 @@ Lisp_Object Qarith_error;
 static int in_float;
 
 /* If an argument is out of range for a mathematical function,
 static int in_float;
 
 /* If an argument is out of range for a mathematical function,
-   that is detected with a signal.  Here is the actual argument
-   value to use in the error message.  */
+   here is the actual argument value to use in the error message.  */
 
 static Lisp_Object float_error_arg;
 
 
 static Lisp_Object float_error_arg;
 
-#define IN_FLOAT(d, num) \
-(in_float = 1, float_error_arg = num, (d), in_float = 0)
+/* Evaluate the floating point expression D, recording NUM
+   as the original argument for error messages.
+   D is normally an assignment expression.
+   Handle errors which may result in signals or may set errno.  */
+
+#define IN_FLOAT(D, NUM) \
+(in_float = 1, errno = 0, float_error_arg = NUM, (D),                  \
+ (errno == ERANGE || errno == EDOM ? float_error () : (SIGTYPE) 0),    \
+ in_float = 0)
 
 /* Extract a Lisp number as a `double', or signal an error.  */
 
 
 /* Extract a Lisp number as a `double', or signal an error.  */
 
@@ -54,6 +77,8 @@ extract_float (num)
     return XFLOAT (num)->data;
   return (double) XINT (num);
 }
     return XFLOAT (num)->data;
   return (double) XINT (num);
 }
+\f
+/* Trig functions.  */
 
 DEFUN ("acos", Facos, Sacos, 1, 1, 0,
   "Return the inverse cosine of ARG.")
 
 DEFUN ("acos", Facos, Sacos, 1, 1, 0,
   "Return the inverse cosine of ARG.")
@@ -65,56 +90,58 @@ DEFUN ("acos", Facos, Sacos, 1, 1, 0,
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
-  "Return the inverse hyperbolic cosine of ARG.")
+DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
+  "Return the inverse sine of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = acosh (d), num);
+  IN_FLOAT (d = asin (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
-  "Return the inverse sine of ARG.")
+DEFUN ("atan", Fatan, Satan, 1, 1, 0,
+  "Return the inverse tangent of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = asin (d), num);
+  IN_FLOAT (d = atan (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
-  "Return the inverse hyperbolic sine of ARG.")
+DEFUN ("cos", Fcos, Scos, 1, 1, 0,
+  "Return the cosine of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = asinh (d), num);
+  IN_FLOAT (d = cos (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("atan", Fatan, Satan, 1, 1, 0,
-  "Return the inverse tangent of ARG.")
+DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
+  "Return the sine of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = atan (d), num);
+  IN_FLOAT (d = sin (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
-  "Return the inverse hyperbolic tangent of ARG.")
+DEFUN ("tan", Ftan, Stan, 1, 1, 0,
+  "Return the tangent of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = atanh (d), num);
+  IN_FLOAT (d = tan (d), num);
   return make_float (d);
 }
 \f
   return make_float (d);
 }
 \f
+#if 0 /* Leave these out unless we find there's a reason for them.  */
+
 DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
   "Return the bessel function j0 of ARG.")
   (num)
 DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
   "Return the bessel function j0 of ARG.")
   (num)
@@ -180,36 +207,10 @@ The first arg (the order) is truncated to an integer.")
   IN_FLOAT (f2 = yn (i1, f2), num1);
   return make_float (f2);
 }
   IN_FLOAT (f2 = yn (i1, f2), num1);
   return make_float (f2);
 }
-\f
-DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
-  "Return the cube root of ARG.")
-  (num)
-     register Lisp_Object num;
-{
-  double d = extract_float (num);
-  IN_FLOAT (d = cbrt (d), num);
-  return make_float (d);
-}
-
-DEFUN ("cos", Fcos, Scos, 1, 1, 0,
-  "Return the cosine of ARG.")
-  (num)
-     register Lisp_Object num;
-{
-  double d = extract_float (num);
-  IN_FLOAT (d = cos (d), num);
-  return make_float (d);
-}
 
 
-DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
-  "Return the hyperbolic cosine of ARG.")
-  (num)
-     register Lisp_Object num;
-{
-  double d = extract_float (num);
-  IN_FLOAT (d = cosh (d), num);
-  return make_float (d);
-}
+#endif
+\f
+#if 0 /* Leave these out unless we see they are worth having.  */
 
 DEFUN ("erf", Ferf, Serf, 1, 1, 0,
   "Return the mathematical error function of ARG.")
 
 DEFUN ("erf", Ferf, Serf, 1, 1, 0,
   "Return the mathematical error function of ARG.")
@@ -231,26 +232,6 @@ DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
-  "Return the exponential base e of ARG.")
-  (num)
-     register Lisp_Object num;
-{
-  double d = extract_float (num);
-  IN_FLOAT (d = exp (d), num);
-  return make_float (d);
-}
-
-DEFUN ("expm1", Fexpm1, Sexpm1, 1, 1, 0,
-  "Return the exp (x)-1 of ARG.")
-  (num)
-     register Lisp_Object num;
-{
-  double d = extract_float (num);
-  IN_FLOAT (d = expm1 (d), num);
-  return make_float (d);
-}
-\f
 DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
   "Return the log gamma of ARG.")
   (num)
 DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
   "Return the log gamma of ARG.")
   (num)
@@ -261,38 +242,30 @@ DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("log", Flog, Slog, 1, 1, 0,
-  "Return the natural logarithm of ARG.")
-  (num)
-     register Lisp_Object num;
-{
-  double d = extract_float (num);
-  IN_FLOAT (d = log (d), num);
-  return make_float (d);
-}
-
-DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
-  "Return the logarithm base 10 of ARG.")
+DEFUN ("cbrt", Fcbrt, Scbrt, 1, 1, 0,
+  "Return the cube root of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = log10 (d), num);
+  IN_FLOAT (d = cbrt (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("log1p", Flog1p, Slog1p, 1, 1, 0,
-  "Return the log (1+x) of ARG.")
+#endif
+\f
+DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
+  "Return the exponential base e of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = log1p (d), num);
+  IN_FLOAT (d = exp (d), num);
   return make_float (d);
 }
 
 DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
   return make_float (d);
 }
 
 DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
-  "Return the exponential x ** y.")
+  "Return the exponential X ** Y.")
   (num1, num2)
      register Lisp_Object num1, num2;
 {
   (num1, num2)
      register Lisp_Object num1, num2;
 {
@@ -326,24 +299,33 @@ DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
   IN_FLOAT (f1 = pow (f1, f2), num1);
   return make_float (f1);
 }
   IN_FLOAT (f1 = pow (f1, f2), num1);
   return make_float (f1);
 }
-\f
-DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
-  "Return the sine of ARG.")
-  (num)
+
+DEFUN ("log", Flog, Slog, 1, 2, 0,
+  "Return the natural logarithm of NUM.
+If second optional argument BASE is given, return log NUM using that base.")
+  (num, base)
      register Lisp_Object num;
 {
   double d = extract_float (num);
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = sin (d), num);
+
+  if (NILP (base))
+    IN_FLOAT (d = log (d), num);
+  else
+    {
+      double b = extract_float (base);
+
+      IN_FLOAT (d = log (num) / log (b), num);
+    }
   return make_float (d);
 }
 
   return make_float (d);
 }
 
-DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
-  "Return the hyperbolic sine of ARG.")
+DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
+  "Return the logarithm base 10 of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = sinh (d), num);
+  IN_FLOAT (d = log10 (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
@@ -356,14 +338,56 @@ DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
   IN_FLOAT (d = sqrt (d), num);
   return make_float (d);
 }
   IN_FLOAT (d = sqrt (d), num);
   return make_float (d);
 }
+\f
+#if 0 /* Not clearly worth adding.  */
 
 
-DEFUN ("tan", Ftan, Stan, 1, 1, 0,
-  "Return the tangent of ARG.")
+DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
+  "Return the inverse hyperbolic cosine of ARG.")
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
   (num)
      register Lisp_Object num;
 {
   double d = extract_float (num);
-  IN_FLOAT (d = tan (d), num);
+  IN_FLOAT (d = acosh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
+  "Return the inverse hyperbolic sine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = asinh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
+  "Return the inverse hyperbolic tangent of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = atanh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
+  "Return the hyperbolic cosine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = cosh (d), num);
+  return make_float (d);
+}
+
+DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
+  "Return the hyperbolic sine of ARG.")
+  (num)
+     register Lisp_Object num;
+{
+  double d = extract_float (num);
+  IN_FLOAT (d = sinh (d), num);
   return make_float (d);
 }
 
   return make_float (d);
 }
 
@@ -376,6 +400,7 @@ DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
   IN_FLOAT (d = tanh (d), num);
   return make_float (d);
 }
   IN_FLOAT (d = tanh (d), num);
   return make_float (d);
 }
+#endif
 \f
 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
   "Return the absolute value of ARG.")
 \f
 DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
   "Return the absolute value of ARG.")
@@ -411,14 +436,17 @@ This is the same as the exponent of a float.")
      (num)
 Lisp_Object num;
 {
      (num)
 Lisp_Object num;
 {
+#ifdef USG
+  /* System V apparently doesn't have a `logb' function.  */
+  return Flog (num, make_number (2));
+#else
   Lisp_Object val;
   Lisp_Object val;
-  double f;
+  double f = extract_float (num);
 
 
-  CHECK_NUMBER_OR_FLOAT (num, 0);
-  f = (XTYPE (num) == Lisp_Float) ? XFLOAT (num)->data : XINT (num);
   IN_FLOAT (val = logb (f), num);
   XSET (val, Lisp_Int, val);
   return val;
   IN_FLOAT (val = logb (f), num);
   XSET (val, Lisp_Int, val);
   return val;
+#endif
 }
 
 /* the rounding functions  */
 }
 
 /* the rounding functions  */
@@ -457,7 +485,14 @@ DEFUN ("round", Fround, Sround, 1, 1, 0,
   CHECK_NUMBER_OR_FLOAT (num, 0);
 
   if (XTYPE (num) == Lisp_Float)
   CHECK_NUMBER_OR_FLOAT (num, 0);
 
   if (XTYPE (num) == Lisp_Float)
-    IN_FLOAT (XSET (num, Lisp_Int, rint (XFLOAT (num)->data)), num);
+    {
+#ifdef USG
+      /* Screw the prevailing rounding mode.  */
+      IN_FLOAT (XSET (num, Lisp_Int, floor (XFLOAT (num)->data + 0.5)), num);
+#else
+      IN_FLOAT (XSET (num, Lisp_Int, rint (XFLOAT (num)->data)), num);
+#endif
+    }
 
   return num;
 }
 
   return num;
 }
@@ -476,30 +511,29 @@ Rounds the value toward zero.")
   return num;
 }
 \f
   return num;
 }
 \f
-#ifdef BSD
-static
+static SIGTYPE
 float_error (signo)
      int signo;
 {
   if (! in_float)
     fatal_error_signal (signo);
 
 float_error (signo)
      int signo;
 {
   if (! in_float)
     fatal_error_signal (signo);
 
+#ifdef BSD
 #ifdef BSD4_1
   sigrelse (SIGILL);
 #else /* not BSD4_1 */
 #ifdef BSD4_1
   sigrelse (SIGILL);
 #else /* not BSD4_1 */
-  sigsetmask (0);
+  sigsetmask (SIGEMPTYMASK);
 #endif /* not BSD4_1 */
 #endif /* not BSD4_1 */
+#else
+  /* Must reestablish handler each time it is called.  */
+  signal (SIGILL, float_error);
+#endif /* BSD */
 
   in_float = 0;
 
   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
 }
 
 
   in_float = 0;
 
   Fsignal (Qarith_error, Fcons (float_error_arg, Qnil));
 }
 
-/* Another idea was to replace the library function `infnan'
-   where SIGILL is signaled.  */
-
-#endif /* BSD */
-
 init_floatfns ()
 {
   signal (SIGILL, float_error);
 init_floatfns ()
 {
   signal (SIGILL, float_error);
@@ -509,34 +543,34 @@ init_floatfns ()
 syms_of_floatfns ()
 {
   defsubr (&Sacos);
 syms_of_floatfns ()
 {
   defsubr (&Sacos);
-  defsubr (&Sacosh);
   defsubr (&Sasin);
   defsubr (&Sasin);
-  defsubr (&Sasinh);
   defsubr (&Satan);
   defsubr (&Satan);
+  defsubr (&Scos);
+  defsubr (&Ssin);
+  defsubr (&Stan);
+#if 0
+  defsubr (&Sacosh);
+  defsubr (&Sasinh);
   defsubr (&Satanh);
   defsubr (&Satanh);
+  defsubr (&Scosh);
+  defsubr (&Ssinh);
+  defsubr (&Stanh);
   defsubr (&Sbessel_y0);
   defsubr (&Sbessel_y1);
   defsubr (&Sbessel_yn);
   defsubr (&Sbessel_j0);
   defsubr (&Sbessel_j1);
   defsubr (&Sbessel_jn);
   defsubr (&Sbessel_y0);
   defsubr (&Sbessel_y1);
   defsubr (&Sbessel_yn);
   defsubr (&Sbessel_j0);
   defsubr (&Sbessel_j1);
   defsubr (&Sbessel_jn);
-  defsubr (&Scube_root);
-  defsubr (&Scos);
-  defsubr (&Scosh);
   defsubr (&Serf);
   defsubr (&Serfc);
   defsubr (&Serf);
   defsubr (&Serfc);
-  defsubr (&Sexp);
-  defsubr (&Sexpm1);
   defsubr (&Slog_gamma);
   defsubr (&Slog_gamma);
+  defsubr (&Scbrt);
+#endif
+  defsubr (&Sexp);
+  defsubr (&Sexpt);
   defsubr (&Slog);
   defsubr (&Slog10);
   defsubr (&Slog);
   defsubr (&Slog10);
-  defsubr (&Slog1p);
-  defsubr (&Sexpt);
-  defsubr (&Ssin);
-  defsubr (&Ssinh);
   defsubr (&Ssqrt);
   defsubr (&Ssqrt);
-  defsubr (&Stan);
-  defsubr (&Stanh);
 
   defsubr (&Sabs);
   defsubr (&Sfloat);
 
   defsubr (&Sabs);
   defsubr (&Sfloat);
Unnamed repository; edit this file 'description' to name the repository.