Win32: Import Ruby's lgamma_r implementation (Public Domain)

Import Ruby's lgamma_r implementation as MSVCRT missing lgamma_r
implementation. Non Windows platforms should continue to use lgamma_r
implementation which provided with its C runtime library.

lib/srfi/144/lgamma_r.c

@@ -0,0 +1,84 @@
+/* 
+ * Ruby's missing/lgamma_r.c took from
+ * https://github.com/ruby/ruby/commit/39330d6b79c95f67006453156d8405242da04d7b
+ */
+
+/* lgamma_r.c  - public domain implementation of function lgamma_r(3m)
+
+lgamma_r() is based on gamma().  modified by Tanaka Akira.
+
+reference - Haruhiko Okumura: C-gengo niyoru saishin algorithm jiten
+            (New Algorithm handbook in C language) (Gijyutsu hyouron
+            sha, Tokyo, 1991) [in Japanese]
+            http://oku.edu.mie-u.ac.jp/~okumura/algo/
+*/
+
+/***********************************************************
+    gamma.c -- Gamma function
+***********************************************************/
+#include <math.h>
+#include <errno.h>
+#define PI      3.14159265358979324  /* $\pi$ */
+#define LOG_2PI 1.83787706640934548  /* $\log 2\pi$ */
+#define LOG_PI  1.14472988584940017  /* $\log_e \pi$ */
+#define N       8
+
+#define B0  1                 /* Bernoulli numbers */
+#define B1  (-1.0 / 2.0)
+#define B2  ( 1.0 / 6.0)
+#define B4  (-1.0 / 30.0)
+#define B6  ( 1.0 / 42.0)
+#define B8  (-1.0 / 30.0)
+#define B10 ( 5.0 / 66.0)
+#define B12 (-691.0 / 2730.0)
+#define B14 ( 7.0 / 6.0)
+#define B16 (-3617.0 / 510.0)
+
+static double
+loggamma(double x)  /* the natural logarithm of the Gamma function. */
+{
+    double v, w;
+
+    if (x == 1.0 || x == 2.0) return 0.0;
+
+    v = 1;
+    while (x < N) {  v *= x;  x++;  }
+    w = 1 / (x * x);
+    return ((((((((B16 / (16 * 15))  * w + (B14 / (14 * 13))) * w
+                + (B12 / (12 * 11))) * w + (B10 / (10 *  9))) * w
+                + (B8  / ( 8 *  7))) * w + (B6  / ( 6 *  5))) * w
+                + (B4  / ( 4 *  3))) * w + (B2  / ( 2 *  1))) / x
+                + 0.5 * LOG_2PI - log(v) - x + (x - 0.5) * log(x);
+}
+
+
+#ifdef __MINGW_ATTRIB_PURE
+/* get rid of bugs in math.h of mingw */
+#define modf(_X, _Y) __extension__ ({\
+    double intpart_modf_bug = intpart_modf_bug;\
+    double result_modf_bug = modf((_X), &intpart_modf_bug);\
+    *(_Y) = intpart_modf_bug;\
+    result_modf_bug;\
+})
+#endif
+
+/* the natural logarithm of the absolute value of the Gamma function */
+double
+lgamma_r(double x, int *signp)
+{
+    if (x <= 0) {
+        double i, f, s;
+        f = modf(-x, &i);
+        if (f == 0.0) { /* pole error */
+            *signp = signbit(x) ? -1 : 1;
+            errno = ERANGE;
+            return HUGE_VAL;
+        }
+        *signp = (fmod(i, 2.0) != 0.0) ? 1 : -1;
+        s = sin(PI * f);
+        if (s < 0) s = -s;
+        return LOG_PI - log(s) - loggamma(1 - x);
+    }
+    *signp = 1;
+    return loggamma(x);
+}

lib/srfi/144/math.stub

@@ -148,11 +148,8 @@
 (define-c double (flgamma "tgamma") (double))
 (cond-expand
   (windows
-   ;; FIXME: Implement this.
+   (c-include-verbatim "lgamma_r.c")))
-   (c-declare "double lgamma_r(double x, int* sign) { *sign = 9999; __debugbreak(); }")
+(define-c double lgamma_r (double (result int)))
-    (define-c double lgamma_r (double (result int))))
-   (else
-    (define-c double lgamma_r (double (result int)))))
 
 (define-c double (flfirst-bessel "jn") (int double))
 (define-c double (flsecond-bessel "yn") (int double))