From a5a1bbaad279c4f56850bc8d047e97bbf02d9616 Mon Sep 17 00:00:00 2001
From: stepan <stepan.sindelar@oracle.com>
Date: Tue, 23 Jan 2018 17:21:59 +0100
Subject: [PATCH] Add implementation of R_qsort_I from GnuR
---
.../fficall/src/common/qsort-body.templ | 161 ++++++++++++++++++
.../fficall/src/common/qsort.c | 63 +++++++
.../Rinternals_truffle_common.h | 10 --
com.oracle.truffle.r.native/version.source | 2 +-
mx.fastr/copyrights/overrides | 1 +
5 files changed, 226 insertions(+), 11 deletions(-)
create mode 100644 com.oracle.truffle.r.native/fficall/src/common/qsort-body.templ
create mode 100644 com.oracle.truffle.r.native/fficall/src/common/qsort.c
diff --git a/com.oracle.truffle.r.native/fficall/src/common/qsort-body.templ b/com.oracle.truffle.r.native/fficall/src/common/qsort-body.templ
new file mode 100644
index 0000000000..85b434aeb2
--- /dev/null
+++ b/com.oracle.truffle.r.native/fficall/src/common/qsort-body.templ
@@ -0,0 +1,161 @@
+/*
+ * 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} */
diff --git a/com.oracle.truffle.r.native/fficall/src/common/qsort.c b/com.oracle.truffle.r.native/fficall/src/common/qsort.c
new file mode 100644
index 0000000000..a3bfa43ffe
--- /dev/null
+++ b/com.oracle.truffle.r.native/fficall/src/common/qsort.c
@@ -0,0 +1,63 @@
+/*
+ * 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
diff --git a/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h b/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h
index be5a68d086..62570bfb08 100644
--- a/com.oracle.truffle.r.native/fficall/src/truffle_common/Rinternals_truffle_common.h
+++ b/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");
diff --git a/com.oracle.truffle.r.native/version.source b/com.oracle.truffle.r.native/version.source
index abac1ea7b7..21e72e8ac3 100644
--- a/com.oracle.truffle.r.native/version.source
+++ b/com.oracle.truffle.r.native/version.source
@@ -1 +1 @@
-47
+48
diff --git a/mx.fastr/copyrights/overrides b/mx.fastr/copyrights/overrides
index 6dbe8cf3cc..b9c0f04a36 100644
--- a/mx.fastr/copyrights/overrides
+++ b/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
--
GitLab