From b52711cac8fca57b9f10ea8c6746069cca608dd1 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Sat, 3 Jun 2017 16:49:09 +0900
Subject: [PATCH] adding (srfi 144)

---
 Makefile                |   6 +-
 lib/srfi/144.sld        |  53 ++++++++++++++
 lib/srfi/144/flonum.scm |  47 +++++++++++++
 lib/srfi/144/math.stub  | 151 ++++++++++++++++++++++++++++++++++++++++
 lib/srfi/144/test.sld   |  97 ++++++++++++++++++++++++++
 5 files changed, 352 insertions(+), 2 deletions(-)
 create mode 100644 lib/srfi/144.sld
 create mode 100644 lib/srfi/144/flonum.scm
 create mode 100644 lib/srfi/144/math.stub
 create mode 100644 lib/srfi/144/test.sld

diff --git a/Makefile b/Makefile
index 78e96741..d3b3d09c 100644
--- a/Makefile
+++ b/Makefile
@@ -36,7 +36,7 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
 	$(EXTRA_COMPILED_LIBS) \
 	lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/142/bit$(SO) \
 	lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
-	lib/srfi/98/env$(SO) lib/scheme/time$(SO)
+	lib/srfi/98/env$(SO) lib/srfi/144/math$(SO) lib/scheme/time$(SO)
 
 BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
 INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
@@ -317,7 +317,7 @@ install-base: all
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/io/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/chibi/optimize/
 	$(MKDIR) $(DESTDIR)$(BINMODDIR)/scheme/
