home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / floatfns.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-04  |  25.1 KB  |  1,065 lines
  1. /* Primitive operations on floating point for XEmacs Lisp interpreter.
  2.    Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
  3.  
  4. This file is part of XEmacs.
  5.  
  6. XEmacs is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by the
  8. Free Software Foundation; either version 2, or (at your option) any
  9. later version.
  10.  
  11. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14. for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with XEmacs; see the file COPYING.  If not, write to the Free
  18. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* Synched up with: FSF 19.28. */
  21.  
  22. /* ANSI C requires only these float functions:
  23.    acos, asin, atan, atan2, ceil, cos, cosh, exp, fabs, floor, fmod,
  24.    frexp, ldexp, log, log10, modf, pow, sin, sinh, sqrt, tan, tanh.
  25.  
  26.    Define HAVE_INVERSE_HYPERBOLIC if you have acosh, asinh, and atanh.
  27.    Define HAVE_CBRT if you have cbrt().
  28.    Define HAVE_RINT if you have rint().
  29.    If you don't define these, then the appropriate routines will be simulated.
  30.  
  31.    Define HAVE_MATHERR if on a system supporting the SysV matherr() callback.
  32.    (This should happen automatically.)
  33.  
  34.    Define FLOAT_CHECK_ERRNO if the float library routines set errno.
  35.    This has no effect if HAVE_MATHERR is defined.
  36.  
  37.    Define FLOAT_CATCH_SIGILL if the float library routines signal SIGILL.
  38.    (What systems actually do this?  Let me know. -jwz)
  39.  
  40.    Define FLOAT_CHECK_DOMAIN if the float library doesn't handle errors by
  41.    either setting errno, or signalling SIGFPE/SIGILL.  Otherwise, domain and
  42.    range checking will happen before calling the float routines.  This has
  43.    no effect if HAVE_MATHERR is defined (since matherr will be called when
  44.    a domain error occurs).
  45.  */
  46.  
  47. #include <config.h>
  48. #include "lisp.h"
  49. #include "syssignal.h"
  50.  
  51. #ifdef LISP_FLOAT_TYPE
  52.  
  53. /* Need to define a differentiating symbol -- see sysfloat.h */
  54. #define THIS_FILENAME floatfns
  55. #include "sysfloat.h"
  56.  
  57. #ifndef HAVE_RINT
  58. static double
  59. rint (double x)
  60. {
  61.   double r = floor (x + 0.5);
  62.   double diff = fabs (r - x);
  63.   /* Round to even and correct for any roundoff errors.  */
  64.   if (diff >= 0.5 && (diff > 0.5 || r != 2.0 * floor (r / 2.0)))
  65.     r += r < x ? 1.0 : -1.0;
  66.   return r;
  67. }
  68. #endif
  69.  
  70. /* Nonzero while executing in floating point.
  71.    This tells float_error what to do.  */
  72. static int in_float;
  73.  
  74. /* If an argument is out of range for a mathematical function,
  75.    here is the actual argument value to use in the error message.  */
  76. static Lisp_Object float_error_arg, float_error_arg2;
  77. static CONST char *float_error_fn_name;
  78.  
  79. /* Evaluate the floating point expression D, recording NUM
  80.    as the original argument for error messages.
  81.    D is normally an assignment expression.
  82.    Handle errors which may result in signals or may set errno.
  83.  
  84.    Note that float_error may be declared to return void, so you can't
  85.    just cast the zero after the colon to (SIGTYPE) to make the types
  86.    check properly.  */
  87. #ifdef FLOAT_CHECK_ERRNO
  88. #define IN_FLOAT(d, name, num)                \
  89.   do {                            \
  90.     float_error_arg = num;                \
  91.     float_error_fn_name = name;                \
  92.     in_float = 1; errno = 0; (d); in_float = 0;        \
  93.     if (errno != 0) in_float_error ();            \
  94.   } while (0)
  95. #define IN_FLOAT2(d, name, num, num2)            \
  96.   do {                            \
  97.     float_error_arg = num;                \
  98.     float_error_arg2 = num2;                \
  99.     float_error_fn_name = name;                \
  100.     in_float = 2; errno = 0; (d); in_float = 0;        \
  101.     if (errno != 0) in_float_error ();            \
  102.   } while (0)
  103. #else
  104. #define IN_FLOAT(d, name, num) (in_float = 1, (d), in_float = 0)
  105. #define IN_FLOAT2(d, name, num, num2) (in_float = 2, (d), in_float = 0)
  106. #endif
  107.  
  108.  
  109. #define arith_error(op,arg) \
  110.   Fsignal (Qarith_error, list2 (build_string ((op)), (arg)))
  111. #define range_error(op,arg) \
  112.   Fsignal (Qrange_error, list2 (build_string ((op)), (arg)))
  113. #define range_error2(op,a1,a2) \
  114.   Fsignal (Qrange_error, list3 (build_string ((op)), (a1), (a2)))
  115. #define domain_error(op,arg) \
  116.   Fsignal (Qdomain_error, list2 (build_string ((op)), (arg)))
  117. #define domain_error2(op,a1,a2) \
  118.   Fsignal (Qdomain_error, list3 (build_string ((op)), (a1), (a2)))
  119.  
  120.  
  121. /* Convert float to Lisp_Int if it fits, else signal a range error
  122.    using the given arguments.  */
  123. static Lisp_Object
  124. float_to_int (double x, CONST char *name, Lisp_Object num, Lisp_Object num2)
  125. {
  126.   if (x >= ((LISP_WORD_TYPE)1 << (VALBITS-1))
  127.       || x <= - ((LISP_WORD_TYPE)1 << (VALBITS-1)) - (LISP_WORD_TYPE)1)
  128.   {
  129.     if (!EQ (num2, Qunbound))
  130.       range_error2 (name, num, num2);
  131.     else
  132.       range_error (name, num);
  133.   }
  134.   return (make_number ((LISP_WORD_TYPE) x));
  135. }
  136.  
  137.  
  138. static void
  139. in_float_error (void)
  140. {
  141.   switch (errno)
  142.   {
  143.   case 0: 
  144.     break;
  145.   case EDOM:
  146.     if (in_float == 2)
  147.       domain_error2 (float_error_fn_name, float_error_arg, float_error_arg2);
  148.     else
  149.       domain_error (float_error_fn_name, float_error_arg);
  150.     break;
  151.   case ERANGE:
  152.     range_error (float_error_fn_name, float_error_arg);
  153.     break;
  154.   default:
  155.     arith_error (float_error_fn_name, float_error_arg);
  156.     break;
  157.   }
  158. }
  159.  
  160.   
  161.  
  162. static Lisp_Object mark_float (Lisp_Object, void (*) (Lisp_Object));
  163. extern void print_float (Lisp_Object, Lisp_Object, int);
  164. static int float_equal (Lisp_Object o1, Lisp_Object o2, int depth);
  165. static unsigned long float_hash (Lisp_Object obj, int depth);
  166. DEFINE_LRECORD_IMPLEMENTATION ("float", float,
  167.                                mark_float, print_float, 0, float_equal,
  168.                    float_hash, struct Lisp_Float);
  169.  
  170. static Lisp_Object
  171. mark_float (Lisp_Object obj, void (*markobj) (Lisp_Object))
  172. {
  173.   return (Qnil);
  174. }
  175.  
  176. static int
  177. float_equal (Lisp_Object o1, Lisp_Object o2, int depth)
  178. {
  179.   return (extract_float (o1) == extract_float (o2));
  180. }
  181.  
  182. static unsigned long
  183. float_hash (Lisp_Object obj, int depth)
  184. {
  185.   /* mod the value down to 32-bit range */
  186.   /* #### change for 64-bit machines */
  187.   return (unsigned long) fmod (extract_float (obj), 4e9);
  188. }
  189.  
  190.  
  191. /* Extract a Lisp number as a `double', or signal an error.  */
  192.  
  193. double
  194. extract_float (Lisp_Object num)
  195. {
  196.   CHECK_INT_OR_FLOAT (num, 0);
  197.  
  198.   if (FLOATP (num))
  199.     return (float_data (XFLOAT (num)));
  200.   return (double) XINT (num);
  201. }
  202. #endif /* LISP_FLOAT_TYPE */
  203.  
  204.  
  205. /* Trig functions.  */
  206. #ifdef LISP_FLOAT_TYPE
  207.  
  208. DEFUN ("acos", Facos, Sacos, 1, 1, 0,
  209.   "Return the inverse cosine of ARG.")
  210.   (arg)
  211.      Lisp_Object arg;
  212. {
  213.   double d = extract_float (arg);
  214. #ifdef FLOAT_CHECK_DOMAIN
  215.   if (d > 1.0 || d < -1.0)
  216.     domain_error ("acos", arg);
  217. #endif
  218.   IN_FLOAT (d = acos (d), "acos", arg);
  219.   return make_float (d);
  220. }
  221.  
  222. DEFUN ("asin", Fasin, Sasin, 1, 1, 0,
  223.   "Return the inverse sine of ARG.")
  224.   (arg)
  225.      Lisp_Object arg;
  226. {
  227.   double d = extract_float (arg);
  228. #ifdef FLOAT_CHECK_DOMAIN
  229.   if (d > 1.0 || d < -1.0)
  230.     domain_error ("asin", arg);
  231. #endif
  232.   IN_FLOAT (d = asin (d), "asin", arg);
  233.   return make_float (d);
  234. }
  235.  
  236. DEFUN ("atan", Fatan, Satan, 1, 2, 0,
  237.   "Return the inverse tangent of ARG.")
  238.   (arg1, arg2)
  239.      Lisp_Object arg1, arg2;
  240. {
  241.   double d = extract_float (arg1);
  242.  
  243.   if (NILP (arg2))
  244.     IN_FLOAT (d = atan (d), "atan", arg1);
  245.   else
  246.     {
  247.       double d2 = extract_float (arg2);
  248. #ifdef FLOAT_CHECK_DOMAIN
  249.       if (d == 0.0 && d2 == 0.0)
  250.     domain_error2 ("atan", arg1, arg2);
  251. #endif
  252.       IN_FLOAT2 (d = atan2 (d, d2), "atan", arg1, arg2);
  253.     }
  254.   return make_float (d);
  255. }
  256.  
  257. DEFUN ("cos", Fcos, Scos, 1, 1, 0,
  258.   "Return the cosine of ARG.")
  259.   (arg)
  260.      Lisp_Object arg;
  261. {
  262.   double d = extract_float (arg);
  263.   IN_FLOAT (d = cos (d), "cos", arg);
  264.   return make_float (d);
  265. }
  266.  
  267. DEFUN ("sin", Fsin, Ssin, 1, 1, 0,
  268.   "Return the sine of ARG.")
  269.   (arg)
  270.      Lisp_Object arg;
  271. {
  272.   double d = extract_float (arg);
  273.   IN_FLOAT (d = sin (d), "sin", arg);
  274.   return make_float (d);
  275. }
  276.  
  277. DEFUN ("tan", Ftan, Stan, 1, 1, 0,
  278.   "Return the tangent of ARG.")
  279.   (arg)
  280.      Lisp_Object arg;
  281. {
  282.   double d = extract_float (arg);
  283.   double c = cos (d);
  284. #ifdef FLOAT_CHECK_DOMAIN
  285.   if (c == 0.0)
  286.     domain_error ("tan", arg);
  287. #endif
  288.   IN_FLOAT (d = (sin (d) / c), "tan", arg);
  289.   return make_float (d);
  290. }
  291. #endif /* LISP_FLOAT_TYPE (trig functions) */
  292.  
  293.  
  294. /* Bessel functions */
  295. #if 0 /* Leave these out unless we find there's a reason for them.  */
  296. /* #ifdef LISP_FLOAT_TYPE */
  297.  
  298. DEFUN ("bessel-j0", Fbessel_j0, Sbessel_j0, 1, 1, 0,
  299.   "Return the bessel function j0 of ARG.")
  300.   (arg)
  301.      Lisp_Object arg;
  302. {
  303.   double d = extract_float (arg);
  304.   IN_FLOAT (d = j0 (d), "bessel-j0", arg);
  305.   return make_float (d);
  306. }
  307.  
  308. DEFUN ("bessel-j1", Fbessel_j1, Sbessel_j1, 1, 1, 0,
  309.   "Return the bessel function j1 of ARG.")
  310.   (arg)
  311.      Lisp_Object arg;
  312. {
  313.   double d = extract_float (arg);
  314.   IN_FLOAT (d = j1 (d), "bessel-j1", arg);
  315.   return make_float (d);
  316. }
  317.  
  318. DEFUN ("bessel-jn", Fbessel_jn, Sbessel_jn, 2, 2, 0,
  319.   "Return the order N bessel function output jn of ARG.\n\
  320. The first arg (the order) is truncated to an integer.")
  321.   (arg1, arg2)
  322.      Lisp_Object arg1, arg2;
  323. {
  324.   int i1 = extract_float (arg1);
  325.   double f2 = extract_float (arg2);
  326.  
  327.   IN_FLOAT (f2 = jn (i1, f2), "bessel-jn", arg1);
  328.   return make_float (f2);
  329. }
  330.  
  331. DEFUN ("bessel-y0", Fbessel_y0, Sbessel_y0, 1, 1, 0,
  332.   "Return the bessel function y0 of ARG.")
  333.   (arg)
  334.      Lisp_Object arg;
  335. {
  336.   double d = extract_float (arg);
  337.   IN_FLOAT (d = y0 (d), "bessel-y0", arg);
  338.   return make_float (d);
  339. }
  340.  
  341. DEFUN ("bessel-y1", Fbessel_y1, Sbessel_y1, 1, 1, 0,
  342.   "Return the bessel function y1 of ARG.")
  343.   (arg)
  344.      Lisp_Object arg;
  345. {
  346.   double d = extract_float (arg);
  347.   IN_FLOAT (d = y1 (d), "bessel-y0", arg);
  348.   return make_float (d);
  349. }
  350.  
  351. DEFUN ("bessel-yn", Fbessel_yn, Sbessel_yn, 2, 2, 0,
  352.   "Return the order N bessel function output yn of ARG.\n\
  353. The first arg (the order) is truncated to an integer.")
  354.   (arg1, arg2)
  355.      Lisp_Object arg1, arg2;
  356. {
  357.   int i1 = extract_float (arg1);
  358.   double f2 = extract_float (arg2);
  359.  
  360.   IN_FLOAT (f2 = yn (i1, f2), "bessel-yn", arg1);
  361.   return make_float (f2);
  362. }
  363.  
  364. #endif /* 0 (bessel functions) */
  365.  
  366. /* Error functions. */
  367. #if 0 /* Leave these out unless we see they are worth having.  */
  368. /* #ifdef LISP_FLOAT_TYPE */
  369.  
  370. DEFUN ("erf", Ferf, Serf, 1, 1, 0,
  371.   "Return the mathematical error function of ARG.")
  372.   (arg)
  373.      Lisp_Object arg;
  374. {
  375.   double d = extract_float (arg);
  376.   IN_FLOAT (d = erf (d), "erf", arg);
  377.   return make_float (d);
  378. }
  379.  
  380. DEFUN ("erfc", Ferfc, Serfc, 1, 1, 0,
  381.   "Return the complementary error function of ARG.")
  382.   (arg)
  383.      Lisp_Object arg;
  384. {
  385.   double d = extract_float (arg);
  386.   IN_FLOAT (d = erfc (d), "erfc", arg);
  387.   return make_float (d);
  388. }
  389.  
  390. DEFUN ("log-gamma", Flog_gamma, Slog_gamma, 1, 1, 0,
  391.   "Return the log gamma of ARG.")
  392.   (arg)
  393.      Lisp_Object arg;
  394. {
  395.   double d = extract_float (arg);
  396.   IN_FLOAT (d = lgamma (d), "log-gamma", arg);
  397.   return make_float (d);
  398. }
  399.  
  400. #endif /* 0 (error functions) */
  401.  
  402.  
  403. /* Root and Log functions. */
  404.  
  405. #ifdef LISP_FLOAT_TYPE
  406. DEFUN ("exp", Fexp, Sexp, 1, 1, 0,
  407.   "Return the exponential base e of ARG.")
  408.   (arg)
  409.      Lisp_Object arg;
  410. {
  411.   double d = extract_float (arg);
  412. #ifdef FLOAT_CHECK_DOMAIN
  413.   if (d > 709.7827)   /* Assume IEEE doubles here */
  414.     range_error ("exp", arg);
  415.   else if (d < -709.0)
  416.     return make_float (0.0);
  417.   else
  418. #endif
  419.     IN_FLOAT (d = exp (d), "exp", arg);
  420.   return make_float (d);
  421. }
  422. #endif /* LISP_FLOAT_TYPE */
  423.  
  424.  
  425. DEFUN ("expt", Fexpt, Sexpt, 2, 2, 0,
  426.   "Return the exponential X ** Y.")
  427.   (arg1, arg2)
  428.      Lisp_Object arg1, arg2;
  429. {
  430.   double f1, f2;
  431.  
  432.   CHECK_INT_OR_FLOAT (arg1, 0);
  433.   CHECK_INT_OR_FLOAT (arg2, 0);
  434.   if ((INTP (arg1)) && /* common lisp spec */
  435.       (INTP (arg2))) /* don't promote, if both are ints */
  436.     {
  437.       LISP_WORD_TYPE acc, x, y;
  438.       x = XINT (arg1);
  439.       y = XINT (arg2);
  440.       
  441.       if (y < 0)
  442.     {
  443.       if (x == 1)
  444.         acc = 1;
  445.       else if (x == -1)
  446.         acc = (y & 1) ? -1 : 1;
  447.       else
  448.         acc = 0;
  449.     }
  450.       else
  451.     {
  452.       acc = 1;
  453.       while (y > 0)
  454.         {
  455.           if (y & 1)
  456.         acc *= x;
  457.           x *= x;
  458.           y = (unsigned LISP_WORD_TYPE) y >> 1;
  459.         }
  460.     }
  461.       return (make_number (acc));
  462.     }
  463. #ifdef LISP_FLOAT_TYPE
  464.   f1 = (FLOATP (arg1)) ? float_data (XFLOAT (arg1)) : XINT (arg1);
  465.   f2 = (FLOATP (arg2)) ? float_data (XFLOAT (arg2)) : XINT (arg2);
  466.   /* Really should check for overflow, too */
  467.   if (f1 == 0.0 && f2 == 0.0)
  468.     f1 = 1.0;
  469. # ifdef FLOAT_CHECK_DOMAIN
  470.   else if ((f1 == 0.0 && f2 < 0.0) || (f1 < 0 && f2 != floor(f2)))
  471.     domain_error2 ("expt", arg1, arg2);
  472. # endif /* FLOAT_CHECK_DOMAIN */
  473.   IN_FLOAT2 (f1 = pow (f1, f2), "expt", arg1, arg2);
  474.   return make_float (f1);
  475. #else  /* !LISP_FLOAT_TYPE */
  476.   abort ();
  477. #endif /* LISP_FLOAT_TYPE */
  478. }
  479.  
  480. #ifdef LISP_FLOAT_TYPE
  481. DEFUN ("log", Flog, Slog, 1, 2, 0,
  482.   "Return the natural logarithm of ARG.\n\
  483. If second optional argument BASE is given, return log ARG using that base.")
  484.   (arg, base)
  485.      Lisp_Object arg, base;
  486. {
  487.   double d = extract_float (arg);
  488. #ifdef FLOAT_CHECK_DOMAIN
  489.   if (d <= 0.0)
  490.     domain_error2 ("log", arg, base);
  491. #endif
  492.   if (NILP (base))
  493.     IN_FLOAT (d = log (d), "log", arg);
  494.   else
  495.     {
  496.       double b = extract_float (base);
  497. #ifdef FLOAT_CHECK_DOMAIN
  498.       if (b <= 0.0 || b == 1.0)
  499.     domain_error2 ("log", arg, base);
  500. #endif
  501.       if (b == 10.0)
  502.     IN_FLOAT2 (d = log10 (d), "log", arg, base);
  503.       else
  504.     IN_FLOAT2 (d = (log (d) / log (b)), "log", arg, base);
  505.     }
  506.   return make_float (d);
  507. }
  508.  
  509.  
  510. DEFUN ("log10", Flog10, Slog10, 1, 1, 0,
  511.   "Return the logarithm base 10 of ARG.")
  512.   (arg)
  513.      Lisp_Object arg;
  514. {
  515.   double d = extract_float (arg);
  516. #ifdef FLOAT_CHECK_DOMAIN
  517.   if (d <= 0.0)
  518.     domain_error ("log10", arg);
  519. #endif
  520.   IN_FLOAT (d = log10 (d), "log10", arg);
  521.   return make_float (d);
  522. }
  523.  
  524.  
  525. DEFUN ("sqrt", Fsqrt, Ssqrt, 1, 1, 0,
  526.   "Return the square root of ARG.")
  527.   (arg)
  528.      Lisp_Object arg;
  529. {
  530.   double d = extract_float (arg);
  531. #ifdef FLOAT_CHECK_DOMAIN
  532.   if (d < 0.0)
  533.     domain_error ("sqrt", arg);
  534. #endif
  535.   IN_FLOAT (d = sqrt (d), "sqrt", arg);
  536.   return make_float (d);
  537. }
  538.  
  539.  
  540. DEFUN ("cube-root", Fcube_root, Scube_root, 1, 1, 0,
  541.   "Return the cube root of ARG.")
  542.   (arg)
  543.      Lisp_Object arg;
  544. {
  545.   double d = extract_float (arg);
  546. #ifdef HAVE_CBRT
  547.   IN_FLOAT (d = cbrt (d), "cube-root", arg);
  548. #else
  549.   if (d >= 0.0)
  550.     IN_FLOAT (d = pow (d, 1.0/3.0), "cube-root", arg);
  551.   else
  552.     IN_FLOAT (d = -pow (-d, 1.0/3.0), "cube-root", arg);
  553. #endif
  554.   return make_float (d);
  555. }
  556. #endif /* LISP_FLOAT_TYPE */
  557.  
  558.  
  559. /* Inverse trig functions. */
  560. #ifdef LISP_FLOAT_TYPE
  561. /* #if 0  Not clearly worth adding...  */
  562.  
  563. DEFUN ("acosh", Facosh, Sacosh, 1, 1, 0,
  564.   "Return the inverse hyperbolic cosine of ARG.")
  565.   (arg)
  566.      Lisp_Object arg;
  567. {
  568.   double d = extract_float (arg);
  569. #ifdef FLOAT_CHECK_DOMAIN
  570.   if (d < 1.0)
  571.     domain_error ("acosh", arg);
  572. #endif
  573. #ifdef HAVE_INVERSE_HYPERBOLIC
  574.   IN_FLOAT (d = acosh (d), "acosh", arg);
  575. #else
  576.   IN_FLOAT (d = log (d + sqrt (d*d - 1.0)), "acosh", arg);
  577. #endif
  578.   return make_float (d);
  579. }
  580.  
  581. DEFUN ("asinh", Fasinh, Sasinh, 1, 1, 0,
  582.   "Return the inverse hyperbolic sine of ARG.")
  583.   (arg)
  584.      Lisp_Object arg;
  585. {
  586.   double d = extract_float (arg);
  587. #ifdef HAVE_INVERSE_HYPERBOLIC
  588.   IN_FLOAT (d = asinh (d), "asinh", arg);
  589. #else
  590.   IN_FLOAT (d = log (d + sqrt (d*d + 1.0)), "asinh", arg);
  591. #endif
  592.   return make_float (d);
  593. }
  594.  
  595. DEFUN ("atanh", Fatanh, Satanh, 1, 1, 0,
  596.   "Return the inverse hyperbolic tangent of ARG.")
  597.   (arg)
  598.      Lisp_Object arg;
  599. {
  600.   double d = extract_float (arg);
  601. #ifdef FLOAT_CHECK_DOMAIN
  602.   if (d >= 1.0 || d <= -1.0)
  603.     domain_error ("atanh", arg);
  604. #endif
  605. #ifdef HAVE_INVERSE_HYPERBOLIC
  606.   IN_FLOAT (d = atanh (d), "atanh", arg);
  607. #else
  608.   IN_FLOAT (d = 0.5 * log ((1.0 + d) / (1.0 - d)), "atanh", arg);
  609. #endif
  610.   return make_float (d);
  611. }
  612.  
  613. DEFUN ("cosh", Fcosh, Scosh, 1, 1, 0,
  614.   "Return the hyperbolic cosine of ARG.")
  615.   (arg)
  616.      Lisp_Object arg;
  617. {
  618.   double d = extract_float (arg);
  619. #ifdef FLOAT_CHECK_DOMAIN
  620.   if (d > 710.0 || d < -710.0)
  621.     range_error ("cosh", arg);
  622. #endif
  623.   IN_FLOAT (d = cosh (d), "cosh", arg);
  624.   return make_float (d);
  625. }
  626.  
  627. DEFUN ("sinh", Fsinh, Ssinh, 1, 1, 0,
  628.   "Return the hyperbolic sine of ARG.")
  629.   (arg)
  630.      Lisp_Object arg;
  631. {
  632.   double d = extract_float (arg);
  633. #ifdef FLOAT_CHECK_DOMAIN
  634.   if (d > 710.0 || d < -710.0)
  635.     range_error ("sinh", arg);
  636. #endif
  637.   IN_FLOAT (d = sinh (d), "sinh", arg);
  638.   return make_float (d);
  639. }
  640.  
  641. DEFUN ("tanh", Ftanh, Stanh, 1, 1, 0,
  642.   "Return the hyperbolic tangent of ARG.")
  643.   (arg)
  644.      Lisp_Object arg;
  645. {
  646.   double d = extract_float (arg);
  647.   IN_FLOAT (d = tanh (d), "tanh", arg);
  648.   return make_float (d);
  649. }
  650. #endif /* LISP_FLOAT_TYPE (inverse trig functions) */
  651.  
  652. /* Rounding functions */
  653.  
  654. DEFUN ("abs", Fabs, Sabs, 1, 1, 0,
  655.   "Return the absolute value of ARG.")
  656.   (arg)
  657.      Lisp_Object arg;
  658. {
  659.   CHECK_INT_OR_FLOAT (arg, 0);
  660.  
  661. #ifdef LISP_FLOAT_TYPE
  662.   if (FLOATP (arg))
  663.   {
  664.     IN_FLOAT (arg = make_float ((double) fabs (float_data (XFLOAT (arg)))),
  665.               "abs", arg);
  666.     return (arg);
  667.   }
  668.   else
  669. #endif /* LISP_FLOAT_TYPE */
  670.     if (XINT (arg) < 0)
  671.       return (make_number (- XINT (arg)));
  672.     else
  673.       return (arg);
  674. }
  675.  
  676. #ifdef LISP_FLOAT_TYPE
  677. DEFUN ("float", Ffloat, Sfloat, 1, 1, 0,
  678.   "Return the floating point number equal to ARG.")
  679.   (arg)
  680.      Lisp_Object arg;
  681. {
  682.   CHECK_INT_OR_FLOAT (arg, 0);
  683.  
  684.   if (INTP (arg))
  685.     return make_float ((double) XINT (arg));
  686.   else                /* give 'em the same float back */
  687.     return arg;
  688. }
  689. #endif /* LISP_FLOAT_TYPE */
  690.  
  691.  
  692. #ifdef LISP_FLOAT_TYPE
  693. DEFUN ("logb", Flogb, Slogb, 1, 1, 0,
  694.   "Return largest integer <= the base 2 log of the magnitude of ARG.\n\
  695. This is the same as the exponent of a float.")
  696.      (arg)
  697.      Lisp_Object arg;
  698. {
  699.   double f = extract_float (arg);
  700.  
  701.   if (f == 0.0)
  702.     return (make_number (- (1 << (VALBITS - 1)))); /* most-negative-fixnum */
  703. #ifdef HAVE_LOGB
  704.   {
  705.     Lisp_Object val;
  706.     IN_FLOAT (val = make_number (logb (f)), "logb", arg);
  707.     return (val);
  708.   }
  709. #else
  710. #ifdef HAVE_FREXP
  711.   {
  712.     int exp;  
  713.     IN_FLOAT (frexp (f, &exp), "logb", arg);
  714.     return (make_number (exp - 1));
  715.   }
  716. #else
  717.   {
  718.     int i;
  719.     double d;
  720.     LISP_WORD_TYPE val;
  721.     if (f < 0.0)
  722.       f = -f;
  723.     val = -1;
  724.     while (f < 0.5)
  725.       {
  726.         for (i = 1, d = 0.5; d * d >= f; i += i)
  727.           d *= d;
  728.         f /= d;
  729.         val -= i;
  730.       }
  731.     while (f >= 1.0)
  732.       {
  733.         for (i = 1, d = 2.0; d * d <= f; i += i)
  734.           d *= d;
  735.         f /= d;
  736.         val += i;
  737.       }
  738.     return (make_number (val));
  739.   }
  740. #endif /* ! HAVE_FREXP */
  741. #endif /* ! HAVE_LOGB */
  742. }
  743. #endif /* LISP_FLOAT_TYPE */
  744.  
  745.  
  746. DEFUN ("ceiling", Fceiling, Sceiling, 1, 1, 0,
  747.   "Return the smallest integer no less than ARG.  (Round toward +inf.)")
  748.   (arg)
  749.      Lisp_Object arg;
  750. {
  751.   CHECK_INT_OR_FLOAT (arg, 0);
  752.  
  753. #ifdef LISP_FLOAT_TYPE
  754.   if (FLOATP (arg))
  755.   {
  756.     double d;
  757.     IN_FLOAT ((d = ceil (float_data (XFLOAT (arg)))), "ceiling", arg);
  758.     return (float_to_int (d, "ceiling", arg, Qunbound));
  759.   }
  760. #endif /* LISP_FLOAT_TYPE */
  761.  
  762.   return arg;
  763. }
  764.  
  765.  
  766. DEFUN ("floor", Ffloor, Sfloor, 1, 2, 0,
  767.   "Return the largest integer no greater than ARG.  (Round towards -inf.)\n\
  768. With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR.")
  769.   (arg, divisor)
  770.      Lisp_Object arg, divisor;
  771. {
  772.   CHECK_INT_OR_FLOAT (arg, 0);
  773.  
  774.   if (! NILP (divisor))
  775.     {
  776.       int i1, i2;
  777.  
  778.       CHECK_INT_OR_FLOAT (divisor, 1);
  779.  
  780. #ifdef LISP_FLOAT_TYPE
  781.       if (FLOATP (arg) || FLOATP (divisor))
  782.     {
  783.       double f1, f2;
  784.  
  785.       f1 = ((FLOATP (arg)) ? float_data (XFLOAT (arg)) : XINT (arg));
  786.       f2 = ((FLOATP (divisor)) ? float_data (XFLOAT (divisor)) : XINT (divisor));
  787.       if (f2 == 0)
  788.         Fsignal (Qarith_error, Qnil);
  789.  
  790.       IN_FLOAT2 (f1 = floor (f1 / f2), "floor", arg, divisor);
  791.       return float_to_int (f1, "floor", arg, divisor);
  792.     }
  793. #endif /* LISP_FLOAT_TYPE */
  794.  
  795.       i1 = XINT (arg);
  796.       i2 = XINT (divisor);
  797.  
  798.       if (i2 == 0)
  799.     Fsignal (Qarith_error, Qnil);
  800.  
  801.       /* With C's /, the result is implementation-defined if either operand
  802.      is negative, so use only nonnegative operands.  */
  803.       i1 = (i2 < 0
  804.         ? (i1 <= 0  ?  -i1 / -i2  :  -1 - ((i1 - 1) / -i2))
  805.         : (i1 < 0  ?  -1 - ((-1 - i1) / i2)  :  i1 / i2));
  806.  
  807.       return (make_number (i1));
  808.     }
  809.  
  810. #ifdef LISP_FLOAT_TYPE
  811.   if (FLOATP (arg))
  812.   {
  813.     double d;
  814.     IN_FLOAT ((d = floor (float_data (XFLOAT (arg)))), "floor", arg);
  815.     return (float_to_int (d, "floor", arg, Qunbound));
  816.   }
  817. #endif /* LISP_FLOAT_TYPE */
  818.  
  819.   return arg;
  820. }
  821.  
  822. DEFUN ("round", Fround, Sround, 1, 1, 0,
  823.   "Return the nearest integer to ARG.")
  824.   (arg)
  825.      Lisp_Object arg;
  826. {
  827.   CHECK_INT_OR_FLOAT (arg, 0);
  828.  
  829. #ifdef LISP_FLOAT_TYPE
  830.   if (FLOATP (arg))
  831.   {
  832.     double d;
  833.     /* Screw the prevailing rounding mode.  */
  834.     IN_FLOAT ((d = rint (float_data (XFLOAT (arg)))), "round", arg);
  835.     return (float_to_int (d, "round", arg, Qunbound));
  836.   }
  837. #endif /* LISP_FLOAT_TYPE */
  838.  
  839.   return arg;
  840. }
  841.  
  842. DEFUN ("truncate", Ftruncate, Struncate, 1, 1, 0,
  843.        "Truncate a floating point number to an integer.\n\
  844. Rounds the value toward zero.")
  845.   (arg)
  846.      Lisp_Object arg;
  847. {
  848.   CHECK_INT_OR_FLOAT (arg, 0);
  849.  
  850. #ifdef LISP_FLOAT_TYPE
  851.   if (FLOATP (arg))
  852.     return (float_to_int (float_data (XFLOAT (arg)),
  853.                           "truncate", arg, Qunbound));
  854. #endif /* LISP_FLOAT_TYPE */
  855.  
  856.   return arg;
  857. }
  858.  
  859. /* Float-rounding functions. */
  860. #ifdef LISP_FLOAT_TYPE
  861. /* #if 1  It's not clear these are worth adding... */
  862.  
  863. DEFUN ("fceiling", Ffceiling, Sfceiling, 1, 1, 0,
  864.   "Return the smallest integer no less than ARG, as a float.\n\
  865. \(Round toward +inf.\)")
  866.   (arg)
  867.      Lisp_Object arg;
  868. {
  869.   double d = extract_float (arg);
  870.   IN_FLOAT (d = ceil (d), "fceiling", arg);
  871.   return make_float (d);
  872. }
  873.  
  874. DEFUN ("ffloor", Fffloor, Sffloor, 1, 1, 0,
  875.   "Return the largest integer no greater than ARG, as a float.\n\
  876. \(Round towards -inf.\)")
  877.   (arg)
  878.      Lisp_Object arg;
  879. {
  880.   double d = extract_float (arg);
  881.   IN_FLOAT (d = floor (d), "ffloor", arg);
  882.   return make_float (d);
  883. }
  884.  
  885. DEFUN ("fround", Ffround, Sfround, 1, 1, 0,
  886.   "Return the nearest integer to ARG, as a float.")
  887.   (arg)
  888.      Lisp_Object arg;
  889. {
  890.   double d = extract_float (arg);
  891.   IN_FLOAT (d = rint (d), "fround", arg);
  892.   return make_float (d);
  893. }
  894.  
  895. DEFUN ("ftruncate", Fftruncate, Sftruncate, 1, 1, 0,
  896.        "Truncate a floating point number to an integral float value.\n\
  897. Rounds the value toward zero.")
  898.   (arg)
  899.      Lisp_Object arg;
  900. {
  901.   double d = extract_float (arg);
  902.   if (d >= 0.0)
  903.     IN_FLOAT (d = floor (d), "ftruncate", arg);
  904.   else
  905.     IN_FLOAT (d = ceil (d), "ftruncate", arg);
  906.   return make_float (d);
  907. }
  908.  
  909. #endif /* LISP_FLOAT_TYPE (float-rounding functions) */
  910.  
  911.  
  912. #ifdef LISP_FLOAT_TYPE
  913. #ifdef FLOAT_CATCH_SIGILL
  914. static SIGTYPE
  915. float_error (int signo)
  916. {
  917.   if (! in_float)
  918.     fatal_error_signal (signo);
  919.  
  920.   EMACS_REESTABLISH_SIGNAL (signo, arith_error);
  921.   EMACS_UNBLOCK_SIGNAL (signo);
  922.  
  923.   in_float = 0;
  924.  
  925.   /* Was Fsignal(), but it just doesn't make sense for an error
  926.      occurring inside a signal handler to be restartable, considering
  927.      that anything could happen when the error is signaled and trapped
  928.      and considering the asynchronous nature of signal handlers. */
  929.   signal_error (Qarith_error, list1 (float_error_arg));
  930. }
  931.  
  932. /* Another idea was to replace the library function `infnan'
  933.    where SIGILL is signaled.  */
  934.  
  935. #endif /* FLOAT_CATCH_SIGILL */
  936.  
  937. #ifdef HAVE_MATHERR
  938. int 
  939. matherr (struct exception *x)
  940. {
  941.   Lisp_Object args;
  942.   if (! in_float)
  943.     /* Not called from emacs-lisp float routines; do the default thing. */
  944.     return 0;
  945.  
  946.   /* if (!strcmp (x->name, "pow")) x->name = "expt"; */
  947.  
  948.   args = Fcons (build_string (x->name),
  949.                 Fcons (make_float (x->arg1),
  950.                        ((in_float == 2)
  951.                         ? Fcons (make_float (x->arg2), Qnil)
  952.                         : Qnil)));
  953.   switch (x->type)
  954.     {
  955.     case DOMAIN:    Fsignal (Qdomain_error, args);        break;
  956.     case SING:        Fsignal (Qsingularity_error, args);    break;
  957.     case OVERFLOW:    Fsignal (Qoverflow_error, args);    break;
  958.     case UNDERFLOW:    Fsignal (Qunderflow_error, args);    break;
  959.     default:        Fsignal (Qarith_error, args);        break;
  960.     }
  961.   return (1);    /* don't set errno or print a message */
  962. }
  963. #endif /* HAVE_MATHERR */
  964. #endif /* LISP_FLOAT_TYPE */
  965.  
  966.  
  967. void
  968. init_floatfns_very_early (void)
  969. {
  970. #ifdef LISP_FLOAT_TYPE
  971. # ifdef FLOAT_CATCH_SIGILL
  972.   signal (SIGILL, float_error);
  973. # endif 
  974.   in_float = 0;
  975. #endif /* LISP_FLOAT_TYPE */
  976. }
  977.  
  978. void
  979. syms_of_floatfns (void)
  980. {
  981.   
  982.   /* Trig functions.  */
  983.   
  984. #ifdef LISP_FLOAT_TYPE
  985.   defsubr (&Sacos);
  986.   defsubr (&Sasin);
  987.   defsubr (&Satan);
  988.   defsubr (&Scos);
  989.   defsubr (&Ssin);
  990.   defsubr (&Stan);
  991. #endif /* LISP_FLOAT_TYPE */
  992.  
  993.   /* Bessel functions */
  994.   
  995. #if 0
  996.   defsubr (&Sbessel_y0);
  997.   defsubr (&Sbessel_y1);
  998.   defsubr (&Sbessel_yn);
  999.   defsubr (&Sbessel_j0);
  1000.   defsubr (&Sbessel_j1);
  1001.   defsubr (&Sbessel_jn);
  1002. #endif /* 0 */
  1003.  
  1004.   /* Error functions. */
  1005.  
  1006. #if 0
  1007.   defsubr (&Serf);
  1008.   defsubr (&Serfc);
  1009.   defsubr (&Slog_gamma);
  1010. #endif /* 0 */
  1011.  
  1012.   /* Root and Log functions. */
  1013.  
  1014. #ifdef LISP_FLOAT_TYPE
  1015.   defsubr (&Sexp);
  1016. #endif /* LISP_FLOAT_TYPE */
  1017.   defsubr (&Sexpt);
  1018. #ifdef LISP_FLOAT_TYPE
  1019.   defsubr (&Slog);
  1020.   defsubr (&Slog10);
  1021.   defsubr (&Ssqrt);
  1022.   defsubr (&Scube_root);
  1023. #endif /* LISP_FLOAT_TYPE */
  1024.  
  1025.   /* Inverse trig functions. */
  1026.  
  1027. #ifdef LISP_FLOAT_TYPE
  1028.   defsubr (&Sacosh);
  1029.   defsubr (&Sasinh);
  1030.   defsubr (&Satanh);
  1031.   defsubr (&Scosh);
  1032.   defsubr (&Ssinh);
  1033.   defsubr (&Stanh);
  1034. #endif /* LISP_FLOAT_TYPE */
  1035.  
  1036.   /* Rounding functions */
  1037.  
  1038.   defsubr (&Sabs);
  1039. #ifdef LISP_FLOAT_TYPE
  1040.   defsubr (&Sfloat);
  1041.   defsubr (&Slogb);
  1042. #endif /* LISP_FLOAT_TYPE */
  1043.   defsubr (&Sceiling);
  1044.   defsubr (&Sfloor);
  1045.   defsubr (&Sround);
  1046.   defsubr (&Struncate);
  1047.  
  1048.   /* Float-rounding functions. */
  1049.  
  1050. #ifdef LISP_FLOAT_TYPE
  1051.   defsubr (&Sfceiling);
  1052.   defsubr (&Sffloor);
  1053.   defsubr (&Sfround);
  1054.   defsubr (&Sftruncate);
  1055. #endif /* LISP_FLOAT_TYPE */
  1056. }
  1057.  
  1058. void
  1059. vars_of_floatfns (void)
  1060. {
  1061. #ifdef LISP_FLOAT_TYPE
  1062.   Fprovide (intern ("lisp-float-type"));
  1063. #endif
  1064. }
  1065.