~ chicken-core (chicken-5) aa16d98745c6e51436272f2bc2d1554a7ca46403
commit aa16d98745c6e51436272f2bc2d1554a7ca46403
Author: Christian Himpe <christian.himpe@wwu.de>
AuthorDate: Mon Jun 5 20:05:21 2023 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sat Jun 10 13:54:26 2023 +0200
Added hyperbolic and inverse hyperbolic functions in c-std lib: sinh, cosh, tanh, asinh, acosh, atanh
Also modified old r/t C_a_i_... trigonometric functions to
actually use aliases for libc math functions introduced in
chicken.h.
Signed-off-by: felix <felix@call-with-current-continuation.org>
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index c181866f..d0293b1d 100644
--- a/NEWS
+++ b/NEWS
@@ -14,6 +14,8 @@
- Added "locative-index", kindly contributed by John Croisant.
- Added "fp*+" (fused multiply-add) to "chicken.flonum" module
(suggested by Christian Himpe).
+ - Added flonum-specific hyperbolic functions and their inverse to
+ "chicken.flonum" module (suggested by Christian Himpe).
- The `process-execute` procedure now sets argv[0] to the unmodified
filename. Previously, the directory part would be stripped.
diff --git a/chicken.h b/chicken.h
index 928066ed..6461241d 100644
--- a/chicken.h
+++ b/chicken.h
@@ -966,6 +966,12 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# define C_asin asin
# define C_acos acos
# define C_atan atan
+# define C_sinh sinh
+# define C_cosh cosh
+# define C_tanh tanh
+# define C_asinh asinh
+# define C_acosh acosh
+# define C_atanh atanh
# define C_atan2 atan2
# define C_log log
# define C_exp exp
@@ -1629,6 +1635,12 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_a_i_flonum_acos(ptr, c, x) C_flonum(ptr, C_acos(C_flonum_magnitude(x)))
#define C_a_i_flonum_atan(ptr, c, x) C_flonum(ptr, C_atan(C_flonum_magnitude(x)))
#define C_a_i_flonum_atan2(ptr, c, x, y) C_flonum(ptr, C_atan2(C_flonum_magnitude(x), C_flonum_magnitude(y)))
+#define C_a_i_flonum_sinh(ptr, c, x) C_flonum(ptr, C_sinh(C_flonum_magnitude(x)))
+#define C_a_i_flonum_cosh(ptr, c, x) C_flonum(ptr, C_cosh(C_flonum_magnitude(x)))
+#define C_a_i_flonum_tanh(ptr, c, x) C_flonum(ptr, C_tanh(C_flonum_magnitude(x)))
+#define C_a_i_flonum_asinh(ptr, c, x) C_flonum(ptr, C_asinh(C_flonum_magnitude(x)))
+#define C_a_i_flonum_acosh(ptr, c, x) C_flonum(ptr, C_acosh(C_flonum_magnitude(x)))
+#define C_a_i_flonum_atanh(ptr, c, x) C_flonum(ptr, C_atanh(C_flonum_magnitude(x)))
#define C_a_i_flonum_exp(ptr, c, x) C_flonum(ptr, C_exp(C_flonum_magnitude(x)))
#define C_a_i_flonum_expt(ptr, c, x, y) C_flonum(ptr, C_pow(C_flonum_magnitude(x), C_flonum_magnitude(y)))
#define C_a_i_flonum_log(ptr, c, x) C_flonum(ptr, C_log(C_flonum_magnitude(x)))
@@ -2074,6 +2086,12 @@ C_fctexport C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_sinh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_cosh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_tanh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_asinh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_acosh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_atanh(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_plus(C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_i_o_fixnum_difference(C_word x, C_word y) C_regparm;
diff --git a/lfa2.scm b/lfa2.scm
index 38ed4da2..e47f1a23 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -167,12 +167,16 @@
("C_a_i_bignum2" bignum)
("C_a_i_flonum_abs" float)
("C_a_i_flonum_acos" float)
+ ("C_a_i_flonum_acosh" float)
("C_a_i_flonum_actual_quotient_checked" float)
("C_a_i_flonum_asin" float)
+ ("C_a_i_flonum_asinh" float)
("C_a_i_flonum_atan2" float)
("C_a_i_flonum_atan" float)
+ ("C_a_i_flonum_atanh" float)
("C_a_i_flonum_ceiling" float)
("C_a_i_flonum_cos" float)
+ ("C_a_i_flonum_cosh" float)
("C_a_i_flonum_difference" float)
("C_a_i_flonum_exp" float)
("C_a_i_flonum_expt" float)
@@ -188,8 +192,10 @@
("C_a_i_flonum_round" float)
("C_a_i_flonum_round_proper" float)
("C_a_i_flonum_sin" float)
+ ("C_a_i_flonum_sinh" float)
("C_a_i_flonum_sqrt" float)
("C_a_i_flonum_tan" float)
+ ("C_a_i_flonum_tanh" float)
("C_a_i_flonum_times" float)
("C_a_i_flonum_multiply_add" float)
("C_a_i_flonum_truncate" float)
@@ -219,6 +225,12 @@
("C_a_i_flonum_acos" "C_acos" op)
("C_a_i_flonum_atan" "C_atan" op)
("C_a_i_flonum_atan2" "C_atan2" op)
+ ("C_a_i_flonum_sinh" "C_sinh" op)
+ ("C_a_i_flonum_cosh" "C_cosh" op)
+ ("C_a_i_flonum_tanh" "C_tanh" op)
+ ("C_a_i_flonum_asinh" "C_asinh" op)
+ ("C_a_i_flonum_acosh" "C_acosh" op)
+ ("C_a_i_flonum_atanh" "C_atanh" op)
("C_a_i_flonum_exp" "C_exp" op)
("C_a_i_flonum_expr" "C_pow" op)
("C_a_i_flonum_log" "C_log" op)
diff --git a/library.scm b/library.scm
index 819dacfe..04445321 100644
--- a/library.scm
+++ b/library.scm
@@ -1680,6 +1680,30 @@ EOF
(fp-check-flonums x y 'fpatan2)
(##core#inline_allocate ("C_a_i_flonum_atan2" 4) x y))
+(define (fpsinh x)
+ (fp-check-flonum x 'fpsinh)
+ (##core#inline_allocate ("C_a_i_flonum_sinh" 4) x))
+
+(define (fpcosh x)
+ (fp-check-flonum x 'fpcosh)
+ (##core#inline_allocate ("C_a_i_flonum_cosh" 4) x))
+
+(define (fptanh x)
+ (fp-check-flonum x 'fptanh)
+ (##core#inline_allocate ("C_a_i_flonum_tanh" 4) x))
+
+(define (fpasinh x)
+ (fp-check-flonum x 'fpasinh)
+ (##core#inline_allocate ("C_a_i_flonum_asinh" 4) x))
+
+(define (fpacosh x)
+ (fp-check-flonum x 'fpacosh)
+ (##core#inline_allocate ("C_a_i_flonum_acosh" 4) x))
+
+(define (fpatanh x)
+ (fp-check-flonum x 'fpatanh)
+ (##core#inline_allocate ("C_a_i_flonum_atanh" 4) x))
+
(define (fpexp x)
(fp-check-flonum x 'fpexp)
(##core#inline_allocate ("C_a_i_flonum_exp" 4) x))
diff --git a/manual/Module (chicken flonum) b/manual/Module (chicken flonum)
index 69aab2fc..b06dcbb6 100644
--- a/manual/Module (chicken flonum)
+++ b/manual/Module (chicken flonum)
@@ -41,6 +41,12 @@ your code.
<procedure>(fpacos X)</procedure>
<procedure>(fpatan X)</procedure>
<procedure>(fpatan2 X Y)</procedure>
+<procedure>(fpsinh X)</procedure>
+<procedure>(fpcosh X)</procedure>
+<procedure>(fptanh X)</procedure>
+<procedure>(fpasinh X)</procedure>
+<procedure>(fpacosh X)</procedure>
+<procedure>(fpatanh X)</procedure>
<procedure>(fplog X)</procedure>
<procedure>(fpexp X)</procedure>
<procedure>(fpexpt X Y)</procedure>
diff --git a/runtime.c b/runtime.c
index ac7f2392..33829210 100644
--- a/runtime.c
+++ b/runtime.c
@@ -6952,7 +6952,7 @@ C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
double f;
C_check_real(n, "exp", f);
- return C_flonum(a, exp(f));
+ return C_flonum(a, C_exp(f));
}
@@ -6961,7 +6961,7 @@ C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
double f;
C_check_real(n, "log", f);
- return C_flonum(a, log(f));
+ return C_flonum(a, C_log(f));
}
@@ -6970,7 +6970,7 @@ C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
double f;
C_check_real(n, "sin", f);
- return C_flonum(a, sin(f));
+ return C_flonum(a, C_sin(f));
}
@@ -6979,7 +6979,7 @@ C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
double f;
C_check_real(n, "cos", f);
- return C_flonum(a, cos(f));
+ return C_flonum(a, C_cos(f));
}
@@ -6988,7 +6988,7 @@ C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
double f;
C_check_real(n, "tan", f);
- return C_flonum(a, tan(f));
+ return C_flonum(a, C_tan(f));
}
@@ -6997,7 +6997,7 @@ C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
double f;
C_check_real(n, "asin", f);
- return C_flonum(a, asin(f));
+ return C_flonum(a, C_asin(f));
}
@@ -7006,7 +7006,7 @@ C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
double f;
C_check_real(n, "acos", f);
- return C_flonum(a, acos(f));
+ return C_flonum(a, C_acos(f));
}
@@ -7015,7 +7015,7 @@ C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
double f;
C_check_real(n, "atan", f);
- return C_flonum(a, atan(f));
+ return C_flonum(a, C_atan(f));
}
@@ -7025,7 +7025,61 @@ C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
C_check_real(n1, "atan", f1);
C_check_real(n2, "atan", f2);
- return C_flonum(a, atan2(f1, f2));
+ return C_flonum(a, C_atan2(f1, f2));
+}
+
+
+C_regparm C_word C_fcall C_a_i_sinh(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "sinh", f);
+ return C_flonum(a, C_sinh(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_cosh(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "cosh", f);
+ return C_flonum(a, C_cosh(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_tanh(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "tanh", f);
+ return C_flonum(a, C_tanh(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_asinh(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "asinh", f);
+ return C_flonum(a, C_asinh(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_acosh(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "acosh", f);
+ return C_flonum(a, C_acosh(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_atanh(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "atanh", f);
+ return C_flonum(a, C_atanh(f));
}
@@ -7034,7 +7088,7 @@ C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
double f;
C_check_real(n, "sqrt", f);
- return C_flonum(a, sqrt(f));
+ return C_flonum(a, C_sqrt(f));
}
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index bb7ae8a2..93e048f7 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -336,6 +336,32 @@
(assert (nan? (fp*+ 0.0 +inf.0 1.0)))
(assert (nan? (fp*+ -inf.0 0.0 1.0)))
+;; Hyperbolic function tests
+
+(assert (fp= (fpsinh -inf.0) -inf.0))
+(assert (fp= (fpsinh 0.0) 0.0))
+(assert (fp= (fpsinh +inf.0) +inf.0))
+
+(assert (fp= (fpcosh -inf.0) +inf.0))
+(assert (fp= (fpcosh 0.0) 1.0))
+(assert (fp= (fpcosh +inf.0) +inf.0))
+
+(assert (fp= (fptanh -inf.0) -1.0))
+(assert (fp= (fptanh 0.0) 0.0))
+(assert (fp= (fptanh +inf.0) 1.0))
+
+(assert (fp= (fpasinh -inf.0) -inf.0))
+(assert (fp= (fpasinh 0.0) 0.0))
+(assert (fp= (fpasinh +inf.0) +inf.0))
+
+(assert (fp= (fpacosh 1.0) 0.0))
+(assert (fp= (fpacosh +inf.0) +inf.0))
+(assert (nan? (fpacosh 0.0)))
+
+(assert (fp= (fpatanh -1.0) -inf.0))
+(assert (fp= (fpatanh 0.0) 0.0))
+(assert (fp= (fpatanh 1.0) +inf.0))
+
;; string->symbol
;; by Jim Ursetto
diff --git a/types.db b/types.db
index acd9d80b..a61cfa72 100644
--- a/types.db
+++ b/types.db
@@ -1216,25 +1216,37 @@
((float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1) )))
(chicken.flonum#fpacos (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpacos (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_acos" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_acos" 4) #(1) )))
+
+(chicken.flonum#fpacosh (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpacosh (float) float)
+ ((float) (##core#inline_allocate ("C_a_i_flonum_acosh" 4) #(1) )))
(chicken.flonum#fpasin (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpasin (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_asin" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_asin" 4) #(1) )))
+
+(chicken.flonum#fpasinh (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpasinh (float) float)
+ ((float) (##core#inline_allocate ("C_a_i_flonum_asinh" 4) #(1) )))
(chicken.flonum#fpatan (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpatan (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_atan" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_atan" 4) #(1) )))
+
+(chicken.flonum#fpatanh (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpatanh (float) float)
+ ((float) (##core#inline_allocate ("C_a_i_flonum_atanh" 4) #(1) )))
(chicken.flonum#fpatan2 (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpatan2 (float float) float)
- ((float float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) #(1) #(2))))
+ ((float float) (##core#inline_allocate ("C_a_i_flonum_atan2" 4) #(1) #(2))))
(chicken.flonum#fpceiling (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpceiling (float) float)
((float) (##core#inline_allocate ("C_a_i_flonum_ceiling" 4) #(1) )))
(chicken.flonum#fpcos (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpcos (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_cos" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_cos" 4) #(1) )))
+
+(chicken.flonum#fpcosh (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpcosh (float) float)
+ ((float) (##core#inline_allocate ("C_a_i_flonum_cosh" 4) #(1) )))
(chicken.flonum#fpexp (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpexp (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_exp" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_exp" 4) #(1) )))
(chicken.flonum#fpexpt (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpexpt (float float) float)
((float float) (##core#inline_allocate ("C_a_i_flonum_expt" 4) #(1) #(2))))
@@ -1261,16 +1273,22 @@
((float) (##core#inline_allocate ("C_a_i_flonum_round" 4) #(1) )))
(chicken.flonum#fpsin (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpsin (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_sin" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_sin" 4) #(1) )))
+
+(chicken.flonum#fpsinh (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpsinh (float) float)
+ ((float) (##core#inline_allocate ("C_a_i_flonum_sinh" 4) #(1) )))
(chicken.flonum#fpsqrt (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fpsqrt (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) #(1) )))
(chicken.flonum#fptan (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fptan (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_tan" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_tan" 4) #(1) )))
+
+(chicken.flonum#fptanh (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fptanh (float) float)
+ ((float) (##core#inline_allocate ("C_a_i_flonum_tanh" 4) #(1) )))
(chicken.flonum#fptruncate (#(procedure #:clean #:enforce #:foldable) chicken.flonum#fptruncate (float) float)
- ((float) (##core#inline_allocate ("C_a_i_flonum_truncate" 4) #(1) )))
+ ((float) (##core#inline_allocate ("C_a_i_flonum_truncate" 4) #(1) )))
;; fixnum
Trap