From 51dc119b39131a06a66c199da85b9ddb292b0cf7 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Mon, 3 Aug 2015 02:53:25 +0000 Subject: [PATCH] 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. --- src/microcode/configure.ac | 2 +- src/microcode/flonum.c | 105 +++++++++++++++++++++++++++++++++++++ src/runtime/fixart.scm | 20 +++++++ src/runtime/runtime.pkg | 20 +++++++ 4 files changed, 146 insertions(+), 1 deletion(-) diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index c7f4b0b13..7a72286ce 100644 --- 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 658be3b14..a9eee3abf 100644 --- 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) + +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)))); } +/* (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)); +} + 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)); } } + +/* 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 f3ce4a96e..63818f1c1 100644 --- 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 1b97debfd..e13a7c9ff 100644 --- 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 -- 2.25.1