Add various math/float functions whose absence was getting in my way.

New functions:

- flo:copysign          copy sign from one value to another
- flo:nextafter         next representable floating-point number
- flo:sinh              hyperbolic trig
- flo:cosh
- flo:tanh
- flo:asinh             hyperbolic inverse trig
- flo:acosh
- flo:atanh
- flo:cbrt              cube root
- flo:erf               error function: 2/sqrt(pi) \int_0^x e^{-t^2} dt
- flo:erfc              complement: 1 - erf(x)
- flo:gamma             Gamma function: \int_0^\infty t^{x-1} e^{-t} dt
- flo:hypot             Euclidean distance: sqrt(x^2 + y^2)
- flo:j0                Bessel function of first kind, order 0
- flo:j1                "      "        "  "     "     "     1
- flo:jn                "      "        "  "     "     "     n
- flo:y0                Bessel function of second kind, order 0
- flo:y1                "      "        "  "      "     "     1
- flo:yn                "      "        "  "      "     "     n

These are all in C99 and POSIX.  For beta, incomplete Gamma, and
other such common critters, we'll have to do it ourselves.

XXX Need automatic tests.

diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac
index c7f4b0b13d3d914c22e044d5346bcfa279bb884e..7a72286ced5085f719f73152da122fb063f563aa 100644 (file)
--- a/src/microcode/configure.ac
+++ b/src/microcode/configure.ac
@@ -728,7 +728,7 @@ AC_CHECK_FUNCS([fpsetround frexp fsync fsync_range ftruncate])
 AC_CHECK_FUNCS([getcwd gethostbyname gethostname getlogin getpagesize getpgrp])
 AC_CHECK_FUNCS([getpt gettimeofday getwd grantpt])
 AC_CHECK_FUNCS([kill])
-AC_CHECK_FUNCS([lockf log1p])
+AC_CHECK_FUNCS([lgamma_r lockf log1p])
 AC_CHECK_FUNCS([madvise memcpy mkdir mktime modf])
 AC_CHECK_FUNCS([nice ntp_adjtime ntp_gettime])
 AC_CHECK_FUNCS([openpty])

diff --git a/src/microcode/flonum.c b/src/microcode/flonum.c
index 658be3b147a937b38acf647c46fea09823b66f05..a9eee3abfb9bb68a11fd5488ac93cc0739620d30 100644 (file)
--- a/src/microcode/flonum.c
+++ b/src/microcode/flonum.c
@@ -205,6 +205,20 @@ DEFINE_PRIMITIVE ("FLONUM-LOG", Prim_flonum_log, 1, 1, 0)
 
 DEFINE_PRIMITIVE ("FLONUM-EXP", Prim_flonum_exp, 1, 1, 0)
      SIMPLE_TRANSCENDENTAL_FUNCTION (exp)
