Add implementation of R_qsort_I from GnuR

com.oracle.truffle.r.native/fficall/src/common/qsort-body.templ

+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (c) 2002--2012, The R Core Team
+ * Copyright (c) 2018, 2018, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+
+// Based on CACM algorithm #347 by R. C. Singleton (1969)
+
+/*====== BODY of R_qsort() and R_qsorti() functions ====================
+ *
+ * is included in ./qsort.c  with and without ``qsort_Index'' defined
+ *======================================================================
+*/
+{
+/* Orders v[] increasingly. Puts into I[] the permutation vector:
+ *  new v[k] = old v[I[k]]
+ * Only elements [i : j]  (in 1-indexing !)  are considered.
+
+ * This is a modification of CACM algorithm #347 by R. C. Singleton,
+ * which is a modified Hoare quicksort.
+ * This version incorporates the modification in the remark by Peto.
+*/
+
+#ifndef INTt
+# define INTt size_t
+#endif
+
+    INTt il[40], iu[40]; /* was 31 */
+    /* Arrays iu[k] and il[k] permit sorting up to 2^(k+1)-1 elements;
+     * originally k = 20 -> n_max =    2'097'151
+     * now        k = 31 -> n_max = 4294'967'295
+     */
+    NUMERIC vt, vtt;
+    double R = 0.375;
+    INTt ii, ij, k, l, m;
+#ifdef qsort_Index
+    INDt it, tt;
+#endif
+
+
+    /* 1-indexing for I[], v[]  (and `i' and `j') : */
+    --v;
+#ifdef qsort_Index
+    --I;
+#endif
+
+    ii = i;/* save */
+    m = 1;
+
+  L10:
+    if (i < j) {
+	if (R < 0.5898437) R += 0.0390625; else R -= 0.21875;
+      L20:
+	k = i;
+	/* ij = (j + i) >> 1; midpoint */
+	ij = (INTt)(i + (INTt)((j - i)*R));
+#ifdef qsort_Index
+	it = I[ij];
+#endif
+	vt = v[ij];
+	if (v[i] > vt) {
+#ifdef qsort_Index
+	    I[ij] = I[i]; I[i] = it; it = I[ij];
+#endif
+	    v[ij] = v[i]; v[i] = vt; vt = v[ij];
+	}
+	/* L30:*/
+	l = j;
+	if (v[j] < vt) {
+#ifdef qsort_Index
+	    I[ij] = I[j]; I[j] = it; it = I[ij];
+#endif
+	    v[ij] = v[j]; v[j] = vt; vt = v[ij];
+	    if (v[i] > vt) {
+#ifdef qsort_Index
+		I[ij] = I[i]; I[i] = it; it = I[ij];
+#endif
+		v[ij] = v[i]; v[i] = vt; vt = v[ij];
+	    }
+	}
+
+	for(;;) { /*L50:*/
+	    do l--;  while (v[l] > vt);
+
+#ifdef qsort_Index
+	     tt = I[l];
+#endif
+	    vtt = v[l];
+	    /*L60:*/ do k++;  while (v[k] < vt);
+
+	    if (k > l) break;
+
+	    /* else (k <= l) : */
+#ifdef qsort_Index
+	    I[l] = I[k]; I[k] =  tt;
+#endif
+	    v[l] = v[k]; v[k] = vtt;
+	}
+
+	m++;
+	if (l - i <= j - k) {
+	    /*L70: */
+	    il[m] = k;
+	    iu[m] = j;
+	    j = l;
+	}
+	else {
+	    il[m] = i;
+	    iu[m] = l;
+	    i = k;
+	}
+    }
+    else { /* i >= j : */
+
+    L80:
+	if (m == 1)	return;
+
+	/* else */
+	i = il[m];
+	j = iu[m];
+	m--;
+    }
+
+    if (j - i > 10)	goto L20;
+
+    if (i == ii)	goto L10;
+
+    --i;
+  L100:
+    do {
+	++i;
+	if (i == j) {
+	    goto L80;
+	}
+#ifdef qsort_Index
+	it = I[i + 1];
+#endif
+	vt = v[i + 1];
+    } while (v[i] <= vt);
+
+    k = i;
+
+    do { /*L110:*/
+#ifdef qsort_Index
+	I[k + 1] = I[k];
+#endif
+	v[k + 1] = v[k];
+	--k;
+    } while (vt < v[k]);
+
+#ifdef qsort_Index
+    I[k + 1] = it;
+#endif
+    v[k + 1] = vt;
+    goto L100;
+} /* R_qsort{i} */

