include selected functions from GNU-R's arithmetic.c

com.oracle.truffle.r.native/fficall/jni/src/arithmetic.c

+/*
+ * Copyright (c) 2015, 2015, Oracle and/or its affiliates. All rights reserved.
+ * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+ *
+ * This code is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License version 2 only, as
+ * published by the Free Software Foundation.
+ *
+ * This code is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+ * version 2 for more details (a copy is included in the LICENSE file that
+ * accompanied this code).
+ *
+ * You should have received a copy of the GNU General Public License version
+ * 2 along with this work; if not, write to the Free Software Foundation,
+ * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+ *
+ * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+ * or visit www.oracle.com if you need additional information or have any
+ * questions.
+ */
+
+#include "rffiutils.h"
+#include <stdlib.h>
+
+// FastR: selected functions from arithmetic.c:
+
+/*
+ *  R : A Computer Language for Statistical Data Analysis
+ *  Copyright (C) 1995, 1996, 1997  Robert Gentleman and Ross Ihaka
+ *  Copyright (C) 1998--2013	    The R Core Team.
+ *  Copyright (C) 2003--2015	    The R Foundation
+ *
+ *  This program is free software; you can redistribute it and/or modify
+ *  it under the terms of the GNU General Public License as published by
+ *  the Free Software Foundation; either version 2 of the License, or
+ *  (at your option) any later version.
+ *
+ *  This program is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
+ *
+ *  You should have received a copy of the GNU General Public License
+ *  along with this program; if not, a copy is available at
+ *  http://www.r-project.org/Licenses/
+ */
+
+typedef union
+{
+    double value;
+    unsigned int word[2];
+} ieee_double;
+
+#ifdef WORDS_BIGENDIAN
+static const int hw = 0;
+static const int lw = 1;
+#else  /* !WORDS_BIGENDIAN */
+static const int hw = 1;
+static const int lw = 0;
+#endif /* WORDS_BIGENDIAN */
+
+
+static double R_ValueOfNA(void)
+{
+    /* The gcc shipping with Fedora 9 gets this wrong without
+     * the volatile declaration. Thanks to Marc Schwartz. */
+    volatile ieee_double x;
+    x.word[hw] = 0x7ff00000;
+    x.word[lw] = 1954;
+    return x.value;
+}
+
+int R_IsNA(double x)
+{
+    if (isnan(x)) {
+	ieee_double y;
+	y.value = x;
+	return (y.word[lw] == 1954);
+    }
+    return 0;
+}
+
+int R_IsNaN(double x)
+{
+    if (isnan(x)) {
+	ieee_double y;
+	y.value = x;
+	return (y.word[lw] != 1954);
+    }
+    return 0;
+}
+
+/* Mainly for use in packages */
+int R_finite(double x)
+{
+#ifdef HAVE_WORKING_ISFINITE
+    return isfinite(x);
+#else
+    return (!isnan(x) & (x != R_PosInf) & (x != R_NegInf));
+#endif
+}
+
+#undef _
+#include "../../../gnur/R-3.1.3/src/nmath/nmath.h"
+
+double fround(double x, double digits) {
+#define MAX_DIGITS DBL_MAX_10_EXP
+    /* = 308 (IEEE); was till R 0.99: (DBL_DIG - 1) */
+    /* Note that large digits make sense for very small numbers */
+    LDOUBLE pow10, sgn, intx;
+    int dig;
+
+    if (ISNAN(x) || ISNAN(digits))
+	return x + digits;
+    if(!R_FINITE(x)) return x;
+
+    if(digits == ML_POSINF) return x;
+    else if(digits == ML_NEGINF) return 0.0;
+
+    if (digits > MAX_DIGITS) digits = MAX_DIGITS;
+    dig = (int)floor(digits + 0.5);
+    if(x < 0.) {
+	sgn = -1.;
+	x = -x;
+    } else
+	sgn = 1.;
+    if (dig == 0) {
+	return (double)(sgn * R_rint(x));
+    } else if (dig > 0) {
+        pow10 = R_pow_di(10., dig);
+	intx = floor(x);
+	return (double)(sgn * (intx + R_rint((double)((x-intx) * pow10)) / pow10));
+    } else {
+        pow10 = R_pow_di(10., -dig);
+        return (double)(sgn * R_rint((double)(x/pow10)) * pow10);
+    }
+}
+
+double Rexp10(double x) {
+	return pow(10.0, x);
+}
+
+double R_pow_di(double x, int n)
+{
+    double xn = 1.0;
+
+    if (ISNAN(x)) return x;
+    if (n == NA_INTEGER) return NA_REAL;
+
+    if (n != 0) {
+	if (!R_FINITE(x)) return R_POW(x, (double)n);
+
+	Rboolean is_neg = (n < 0);
+	if(is_neg) n = -n;
+	for(;;) {
+	    if(n & 01) xn *= x;
+	    if(n >>= 1) x *= x; else break;
+	}
+        if(is_neg) xn = 1. / xn;
+    }
+    return xn;
+}
+

com.oracle.truffle.r.native/fficall/jni/src/misc.c

@@ -25,13 +25,9 @@
 #include <string.h>
 
 jmethodID iS4ObjectMethodID;
-jmethodID isFiniteMethodID;
-jmethodID isNAorNaNMethodID;
 
 void init_misc(JNIEnv *env) {
 	iS4ObjectMethodID = checkGetMethodID(env, CallRFFIHelperClass, "isS4Object", "(Ljava/lang/Object;)I", 1);
-	isFiniteMethodID = checkGetMethodID(env, RRuntimeClass, "isFinite", "(D)Z", 1);
-	isNAorNaNMethodID = checkGetMethodID(env, RRuntimeClass, "isNAorNaN", "(D)Z", 1);
 }
 
 char *dgettext(const char *domainname, const char *msgid) {
@@ -76,24 +72,10 @@ void R_CheckStack2(size_t x) {
 	unimplemented("R_CheckStack2");
 }
 
-int R_finite(double x) {
-	JNIEnv *env = getEnv();
-	return (*env)->CallStaticBooleanMethod(env, RRuntimeClass, isFiniteMethodID, x);
-}
-
-int R_IsNaN(double x) {
-	JNIEnv *env = getEnv();
-	return (*env)->CallStaticBooleanMethod(env, RRuntimeClass, isNAorNaNMethodID, x);
-}
-
 R_len_t R_BadLongVector(SEXP x, const char *y, int z) {
 	unimplemented("R_BadLongVector");
 }
 
-int R_IsNA(double x) {
-	unimplemented("R_IsNA");
-}
-
 int IS_S4_OBJECT(SEXP x) {
 	JNIEnv *env = getEnv();
 	return 	(*env)->CallStaticIntMethod(env, CallRFFIHelperClass, iS4ObjectMethodID, x);

com.oracle.truffle.r.native/fficall/jni/src/rmathc.c

@@ -116,11 +116,6 @@ double R_pow(double x, double y) {
     return 0;
 }
 
-double R_pow_di(double x, int y) {
-    unimplemented("R_pow_di");
-    return 0;
-}
-
 double Rf_dchisq(double x, double y, int z) {
     unimplemented("Rf_dchisq");
     return 0;