-	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/142 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98
+	$(MKDIR) $(DESTDIR)$(BINMODDIR)/srfi/18 $(DESTDIR)$(BINMODDIR)/srfi/27 $(DESTDIR)$(BINMODDIR)/srfi/142 $(DESTDIR)$(BINMODDIR)/srfi/39 $(DESTDIR)$(BINMODDIR)/srfi/69 $(DESTDIR)$(BINMODDIR)/srfi/95 $(DESTDIR)$(BINMODDIR)/srfi/98 $(DESTDIR)$(BINMODDIR)/srfi/144
 	$(INSTALL_EXE) -m0755 $(CHIBI_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/
 	$(INSTALL_EXE) -m0755 $(CHIBI_CRYPTO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/crypto/
 	$(INSTALL_EXE) -m0755 $(CHIBI_IO_COMPILED_LIBS) $(DESTDIR)$(BINMODDIR)/chibi/io/
@@ -330,6 +330,7 @@ install-base: all
 	$(INSTALL_EXE) -m0755 lib/srfi/95/qsort$(SO) $(DESTDIR)$(BINMODDIR)/srfi/95
 	$(INSTALL_EXE) -m0755 lib/srfi/98/env$(SO) $(DESTDIR)$(BINMODDIR)/srfi/98
 	$(INSTALL_EXE) -m0755 lib/srfi/142/bit$(SO) $(DESTDIR)$(BINMODDIR)/srfi/142
+	$(INSTALL_EXE) -m0755 lib/srfi/144/math$(SO) $(DESTDIR)$(BINMODDIR)/srfi/144
 	$(MKDIR) $(DESTDIR)$(INCDIR)
 	$(INSTALL) -m0644 $(INCLUDES) $(DESTDIR)$(INCDIR)/
 	$(MKDIR) $(DESTDIR)$(LIBDIR)
@@ -403,6 +404,7 @@ uninstall:
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99/records $(DESTDIR)$(BINMODDIR)/srfi/99/records
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(BINMODDIR)/srfi/99
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/142 $(DESTDIR)$(BINMODDIR)/srfi/142
+	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi/144 $(DESTDIR)$(BINMODDIR)/srfi/144
 	-$(RMDIR) $(DESTDIR)$(MODDIR)/srfi $(DESTDIR)$(BINMODDIR)/srfi
 	-$(RMDIR) $(DESTDIR)$(MODDIR) $(DESTDIR)$(BINMODDIR)
 	-$(RM) $(DESTDIR)$(MANDIR)/chibi-scheme.1 $(DESTDIR)$(MANDIR)/chibi-ffi.1 $(DESTDIR)$(MANDIR)/chibi-doc.1
diff --git a/lib/srfi/144.sld b/lib/srfi/144.sld
new file mode 100644
index 00000000..ece6a034
--- /dev/null
+++ b/lib/srfi/144.sld
@@ -0,0 +1,53 @@
+(define-library (srfi 144)
+  (import (chibi)
+          (rename (srfi 141)
+                  (floor/ flfloor/)
+                  (floor-quotient flfloor-quotient)
+                  (floor-remainder flfloor-remainder)
+                  (ceiling/ flceiling/)
+                  (ceiling-quotient flceiling-quotient)
+                  (ceiling-remainder flceiling-remainder)
+                  (truncate/ fltruncate/)
+                  (truncate-quotient fltruncate-quotient)
+                  (truncate-remainder fltruncate-remainder)
+                  (round/ flround/)
+                  (round-quotient flround-quotient)
+                  (round-remainder flround-remainder)
+                  (euclidean/ fleuclidean/)
+                  (euclidean-quotient fleuclidean-quotient)
+                  (euclidean-remainder fleuclidean-remainder)
+                  (balanced/ flbalanced/)
+                  (balanced-quotient flbalanced-quotient)
+                  (balanced-remainder flbalanced-remainder)))
+  (export
+   fl-e fl-e-2 fl-log2-e fl-log10-e fl-log-2 fl-log-10 fl-pi
+   fl-1/pi fl-2/pi fl-pi/2 fl-pi/4 fl-sqrt-pi fl-2/sqrt-pi
+   fl-sqrt-2 fl-sqrt-3 fl-sqrt-5 fl-sqrt-10 fl-1/sqrt-2
+   fl-cbrt-2 fl-cbrt-3 fl-4thrt-2 fl-phi fl-log-phi fl-1/log-phi
+   fl-euler fl-e-euler fl-sin-1 fl-cos-1 fl-greatest fl-least
+   fl-integer-exponent-zero fl-integer-exponent-nan fl-fast-+*
+
+   flonum? fl= fl< fl> fl<= fl>= flodd? fleven?
+   flunordered? flinteger? flzero? flpositive? flnegative?
+
+   fl+ fl- fl* fl/ fl+* flmax flmin flabsdiff
+   flnumerator fldenominator
+
+   fladjacent flcopysign flsgn make-flonum flinteger-fraction
+   flexponent flinteger-exponent flnormalized-fraction-exponent
+   sign-bit flfinite? flinfinite? flnan? flnormalized? fldenormalized?
+   flabs flposdiff flfloor flceiling flround fltruncate
+
+   flexp flexp2 flexp-1 flsquare flsqrt flcbrt flhypot flexpt fllog fllog1+
+   fllog2 fllog10 flsin flcos fltan flasin flacos flatan
+   flsinh flcosh fltanh flasinh flacosh flatanh flremquo
+   flgamma flloggamma flfirst-bessel flsecond-bessel flerf flerfc
+
+   flfloor/ flfloor-quotient flfloor-remainder
+   flceiling/ flceiling-quotient flceiling-remainder
+   fltruncate/ fltruncate-quotient fltruncate-remainder
+   flround/ flround-quotient flround-remainder
+   fleuclidean/ fleuclidean-quotient fleuclidean-remainder
+   flbalanced/ flbalanced-quotient flbalanced-remainder)
+  (include-shared "144/math")
+  (include "144/flonum.scm"))
diff --git a/lib/srfi/144/flonum.scm b/lib/srfi/144/flonum.scm
new file mode 100644
index 00000000..7ac1f8ed
--- /dev/null
+++ b/lib/srfi/144/flonum.scm
@@ -0,0 +1,47 @@
+
+(define fl= =)
+(define fl< <)
+(define fl> >)
+(define fl<= <=)
+(define fl>= >=)
+(define flodd? odd?)
+(define fleven? even?)
+(define (flunordered? x y) (or (flnan? x) (flnan? y)))
+(define flinteger? integer?)
+(define flzero? zero?)
+(define flpositive? positive?)
+(define flnegative? negative?)
+
+(define fl+ +)
+(define fl- -)
+(define fl* *)
+(define fl/ /)
+(define flmax max)
+(define flmin min)
+(define (flabsdiff x y) (abs (- x y)))
+(define flnumerator numerator)
+(define fldenominator denominator)
+
+(define (flsquare x) (fl* x x))
+
+(define (flsgn x) (flcopysign 1.0 x))
+
+(define (fldenormalized? x)
+  (eqv? FP_SUBNORMAL (fpclassify x)))
+
+(define (flatan x . o)
+  (if (pair? o)
+      (flatan2 x (car o))
+      (flatan1 x)))
+
+(define (flinteger-fraction x)
+  (let ((ls (modf x))) (values (cadr ls) (car ls))))
+
+(define (flnormalized-fraction-exponent x)
+  (apply values (frexp x)))
+
+(define (flremquo x y)
+  (apply values (remquo x y)))
+
+(define (flloggamma x)
+  (apply values (lgamma_r x)))
diff --git a/lib/srfi/144/math.stub b/lib/srfi/144/math.stub
new file mode 100644
index 00000000..6660a995
--- /dev/null
+++ b/lib/srfi/144/math.stub
@@ -0,0 +1,151 @@
+
+(c-system-include "math.h")
+
+(define-c-const double
+  (fl-e "M_E")
+  (fl-e-2 "logb(2.0)")
+  (fl-log2-e "M_LOG2E")
+  (fl-log10-e "M_LOG10E")
+  (fl-log-2 "M_LN2")
+  (fl-log-10 "M_LN10")
+  (fl-pi "M_PI")
+  (fl-1/pi "M_1_PI")
+  (fl-2/pi "M_2_PI")
+  (fl-pi/2 "M_PI/2")
+  (fl-pi/4 "M_PI/4")
+  (fl-sqrt-pi "sqrt(M_PI)")
+  (fl-2/sqrt-pi "M_2_SQRTPI")
+  (fl-sqrt-2 "M_SQRT2")
+  (fl-sqrt-3 "sqrt(3.0)")
+  (fl-sqrt-5 "sqrt(5.0)")
+  (fl-sqrt-10 "sqrt(10.0)")
+  (fl-1/sqrt-2 "M_SQRT1_2")
+  (fl-cbrt-2 "cbrt(2.0)")
+  (fl-cbrt-3 "cbrt(3.0)")
+  (fl-4thrt-2 "pow(2.0, 0.25)")
+  (fl-phi "(1.0+sqrt(5.0))/2.0")
+  (fl-log-phi "log((1.0+sqrt(5.0))/2.0)")
+  (fl-1/log-phi "1.0/log((1.0+sqrt(5.0))/2.0)")
+  (fl-euler "0.57721566490153286060651209008240243")
+  (fl-e-euler "exp(0.57721566490153286060651209008240243)")
+  (fl-sin-1 "sin(1.0)")
+  (fl-cos-1 "cos(1.0)")
+  (fl-greatest "DBL_MAX")
+  (fl-least "-DBL_MAX")
+  (fl-integer-exponent-zero "FP_ILOGB0")
+  (fl-integer-exponent-nan "FP_ILOGBNAN"))
+
+(define-c-const int
+  FP_SUBNORMAL)
+
+(c-declare
+ "#ifndef FP_FAST_FMA
+#define FP_FAST_FMA 0
+#endif")
+
+(define-c-const boolean
+  (fl-fast-+* FP_FAST_FMA))
+
+(define-c double (fl+* "fma") (double double double))
+
+;; These aren't any faster than the builtin ops.  It might be
+;; interesting to provide these as a way to get flonum support when
+;; Chibi is compiled without flonums, but we'd want for a little extra
+;; support in this case in the FFI and extending the core read/write.
+;;
+;; (c-declare
+;;  "#define fladd(x, y) ((x)+(y))
+;; #define flsub(x, y) ((x)-(y))
+;; #define flmul(x, y) ((x)*(y))
+;; #define fldiv(x, y) ((x)/(y))
+;; #define flneg(x) (-(x))
+;; #define flrecip(x) (1.0/(x))
+;; #define fleq(x, y) ((x)==(y))
+;; #define fllt(x, y) ((x)<(y))
+;; #define flle(x, y) ((x)<=(y))
+;; #define flgt(x, y) ((x)>(y))
+;; #define flge(x, y) ((x)>=(y))
+;; #define flmax(x, y) ((x)<(y)?(y):(x))
+;; #define flmin(x, y) ((x)>(y)?(y):(x))
+;; ")
+;; (define-c double (fl+ "fladd") (double double))
+;; (define-c double (fl- "flsub") (double double))
+;; (define-c double (fl* "flmul") (double double))
+;; (define-c double (fl/ "fldiv") (double double))
+;; (define-c double flneg (double))
+;; (define-c double flrecip (double))
+;; (define-c boolean (fl= "fleq") (double double))
+;; (define-c boolean (fl< "fllt") (double double))
+;; (define-c boolean (fl<= "flle") (double double))
+;; (define-c boolean (fl> "flgt") (double double))
+;; (define-c boolean (fl>= "flge") (double double))
+;; (define-c double flmax (double double))
+;; (define-c double flmin (double double))
+
+(define-c double (fladjacent "nextafter") (double double))
+
+(define-c double (flcopysign "copysign") (double double))
+
+(define-c double (make-flonum "ldexp") (double int))
+
+(define-c double modf (double (result double)))
+
+(define-c double (flexponent "logb") (double))
+
+(define-c int (flinteger-exponent "ilogb") (double))
+
+(define-c double frexp (double (result int)))
+
+(define-c int (sign-bit "signbit") (double))
+
+(define-c boolean (flfinite? "isfinite") (double))
+(define-c boolean (flinfinite? "isinf") (double))
+(define-c boolean (flnan? "isnan") (double))
+(define-c boolean (flnormalized? "isnormal") (double))
+
+(define-c int fpclassify (double))
+
+(define-c double (flabs "fabs") (double))
+(define-c double (flposdiff "fdim") (double double))
+(define-c double (flfloor "floor") (double))
+(define-c double (flceiling "ceil") (double))
+(define-c double (flround "round") (double))
+(define-c double (fltruncate "trunc") (double))
+
+(define-c double (flexp "exp") (double))
+(define-c double (flexp2 "exp2") (double))
+(define-c double (flexp-1 "expm1") (double))
+(define-c double (flsqrt "sqrt") (double))
+(define-c double (flcbrt "cbrt") (double))
+(define-c double (flhypot "hypot") (double double))
+(define-c double (flexpt "pow") (double double))
+(define-c double (fllog "log") (double))
+(define-c double (fllog1+ "log1p") (double))
+(define-c double (fllog2 "log2") (double))
+(define-c double (fllog10 "log10") (double))
+
+(define-c double (flsin "sin") (double))
+(define-c double (flcos "cos") (double))
+(define-c double (fltan "tan") (double))
+(define-c double (flasin "asin") (double))
+(define-c double (flacos "acos") (double))
+(define-c double (flatan1 "atan") (double))
+(define-c double (flatan2 "atan2") (double double))
+
+(define-c double (flsinh "sinh") (double))
+(define-c double (flcosh "cosh") (double))
+(define-c double (fltanh "tanh") (double))
+(define-c double (flasinh "asinh") (double))
+(define-c double (flacosh "acosh") (double))
+(define-c double (flatanh "atanh") (double))
+
+(define-c double remquo (double double (result int)))
+
+(define-c double (flgamma "tgamma") (double))
+(define-c double lgamma_r (double (result int)))
+
+(define-c double (flfirst-bessel "jn") (double int))
+(define-c double (flsecond-bessel "yn") (double int))
+
+(define-c double (flerf "erf") (double))
+(define-c double (flerfc "erfc") (double))
diff --git a/lib/srfi/144/test.sld b/lib/srfi/144/test.sld
new file mode 100644
index 00000000..cf2fb5eb
--- /dev/null
+++ b/lib/srfi/144/test.sld
@@ -0,0 +1,97 @@
+(define-library (srfi 144 test)
+  (import (scheme base) (chibi test) (srfi 144))
+  (export run-tests)
+  (begin
+    ;; note default (current-test-epsilon) for (chibi test) test is 1e-5
+    (define (run-tests)
+      (test-begin "srfi-144: flonums")
+      (test 5. (fl+ 2. 3.))
+      (test -1. (fl- 2. 3.))
+      (test 6. (fl* 2. 3.))
+      (test 0.6666666666 (fl/ 2. 3.))
+      (test 10. (fl+* 2. 3. 4.))
+      (test 0. (fladjacent -0. 1.))
+      (test -0. (flcopysign 0. -1.))
+      (test 3. (make-flonum 3. 0))
+      (test 6. (make-flonum 3. 1))
+      (test 3072. (make-flonum 3. 10))
+      (call-with-values (lambda () (flinteger-fraction 12.345))
+        (lambda (int frac)
+          (test 12. int)
+          (test .345 frac)))
+      (test 0. (flexponent 1.))
+      (test 255. (flexponent 1e77))
+      (test 255 (flinteger-exponent 1e77))
+      (test 0 (sign-bit 0.))
+      (test 0 (sign-bit 1.))
+      (test 0 (sign-bit +inf.0))
+      (test 1 (sign-bit -0.))
+      (test 1 (sign-bit -1.))
+      (test 1 (sign-bit -inf.0))
+      (test-not (flunordered? 0. 1.))
+      (test-not (flunordered? 0. -inf.0))
+      (test-assert (flunordered? +nan.0 0.))
+      (test-assert (flunordered? 0. +nan.0))
+      (test-assert (flinteger? 42.))
+      (test-not (flinteger? 42.1))
+      (test-assert (flzero? -0.))
+      (test-assert (flzero? 0.))
+      (test-not (flzero? 0.1))
+      (test-not (flzero? +nan.0))
+      (test-assert (flpositive? 1.))
+      (test-assert (flpositive? +inf.0))
+      (test-not (flpositive? -1.))
+      (test-assert (flnegative? -1.))
+      (test-assert (flnegative? -inf.0))
+      (test-not (flnegative? 1.))
+      (test-assert (flodd? 1.))
+      (test-not (flodd? 2.))
+      (test-not (fleven? 3.))
+      (test-assert (fleven? 4.))
+      (test-assert (flfinite? 5.))
+      (test-assert (flinfinite? -inf.0))
+      (test-assert (flnan? +nan.0))
+      (test-assert (flnormalized? 1.))
+      (test-assert (fldenormalized? (fladjacent 0. +inf.0)))
+      (test 1. (flabsdiff 2. 3.))
+      (test 1. (flabsdiff 3. 2.))
+      (test 0. (flposdiff 2. 3.))
+      (test 1. (flsgn 0.))
+      (test -1. (flsgn -0.))
+      (test 1. (flexp 0.))
+      (test 2.718281828 (flexp 1.))
+      (test 8. (flexp2 3.))
+      (test 1.718281828 (flexp-1 1.))
+      (test 9. (flsquare 3.))
+      (test 1.414213562 (flsqrt 2.))
+      (test 1.259921050 (flcbrt 2.))
+      (test 5. (flhypot 3. 4.))
+      (test 81. (flexpt 3. 4.))
+      (test 1.098612289 (fllog 3.))
+      (test 0.693147186 (fllog1+ 1.))
+      (test 2.807354922 (fllog2 7.))
+      (test 10. (fllog2 1024.))
+      (test 3.010299957 (fllog10 1024.))
+      (test 0.841470985 (flsin 1.))
+      (test 0.540302306 (flcos -1.))
+      (test 1.557407725 (fltan 1.))
+      (test 1.570796327 (flasin 1.))
+      (test fl-pi (flacos -1.))
+      (test 0.785398163 (flatan 1.))
+      (test 0.463647609 (flatan 1. 2.))
+      (test 1.175201194 (flsinh 1.))
+      (test 1.543080635 (flcosh -1.))
+      (test 0.761594156 (fltanh 1.))
+      (test 0.881373587 (flasinh 1.))
+      (test 0. (flacosh 1.))
+      (test +inf.0 (flatanh 1.))
+      (test 24. (flgamma 5.))
+      (call-with-values (lambda () (flloggamma 0.1))
+        (lambda (res sign)
+          (test 64. res)
+          (test 1 sign)))
+      (test 0.440050586 (flfirst-bessel 1. 1))
+      (test -0.781212821 (flsecond-bessel 1. 1))
+      (test 0.842700793 (flerf 1.))
+      (test 0.157299207 (flerfc 1.))
+      (test-end))))