diff --git a/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c index dae288af88ba75f0d1793c8c3fc9e5f623ff9c8c..a49307a11779bc2093e0410ad88ebc71d4a5f449 100644 --- a/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c +++ b/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c @@ -6,7 +6,7 @@ * Copyright (c) 1995, 1996, 1997 Robert Gentleman and Ross Ihaka * Copyright (c) 1995-2014, The R Core Team * Copyright (c) 2002-2008, The R Foundation - * Copyright (c) 2015, Oracle and/or its affiliates + * Copyright (c) 2015, 2016, Oracle and/or its affiliates * * All rights reserved. */ @@ -55,6 +55,77 @@ RealFromInteger(int x, int *warn) return x; } +int +IntegerFromLogical(int x, int *warn) +{ + return (x == NA_LOGICAL) ? + NA_INTEGER : x; +} + +int +IntegerFromReal(double x, int *warn) +{ + if (ISNAN(x)) + return NA_INTEGER; + else if (x > INT_MAX || x <= INT_MIN ) { + *warn |= WARN_NA; + return NA_INTEGER; + } + return (int) x; +} + +static SEXP coerceToInteger(SEXP v) +{ + SEXP ans; + int warn = 0; + R_xlen_t i, n; + PROTECT(ans = allocVector(INTSXP, n = XLENGTH(v))); +#ifdef R_MEMORY_PROFILING + if (RTRACE(v)){ + memtrace_report(v,ans); + SET_RTRACE(ans,1); + } +#endif + DUPLICATE_ATTRIB(ans, v); + switch (TYPEOF(v)) { + case LGLSXP: + for (i = 0; i < n; i++) { +// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt(); + INTEGER(ans)[i] = IntegerFromLogical(LOGICAL(v)[i], &warn); + } + break; + case REALSXP: + for (i = 0; i < n; i++) { +// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt(); + INTEGER(ans)[i] = IntegerFromReal(REAL(v)[i], &warn); + } + break; + case CPLXSXP: + for (i = 0; i < n; i++) { +// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt(); + INTEGER(ans)[i] = IntegerFromComplex(COMPLEX(v)[i], &warn); + } + break; + case STRSXP: + for (i = 0; i < n; i++) { +// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt(); + INTEGER(ans)[i] = IntegerFromString(STRING_ELT(v, i), &warn); + } + break; + case RAWSXP: + for (i = 0; i < n; i++) { +// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt(); + INTEGER(ans)[i] = (int)RAW(v)[i]; + } + break; + default: + UNIMPLEMENTED_TYPE("coerceToInteger", v); + } + if (warn) CoercionWarning(warn); + UNPROTECT(1); + return ans; +} + static SEXP coerceToReal(SEXP v) { SEXP ans; diff --git a/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c index 04933118b60983ec3bfdeaccc9fab2a4186ed61d..5705f851f042d575ef361630e6e61fd17de2aad1 100644 --- a/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c +++ b/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c @@ -6,7 +6,7 @@ * Copyright (c) 1995, 1996, 1997 Robert Gentleman and Ross Ihaka * Copyright (c) 1995-2014, The R Core Team * Copyright (c) 2002-2008, The R Foundation - * Copyright (c) 2015, Oracle and/or its affiliates + * Copyright (c) 2015, 2016, Oracle and/or its affiliates * * All rights reserved. */ @@ -540,3 +540,7 @@ INLINE_FUN SEXP R_FixupRHS(SEXP x, SEXP y) return y; } +Rboolean IS_BYTES(SEXP x) { return FALSE; } +Rboolean IS_LATIN1(SEXP x) { return FALSE; } +Rboolean IS_ASCII(SEXP x) { return FALSE; } +Rboolean IS_UTF8(SEXP x) { return TRUE; }