com.oracle.truffle.r.native/fficall/src/common/qsort.c

+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (c) 2002--2012, The R Core Team
+ * Copyright (c) 2018, 2018, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+
+/* **********************************************************************
+ * === This was 'sort()' in  gamfit's  mysort.f  [or sortdi() in sortdi.f ] :
+ * was at end of  modreg/src/ppr.f
+ * Translated by f2c (version 20010821) and f2c-clean,v 1.9 2000/01/13 13:46:53
+ * then manually by Martin Maechler
+*/
+
+// Copied from GNU R, TODO: convert to Java up-call
+
+#include <Defn.h>
+#include <Internal.h>
+#include <Rmath.h>
+
+/* These are exposed in Utils.h and are misguidely in the API */
+void qsort4_(double *v, int *indx, int *ii, int *jj)
+{
+    R_qsort_I(v, indx, *ii, *jj);
+}
+
+void qsort3_(double *v, int *ii, int *jj)
+{
+    R_qsort(v, *ii, *jj);
+}
+
+#define qsort_Index
+#define INTt int
+#define INDt int
+
+#define NUMERIC double
+void R_qsort_I(double *v, int *I, int i, int j)
+#include "qsort-body.templ"
+#undef NUMERIC
+
+#define NUMERIC int
+void R_qsort_int_I(int *v, int *I, int i, int j)
+#include "qsort-body.templ"
+#undef NUMERIC
+
+#undef INTt
+#undef INDt
+
+#undef qsort_Index
+
+#define NUMERIC double
+void R_qsort(double *v, size_t i, size_t j)
+#include "qsort-body.templ"
+#undef NUMERIC
+
+#define NUMERIC int
+void R_qsort_int(int *v, size_t i, size_t j)
+#include "qsort-body.templ"
+#undef NUMERIC

com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h

@@ -1218,16 +1218,6 @@ void DUPLICATE_ATTRIB(SEXP to, SEXP from) {
     checkExitCall();
 }
 
-void R_qsort_I  (double *v, int *II, int i, int j) {
-    TRACE0();
-    unimplemented("R_qsort_I");
-}
-
-void R_qsort_int_I(int *iv, int *II, int i, int j) {
-    TRACE0();
-    unimplemented("R_qsort_int_I");
-}
-
 R_len_t R_BadLongVector(SEXP x, const char *y, int z) {
     TRACE0();
     unimplemented("R_BadLongVector");

com.oracle.truffle.r.native/version.source

-47
+48

mx.fastr/copyrights/overrides

@@ -62,6 +62,7 @@ com.oracle.truffle.r.native/fficall/src/truffle_common/Rembedded.c,gnu_r.copyrig
 com.oracle.truffle.r.native/fficall/src/common/arithmetic_fastr.c,gnu_r_gentleman_ihaka.copyright
 com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c,gnu_r_gentleman_ihaka.copyright
 com.oracle.truffle.r.native/fficall/src/common/errors_fastr.c,gnu_r.core.copyright
+com.oracle.truffle.r.native/fficall/src/common/qsort.c,gnu_r.core.copyright
 com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c,gnu_r_gentleman_ihaka.copyright
 com.oracle.truffle.r.native/fficall/src/common/localecharset_fastr.c,gnu_r.copyright
 com.oracle.truffle.r.native/fficall/src/common/print_fastr.c,gnu_r_gentleman_ihaka.copyright