+\f
+DEFINE_PRIMITIVE ("FLONUM-SINH", Prim_flonum_sinh, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (sinh)
+DEFINE_PRIMITIVE ("FLONUM-COSH", Prim_flonum_cosh, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (cosh)
+DEFINE_PRIMITIVE ("FLONUM-TANH", Prim_flonum_tanh, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (tanh)
+DEFINE_PRIMITIVE ("FLONUM-ASINH", Prim_flonum_asinh, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (asinh)
+DEFINE_PRIMITIVE ("FLONUM-ACOSH", Prim_flonum_acosh, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (acosh)
+DEFINE_PRIMITIVE ("FLONUM-ATANH", Prim_flonum_atanh, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (atanh)
+
 DEFINE_PRIMITIVE ("FLONUM-SIN", Prim_flonum_sin, 1, 1, 0)
      SIMPLE_TRANSCENDENTAL_FUNCTION (sin)
 DEFINE_PRIMITIVE ("FLONUM-COS", Prim_flonum_cos, 1, 1, 0)
@@ -232,6 +246,14 @@ DEFINE_PRIMITIVE ("FLONUM-ATAN2", Prim_flonum_atan2, 2, 2, 0)
 
 DEFINE_PRIMITIVE ("FLONUM-SQRT", Prim_flonum_sqrt, 1, 1, 0)
      RESTRICTED_TRANSCENDENTAL_FUNCTION (sqrt, (x >= 0))
+DEFINE_PRIMITIVE ("FLONUM-CBRT", Prim_flonum_cbrt, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (cbrt)
+
+DEFINE_PRIMITIVE ("FLONUM-HYPOT", Prim_flonum_hypot, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  FLONUM_RESULT (hypot ((arg_flonum (1)), (arg_flonum (2))));
+}
 
 DEFINE_PRIMITIVE ("FLONUM-EXPT", Prim_flonum_expt, 2, 2, 0)
 {
@@ -239,6 +261,67 @@ DEFINE_PRIMITIVE ("FLONUM-EXPT", Prim_flonum_expt, 2, 2, 0)
   FLONUM_RESULT (pow ((arg_flonum (1)), (arg_flonum (2))));
 }
 \f
+/* (Complete) Gamma and error functions */
+
+DEFINE_PRIMITIVE ("FLONUM-LGAMMA", Prim_flonum_lgamma, 1, 1, 0)
+{
+  double x;
+  double result;
+  PRIMITIVE_HEADER (1);
+
+  x = (arg_flonum (1));
+  errno = 0;
+#ifdef HAVE_LGAMMA_R
+  {
+    int sign;
+    result = (lgamma_r (x, (&sign)));
+  }
+#else
+  result = (lgamma (x));
+#endif
+  if (errno != 0)
+    error_bad_range_arg (1);
+  FLONUM_RESULT (result);
+}
+
+DEFINE_PRIMITIVE ("FLONUM-GAMMA", Prim_flonum_gamma, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (tgamma)
+DEFINE_PRIMITIVE ("FLONUM-ERF", Prim_flonum_erf, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (erf)
+DEFINE_PRIMITIVE ("FLONUM-ERFC", Prim_flonum_erfc, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (erfc)
+
+/* Bessel functions of the first (j*) and second (y*) kind */
+
+DEFINE_PRIMITIVE ("FLONUM-J0", Prim_flonum_j0, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (j0)
+DEFINE_PRIMITIVE ("FLONUM-J1", Prim_flonum_j1, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (j1)
+DEFINE_PRIMITIVE ("FLONUM-Y0", Prim_flonum_y0, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (y0)
+DEFINE_PRIMITIVE ("FLONUM-Y1", Prim_flonum_y1, 1, 1, 0)
+     SIMPLE_TRANSCENDENTAL_FUNCTION (y1)
+
+DEFINE_PRIMITIVE ("FLONUM-JN", Prim_flonum_jn, 2, 2, 0)
+{
+  int n;
+  double x;
+  PRIMITIVE_HEADER (2);
+  n = (arg_integer_in_range (1, INT_MIN, INT_MAX));
+  x = (arg_flonum (2));
+  FLONUM_RESULT (jn (n, x));
+}
+
+DEFINE_PRIMITIVE ("FLONUM-YN", Prim_flonum_yn, 2, 2, 0)
+{
+  int n;
+  double x;
+  PRIMITIVE_HEADER (2);
+  n = (arg_integer_in_range (1, INT_MIN, INT_MAX));
+  x = (arg_flonum (2));
+  FLONUM_RESULT (yn (n, x));
+}
+\f
 DEFINE_PRIMITIVE ("FLONUM?", Prim_flonum_p, 1, 1, 0)
 {
   PRIMITIVE_HEADER (1);
@@ -392,3 +475,25 @@ DEFINE_PRIMITIVE ("CAST-INTEGER-TO-IEEE754-SINGLE", Prim_cast_integer_to_ieee754
     PRIMITIVE_RETURN (double_to_flonum ((double) cast.f));
   }
 }
+\f
+/* Miscellaneous floating-point operations */
+
+DEFINE_PRIMITIVE ("FLONUM-COPYSIGN", Prim_flonum_copysign, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  {
+    double magnitude = (arg_flonum (1));
+    double sign = (arg_flonum (2));
+    FLONUM_RESULT (copysign (magnitude, sign));
+  }
+}
+
+DEFINE_PRIMITIVE ("FLONUM-NEXTAFTER", Prim_flonum_nextafter, 2, 2, 0)
+{
+  PRIMITIVE_HEADER (2);
+  {
+    double x = (arg_flonum (1));
+    double direction = (arg_flonum (2));
+    FLONUM_RESULT (nextafter (x, direction));
+  }
+}

diff --git a/src/runtime/fixart.scm b/src/runtime/fixart.scm
index f3ce4a96e811173a9ee43107e9a6ceae38996ef6..63818f1c174c2a3a85b606b3b4548b681079a735 100644 (file)
--- a/src/runtime/fixart.scm
+++ b/src/runtime/fixart.scm
@@ -93,12 +93,30 @@ USA.
   (flo:sin flonum-sin 1)
   (flo:cos flonum-cos 1)
   (flo:tan flonum-tan 1)
+  (flo:sinh flonum-sinh 1)
+  (flo:cosh flonum-cosh 1)
+  (flo:tanh flonum-tanh 1)
   (flo:asin flonum-asin 1)
   (flo:acos flonum-acos 1)
   (flo:atan flonum-atan 1)
+  (flo:asinh flonum-asinh 1)
+  (flo:acosh flonum-acosh 1)
+  (flo:atanh flonum-atanh 1)
   (flo:atan2 flonum-atan2 2)
   (flo:sqrt flonum-sqrt 1)
+  (flo:cbrt flonum-cbrt 1)
+  (flo:hypot flonum-hypot 2)
   (flo:expt flonum-expt 2)
+  (flo:lgamma flonum-lgamma 1)
+  (flo:gamma flonum-gamma 1)
+  (flo:erf flonum-erf 1)
+  (flo:erfc flonum-erfc 1)
+  (flo:j0 flonum-j0 1)
+  (flo:j1 flonum-j1 1)
+  (flo:jn flonum-jn 2)
+  (flo:y0 flonum-y0 1)
+  (flo:y1 flonum-y1 1)
+  (flo:yn flonum-yn 2)
   (flo:floor flonum-floor 1)
   (flo:ceiling flonum-ceiling 1)
   (flo:truncate flonum-truncate 1)
@@ -107,6 +125,8 @@ USA.
   (flo:ceiling->exact flonum-ceiling->exact 1)
   (flo:truncate->exact flonum-truncate->exact 1)
   (flo:round->exact flonum-round->exact 1)
+  (flo:copysign flonum-copysign 2)
+  (flo:nextafter flonum-nextafter 2)
   (flo:vector-cons floating-vector-cons 1)
   (flo:vector-length floating-vector-length 1)
   (flo:vector-ref floating-vector-ref 2)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 1b97debfdf22e77c6940ebda6949edd120da0271..e13a7c9ff0b7ac6d465bdd273844b14707c4b62e 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -221,13 +221,21 @@ USA.
          flo:>=
          flo:abs
          flo:acos
+         flo:acosh
          flo:asin
+         flo:asinh
          flo:atan
          flo:atan2
+         flo:atanh
+         flo:cbrt
          flo:ceiling
          flo:ceiling->exact
+         flo:copysign
          flo:cos
+         flo:cosh
          flo:eqv?
+         flo:erf
+         flo:erfc
          flo:exp
          flo:expm1
          flo:expt
@@ -235,6 +243,12 @@ USA.
          flo:flonum?
          flo:floor
          flo:floor->exact
+         flo:gamma
+         flo:hypot
+         flo:j0
+         flo:j1
+         flo:jn
+         flo:lgamma
          flo:log
          flo:log1p
          flo:max
@@ -242,18 +256,24 @@ USA.
          flo:modulo
          flo:negate
          flo:negative?
+         flo:nextafter
          flo:positive?
          flo:round
          flo:round->exact
          flo:sin
+         flo:sinh
          flo:sqrt
          flo:tan
+         flo:tanh
          flo:truncate
          flo:truncate->exact
          flo:vector-cons
          flo:vector-length
          flo:vector-ref
          flo:vector-set!
+         flo:y0
+         flo:y1
+         flo:yn
          flo:zero?
          guarantee-fixnum
          guarantee-index-fixnum