/* used in devWindows.c and cairoDevice */
void doMouseEvent(pDevDesc dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
PROTECT(handler = findVar(install(mouseHandlers[event]), dd->eventEnv));
if (TYPEOF(handler) == PROMSXP) {
handler = eval(handler, dd->eventEnv);
UNPROTECT(1); /* handler */
PROTECT(handler);
}
if (TYPEOF(handler) == CLOSXP) {
SEXP s_which = install("which");
defineVar(s_which, ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
// Be portable: see PR#15793
int len = ((buttons & leftButton) != 0)
+ ((buttons & middleButton) != 0)
+ ((buttons & rightButton) != 0);
PROTECT(bvec = allocVector(INTSXP, len));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
PROTECT(sx = ScalarReal( (x - dd->left) / (dd->right - dd->left) ));
PROTECT(sy = ScalarReal((y - dd->bottom) / (dd->top - dd->bottom) ));
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(5);
R_FlushConsole();
}
UNPROTECT(1); /* handler */
dd->gettingEvent = TRUE;
return;
}
SEXP rmysql_driver_init(SEXP max_con_, SEXP fetch_default_rec_) {
SEXP mgrHandle = ScalarInteger(0);
if (dbManager) return mgrHandle;
int max_con = asInteger(max_con_),
fetch_default_rec = asInteger(fetch_default_rec_);
int counter = 0;
MySQLDriver* mgr = (MySQLDriver*) malloc(sizeof(MySQLDriver));
if (!mgr)
error("Could not allocate memory for the MySQL driver");
/* Ok, we're here to expand number of connections, etc.*/
mgr->managerId = 0;
mgr->connections = calloc(max_con, sizeof(RS_DBI_connection));
if (!mgr->connections) {
free(mgr);
error("Could not allocate memory for connections");
}
mgr->connectionIds = calloc(max_con, sizeof(int));
if (!mgr->connectionIds){
free(mgr->connections);
free(mgr);
error("Could not allocation memory for connection Ids");
}
mgr->counter = counter;
mgr->length = max_con;
mgr->num_con = (int) 0;
mgr->fetch_default_rec = fetch_default_rec;
for(int i = 0; i < max_con; i++){
mgr->connectionIds[i] = -1;
mgr->connections[i] = (RS_DBI_connection *) NULL;
}
dbManager = mgr;
return mgrHandle;
}
SEXP ConvertValue(bson_iter_t* iter){
if(BSON_ITER_HOLDS_INT32(iter)){
return ScalarInteger(bson_iter_int32(iter));
} else if(BSON_ITER_HOLDS_NULL(iter)){
return R_NilValue;
} else if(BSON_ITER_HOLDS_BOOL(iter)){
return ScalarLogical(bson_iter_bool(iter));
} else if(BSON_ITER_HOLDS_DOUBLE(iter)){
return ScalarReal(bson_iter_double(iter));
} else if(BSON_ITER_HOLDS_INT64(iter)){
return ScalarReal((double) bson_iter_int64(iter));
} else if(BSON_ITER_HOLDS_UTF8(iter)){
return mkStringUTF8(bson_iter_utf8(iter, NULL));
} else if(BSON_ITER_HOLDS_CODE(iter)){
return mkStringUTF8(bson_iter_code(iter, NULL));
} else if(BSON_ITER_HOLDS_BINARY(iter)){
return ConvertBinary(iter);
} else if(BSON_ITER_HOLDS_DATE_TIME(iter)){
return ConvertDate(iter);
} else if(BSON_ITER_HOLDS_OID(iter)){
const bson_oid_t *val = bson_iter_oid(iter);
char str[25];
bson_oid_to_string(val, str);
return mkString(str);
} else if(BSON_ITER_HOLDS_ARRAY(iter)){
bson_iter_t child1;
bson_iter_t child2;
bson_iter_recurse (iter, &child1);
bson_iter_recurse (iter, &child2);
return ConvertArray(&child1, &child2);
} else if(BSON_ITER_HOLDS_DOCUMENT(iter)){
bson_iter_t child1;
bson_iter_t child2;
bson_iter_recurse (iter, &child1);
bson_iter_recurse (iter, &child2);
return ConvertObject(&child1, &child2);
} else {
stop("Unimplemented BSON type %d\n", bson_iter_type(iter));
}
}
/**
* Return a SuiteSparse QR factorization of the sparse matrix A
*
* @param Ap (pointer to) a [m x n] dgCMatrix
* @param ordering integer SEXP specifying the ordering strategy to be used
* see SPQR/Include/SuiteSparseQR_definitions.h
* @param econ integer SEXP ("economy"): number of rows of R and columns of Q
* to return. The default is m. Using n gives the standard economy form.
* A value less than the estimated rank r is set to r, so econ=0 gives the
* "rank-sized" factorization, where nrow(R)==nnz(diag(R))==r.
* @param tol double SEXP: if tol <= -2 use SPQR's default,
* if -2 < tol < 0, then no tol is used; otherwise,
* tol > 0, use as tolerance: columns with 2-norm <= tol treated as 0
*
*
* @return SEXP "SPQR" object with slots (Q, R, p, rank, Dim):
* Q: dgCMatrix; R: dgCMatrix [subject to change to dtCMatrix FIXME ?]
* p: integer: 0-based permutation (or length 0 <=> identity);
* rank: integer, the "revealed" rank Dim: integer, original matrix dim.
*/
SEXP dgCMatrix_SPQR(SEXP Ap, SEXP ordering, SEXP econ, SEXP tol)
{
/* SEXP ans = PROTECT(allocVector(VECSXP, 4)); */
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("SPQR")));
CHM_SP A = AS_CHM_SP(Ap), Q, R;
SuiteSparse_long *E, rank;/* not always = int FIXME (Windows_64 ?) */
if ((rank = SuiteSparseQR_C_QR(asInteger(ordering),
asReal(tol),/* originally had SPQR_DEFAULT_TOL */
(SuiteSparse_long)asInteger(econ),/* originally had 0 */
A, &Q, &R, &E, &cl)) == -1)
error(_("SuiteSparseQR_C_QR returned an error code"));
slot_dup(ans, Ap, Matrix_DimSym);
/* SET_VECTOR_ELT(ans, 0, */
/* chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue)); */
SET_SLOT(ans, install("Q"),
chm_sparse_to_SEXP(Q, 0, 0, 0, "", R_NilValue));
/* Also gives a dgCMatrix (not a dtC* *triangular*) :
* may make sense if to be used in the "spqr_solve" routines .. ?? */
/* SET_VECTOR_ELT(ans, 1, */
/* chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue)); */
SET_SLOT(ans, install("R"),
chm_sparse_to_SEXP(R, 0, 0, 0, "", R_NilValue));
cholmod_free_sparse(&Al, &cl);
cholmod_free_sparse(&R, &cl);
cholmod_free_sparse(&Q, &cl);
if (E) {
int *Er;
SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, A->ncol));
Er = INTEGER(VECTOR_ELT(ans, 2));
for (int i = 0; i < A->ncol; i++) Er[i] = (int) E[i];
Free(E);
} else SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, 0));
SET_VECTOR_ELT(ans, 3, ScalarInteger((int)rank));
UNPROTECT(1);
return ans;
}
SEXP loop_apply(SEXP n, SEXP f, SEXP rho) {
if(!isFunction(f)) error("'f' must be a function");
if(!isEnvironment(rho)) error("'rho' should be an environment");
int n1 = INTEGER(n)[0];
SEXP results, R_fcall;
PROTECT(results = allocVector(VECSXP, n1));
PROTECT(R_fcall = lang2(f, R_NilValue));
SEXP ii;
for(int i = 0; i < n1; i++) {
PROTECT(ii = ScalarInteger(i + 1));
SETCADR(R_fcall, ii);
SET_VECTOR_ELT(results, i, eval(R_fcall, rho));
UNPROTECT(1);
}
UNPROTECT(2);
return results;
}
void attribute_visible R_init_datatable(DllInfo *info)
// relies on pkg/src/Makevars to mv data.table.so to datatable.so
{
R_registerRoutines(info, NULL, callMethods, NULL, externalMethods);
R_useDynamicSymbols(info, FALSE);
setSizes();
const char *msg = "... failed. Please forward this message to maintainer('data.table') or datatable-help.";
if (NA_INTEGER != INT_MIN) error("Checking NA_INTEGER [%d] == INT_MIN [%d] %s", NA_INTEGER, INT_MIN, msg);
if (NA_INTEGER != NA_LOGICAL) error("Checking NA_INTEGER [%d] == NA_LOGICAL [%d] %s", NA_INTEGER, NA_LOGICAL, msg);
if (sizeof(int) != 4) error("Checking sizeof(int) [%d] is 4 %s", sizeof(int), msg);
if (sizeof(double) != 8) error("Checking sizeof(double) [%d] is 8 %s", sizeof(double), msg); // 8 on both 32bit and 64bit.
if (sizeof(long long) != 8) error("Checking sizeof(long long) [%d] is 8 %s", sizeof(long long), msg);
if (sizeof(char *) != 4 && sizeof(char *) != 8) error("Checking sizeof(pointer) [%d] is 4 or 8 %s", sizeof(char *), msg);
if (sizeof(SEXP) != sizeof(char *)) error("Checking sizeof(SEXP) [%d] == sizeof(pointer) [%d] %s", sizeof(SEXP), sizeof(char *), msg);
SEXP tmp = PROTECT(allocVector(INTSXP,2));
if (LENGTH(tmp)!=2) error("Checking LENGTH(allocVector(INTSXP,2)) [%d] is 2 %s", LENGTH(tmp), msg);
if (TRUELENGTH(tmp)!=0) error("Checking TRUELENGTH(allocVector(INTSXP,2)) [%d] is 0 %s", TRUELENGTH(tmp), msg);
UNPROTECT(1);
// According to IEEE (http://en.wikipedia.org/wiki/IEEE_754-1985#Zero) we can rely on 0.0 being all 0 bits.
// But check here anyway just to be sure, just in case this answer is right (http://stackoverflow.com/a/2952680/403310).
int i = 314;
memset(&i, 0, sizeof(int));
if (i != 0) error("Checking memset(&i,0,sizeof(int)); i == (int)0 %s", msg);
unsigned int ui = 314;
memset(&ui, 0, sizeof(unsigned int));
if (ui != 0) error("Checking memset(&ui, 0, sizeof(unsigned int)); ui == (unsigned int)0 %s", msg);
double d = 3.14;
memset(&d, 0, sizeof(double));
if (d != 0.0) error("Checking memset(&d, 0, sizeof(double)); d == (double)0.0 %s", msg);
long double ld = 3.14;
memset(&ld, 0, sizeof(long double));
if (ld != 0.0) error("Checking memset(&ld, 0, sizeof(long double)); ld == (long double)0.0 %s", msg);
setNumericRounding(ScalarInteger(2));
char_integer64 = mkChar("integer64"); // for speed, similar to R_*Symbol.
}
/* {{{ rberkeley_db_create */
SEXP rberkeley_db_create (SEXP _dbenv)
{
DB *dbp;
DB_ENV *dbenv;
int ret;
dbp = (DB *)Calloc(1, DB);
if(isNull(_dbenv)) {
ret = db_create(&dbp, NULL, 0);
} else {
dbenv = R_ExternalPtrAddr(_dbenv);
if(R_ExternalPtrTag(_dbenv) != RBerkeley_DB_ENV || dbenv == NULL)
error("invalid 'dbenv' handle");
ret = db_create(&dbp, dbenv, 0);
}
if(ret==0) {
SEXP ptr = R_MakeExternalPtr(dbp, RBerkeley_DB, ScalarLogical(TRUE));
return ptr;
}
return ScalarInteger(ret);
}
/* {{{ rberkeley_db_remove */
SEXP rberkeley_db_remove (SEXP _dbp, SEXP _file, SEXP _database)
{
DB *dbp;
int ret;
u_int32_t flags = 0;
const char * database;
if(isNull(_database)) {
database = NULL;
} else {
database = (const char *)CHAR(STRING_ELT(_database,0));
}
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
ret = dbp->remove(dbp,
(const char *)CHAR(STRING_ELT(_file,0)),
database,
flags);
return ScalarInteger(ret);
}
attribute_hidden
SEXP do_shortRowNames(SEXP call, SEXP op, SEXP args, SEXP env)
{
/* return n if the data frame 'vec' has c(NA, n) rownames;
* nrow(.) otherwise; note that data frames with nrow(.) == 0
* have no row.names.
==> is also used in dim.data.frame() */
checkArity(op, args);
SEXP s = getAttrib0(CAR(args), R_RowNamesSymbol), ans = s;
int type = asInteger(CADR(args));
if( type < 0 || type > 2)
error(_("invalid '%s' argument"), "type");
if(type >= 1) {
int n = (isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER)
? INTEGER(s)[1] : (isNull(s) ? 0 : LENGTH(s));
ans = ScalarInteger((type == 1) ? n : abs(n));
}
return ans;
}
SEXP ConvertValue(bson_iter_t* iter){
if(BSON_ITER_HOLDS_INT32(iter)){
return ScalarInteger(bson_iter_int32(iter));
} else if(BSON_ITER_HOLDS_NULL(iter)){
return R_NilValue;
} else if(BSON_ITER_HOLDS_BOOL(iter)){
return ScalarLogical(bson_iter_bool(iter));
} else if(BSON_ITER_HOLDS_DOUBLE(iter)){
return ScalarReal(bson_iter_double(iter));
} else if(BSON_ITER_HOLDS_INT64(iter)){
return ScalarReal((double) bson_iter_int64(iter));
} else if(BSON_ITER_HOLDS_UTF8(iter)){
return mkStringUTF8(bson_iter_utf8(iter, NULL));
} else if(BSON_ITER_HOLDS_CODE(iter)){
return mkStringUTF8(bson_iter_code(iter, NULL));
} else if(BSON_ITER_HOLDS_BINARY(iter)){
return ConvertBinary(iter);
} else if(BSON_ITER_HOLDS_DATE_TIME(iter)){
return ConvertDate(iter);
} else if(BSON_ITER_HOLDS_OID(iter)){
//not sure if this casting works
return mkRaw((unsigned char *) bson_iter_oid(iter), 12);
} else if(BSON_ITER_HOLDS_ARRAY(iter)){
bson_iter_t child1;
bson_iter_t child2;
bson_iter_recurse (iter, &child1);
bson_iter_recurse (iter, &child2);
return ConvertArray(&child1, &child2);
} else if(BSON_ITER_HOLDS_DOCUMENT(iter)){
bson_iter_t child1;
bson_iter_t child2;
bson_iter_recurse (iter, &child1);
bson_iter_recurse (iter, &child2);
return ConvertObject(&child1, &child2);
} else {
stop("Unimplemented BSON type %d\n", bson_iter_type(iter));
}
}
/* {{{ rberkeley_db_open */
SEXP rberkeley_db_open (SEXP _dbp,
SEXP _txnid,
SEXP _file,
SEXP _database,
SEXP _type,
SEXP _flags/*, SEXP _mode*/)
{
DB *dbp;
DB_TXN *txnid;
DBTYPE type = (DBTYPE)INTEGER(_type)[0];
u_int32_t flags = (u_int32_t)INTEGER(_flags)[0];
const char * file, * database;
int ret;
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else txnid = NULL;
if(isNull(_file)) {
file = NULL;
} else {
file = CHAR(STRING_ELT(_file,0));
}
if(isNull(_database)) {
database = NULL;
} else {
database = CHAR(STRING_ELT(_database,0));
}
ret = dbp->open(dbp, txnid, file, database, type, flags, 0664);
return ScalarInteger(ret);
}
/* {{{ rberkeley_db_cursor */
SEXP rberkeley_db_cursor (SEXP _dbp, SEXP _txnid, SEXP _flags)
{
DB *dbp;
DBC *dbc;
DB_TXN *txnid;
int ret;
u_int32_t flags = INTEGER(_flags)[0];
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != install("DB") || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else txnid = NULL;
ret = dbp->cursor(dbp, txnid, &dbc, flags);
if(ret != 0)
return ScalarInteger(ret);
return R_MakeExternalPtr(dbc, install("DBC"), ScalarLogical(TRUE));
}
/* used in devWindows.c and cairoDevice */
void doKeybd(pDevDesc dd, R_KeyName rkey,
const char *keyname)
{
SEXP handler, skey, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(keybdHandler), dd->eventEnv);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, dd->eventEnv);
if (TYPEOF(handler) == CLOSXP) {
defineVar(install("which"), ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(skey = mkString(keyname ? keyname : keynames[rkey]));
PROTECT(temp = lang2(handler, skey));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(3);
R_FlushConsole();
}
dd->gettingEvent = TRUE;
return;
}
SEXP put_values_from_C (SEXP _dbp)
{
DB *dbp;
DBT key, data;
int ret;
dbp = R_ExternalPtrAddr(_dbp);
memset(&key, 0, sizeof(DBT));
memset(&data, 0, sizeof(DBT));
double d = 123.4;
key.data = &d;
key.size = sizeof(double);
int i = 1;
data.data = &i;
data.size = sizeof(int);
ret = dbp->put(dbp, NULL, &key, &data, 0);
return ScalarInteger(ret);
}
SEXP R_mpfr_set_erange(SEXP kind_, SEXP val) {
erange_kind kind = asInteger(kind_);
mpfr_exp_t exp_val;
if(isInteger(val))
exp_val = asInteger(val);// assume this is always valid to set
else { // we allow larger values from the R side
PROTECT(val = coerceVector(val, REALSXP));
exp_val = (mpfr_exp_t) asReal(val);
UNPROTECT(1);
}
int i_err;
switch(kind) {
case E_min: i_err = mpfr_set_emin(exp_val); break;
case E_max: i_err = mpfr_set_emax(exp_val); break;
default:
error("invalid kind (code = %d) in R_mpfr_set_erange()", kind);
}
if(i_err) warning("e%s exponent could not be set to %ld (code %d)",
(kind == E_min) ? "min" : "max", (long)exp_val, i_err);
return ScalarInteger(i_err);
}
/* Works with digits, but OK in UTF-8 */
SEXP menu(SEXP choices)
{
int c, j;
double first;
char buffer[MAXELTSIZE], *bufp = buffer;
LocalData data = {NULL, 0, 0, '.', NULL, NO_COMCHAR, 0, NULL, FALSE,
FALSE, 0, FALSE, FALSE};
data.NAstrings = R_NilValue;
if (!isString(choices))
error(_("invalid '%s' argument"), "choices");
sprintf(ConsolePrompt, _("Selection: "));
while ((c = ConsoleGetchar()) != '\n' && c != R_EOF) {
if (bufp >= &buffer[MAXELTSIZE - 2]) continue;
*bufp++ = (char) c;
}
*bufp++ = '\0';
ConsolePrompt[0] = '\0';
bufp = buffer;
while (Rspace((int)*bufp)) bufp++;
first = LENGTH(choices) + 1;
if (isdigit((int)*bufp)) {
first = Strtod(buffer, NULL, TRUE, &data);
} else {
for (j = 0; j < LENGTH(choices); j++) {
if (streql(translateChar(STRING_ELT(choices, j)), buffer)) {
first = j + 1;
break;
}
}
}
return ScalarInteger((int)first);
}
/* {{{ rberkeley_db_get_priority */
SEXP rberkeley_db_get_priority (SEXP _dbp)
{
error("DB->get_priority is unavailable from R");
DBC *dbp;
DB_CACHE_PRIORITY priority;
int ret;
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
/* something is wrong with this call... */
ret = dbp->get_priority(dbp, &priority);
if(ret != 0)
return ScalarInteger(ret);
switch(priority) {
case DB_PRIORITY_VERY_LOW:
return mkString("DB_PRIORITY_VERY_LOW");
break;
case DB_PRIORITY_LOW:
return mkString("DB_PRIORITY_LOW");
break;
case DB_PRIORITY_DEFAULT:
return mkString("DB_PRIORITY_DEFAULT");
break;
case DB_PRIORITY_HIGH:
return mkString("DB_PRIORITY_HIGH");
break;
case DB_PRIORITY_VERY_HIGH:
return mkString("DB_PRIORITY_VERY_HIGH");
break;
default:
return R_NilValue;
}
}
SEXP
R_unzGetCurrentFileInfo(SEXP r_r555, SEXP r_r588, SEXP r_r620, SEXP r_r653, SEXP r_r691, SEXP r_r730, SEXP r_r762, SEXP r_r798)
{
SEXP r_ans = R_NilValue;
unzFile r555 ;
unz_file_info r588 ;
char r620[256] ;
uLong r653 = 256;
void * r691 = NULL;
uLong r730 ;
char * r762 = NULL;
uLong r798 ;
int ans ;
r555 = DEREF_REF_PTR( r_r555 , unzFile ) ;
/*
r588 = R_GET_REF_TYPE( r_r588 , unz_file_info ); ;
r620 = CHAR(STRING_ELT( r_r620 , 0)) ;
r653 = INTEGER( r_r653 )[0] ;
r691 = NA ( r_r691 ) ;
r730 = INTEGER( r_r730 )[0] ;
r762 = CHAR(STRING_ELT( r_r762 , 0)) ;
r798 = INTEGER( r_r798 )[0] ;
*/
ans = unzGetCurrentFileInfo ( r555, &r588, r620, r653, r691, r730, r762, r798 ) ;
PROTECT(r_ans = NEW_LIST(3));
SET_VECTOR_ELT(r_ans, 0, ScalarInteger( ans ) );
SET_VECTOR_ELT(r_ans, 1, R_copyStruct_unz_file_info(&r588));
SET_VECTOR_ELT(r_ans, 2, mkString(r620));
/* names */
UNPROTECT(1);
return(r_ans);
}
SEXP
convertNativeValuePtrToR(void *ptr, const llvm::Type *type)
{
SEXP ans = R_NilValue;
if(!ptr)
return(ans);
llvm::Type::TypeID ty = type->getTypeID();
switch(ty) {
case llvm::Type::IntegerTyID: {
unsigned num = type->getIntegerBitWidth();
if(num == 1)
ans = ScalarLogical( * ((int *) ptr));
else
ans = ScalarInteger( * ((int *) ptr));
break;
}
case llvm::Type::DoubleTyID:
ans = ScalarReal( * ((double *) ptr));
break;
case llvm::Type::FloatTyID:
ans = ScalarReal( * ((float *) ptr));
break;
case llvm::Type::PointerTyID:
ans = convertRawPointerToR(ptr, type);
break;
case llvm::Type::ArrayTyID:
ans = convertRawPointerToR(ptr, type);
break;
default:
PROBLEM "no code to handle converting native value to R for %d", ty
WARN;
}
return(ans);
}
SEXP attribute_hidden do_length(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
check1arg(args, call, "x");
SEXP x = CAR(args), ans;
if (isObject(x) &&
DispatchOrEval(call, op, "length", args, rho, &ans, 0, 1)) {
if (length(ans) == 1 && TYPEOF(ans) == REALSXP) {
double d = REAL(ans)[0];
if (R_FINITE(d) && d >= 0. && d <= INT_MAX && floor(d) == d)
return coerceVector(ans, INTSXP);
}
return(ans);
}
#ifdef LONG_VECTOR_SUPPORT
// or use IS_LONG_VEC
R_xlen_t len = xlength(x);
if (len > INT_MAX) return ScalarReal((double) len);
#endif
return ScalarInteger(length(x));
}
SEXP new_svd_mem(int p) {
SEXP ans, u, v, s;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("svd_mem")));
SET_SLOT(ans, PL2_pSym, PROTECT(ScalarInteger(p)));
SET_SLOT(ans, PL2_methodSym, PROTECT(mkString("dgesdd")));
SET_SLOT(ans, PL2_jobuSym, PROTECT(mkString("S")));
SET_SLOT(ans, PL2_jobvSym, PROTECT(mkString("")));
SET_SLOT(ans, PL2_uSym, u = PROTECT(allocMatrix(REALSXP, p, p)));
for (int i = 0; i < p * p; i++)
REAL(u)[i] = 0.0;
SET_SLOT(ans, PL2_vSym, v = PROTECT(allocMatrix(REALSXP, p, p)));
for (int i = 0; i < p * p; i++)
REAL(v)[i] = 0.0;
SET_SLOT(ans, PL2_sSym, s = PROTECT(allocVector(REALSXP, p)));
for (int i = 0; i < p; i++)
REAL(s)[i] = 0.0;
UNPROTECT(8);
return(ans);
}
size_t R_curl_callback_read(char *buffer, size_t size, size_t nitems, SEXP fun) {
SEXP nbytes = PROTECT(ScalarInteger(size * nitems));
SEXP call = PROTECT(LCONS(fun, LCONS(nbytes, R_NilValue)));
int ok;
SEXP res = PROTECT(R_tryEval(call, R_GlobalEnv, &ok));
if (ok != 0 || pending_interrupt()) {
UNPROTECT(3);
return CURL_READFUNC_ABORT;
}
if (TYPEOF(res) != RAWSXP) {
UNPROTECT(3);
Rf_warning("read callback must raw vector");
return CURL_READFUNC_ABORT;
}
size_t bytes_read = length(res);
memcpy(buffer, RAW(res), bytes_read);
UNPROTECT(3);
return bytes_read;
}
SEXP _reported_matches_asSEXP()
{
SEXP start, width, ans;
switch (internal_match_buf.ms_code) {
case MATCHES_AS_NULL:
return R_NilValue;
case MATCHES_AS_COUNTS:
case MATCHES_AS_WHICH:
return ScalarInteger(_get_match_count());
case MATCHES_AS_RANGES:
PROTECT(start = new_INTEGER_from_IntAE(
internal_match_buf.match_starts->elts[active_PSpair_id]));
PROTECT(width = new_INTEGER_from_IntAE(
internal_match_buf.match_widths->elts[active_PSpair_id]));
PROTECT(ans = new_IRanges("IRanges", start, width, R_NilValue));
UNPROTECT(3);
return ans;
}
error("Biostrings internal error in _reported_matches_asSEXP(): "
"invalid 'internal_match_buf.ms_code' value %d",
internal_match_buf.ms_code);
return R_NilValue;
}
SEXP
R_getDynamicVariantValue(SEXP ref)
{
VARIANT *var;
VARTYPE rtype;
var = R_getVariantRef(ref);
rtype = V_VT(var) & (~ VT_BYREF);
switch(rtype) {
case VT_BOOL:
return(ScalarLogical(*V_BOOLREF(var)));
break;
case VT_I4:
return(ScalarInteger(*V_I4REF(var)));
break;
case VT_R8:
return(ScalarReal(*V_R8REF(var)));
break;
default:
return(R_NilValue);
}
return(R_NilValue);
}
/* {{{ rberkeley_db_compact */
SEXP rberkeley_db_compact (SEXP _dbp, SEXP _txnid, SEXP _start,
SEXP _stop, SEXP _c_data, SEXP _flags)
{
DB *dbp;
DB_TXN *txnid;
DBT start, stop, end;
/*DB_COMPACT c_data;*/
u_int32_t flags;
int ret;
if(isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else {
txnid = NULL;
}
if(!isNull(_start)) {
memset(&start, 0, sizeof(DBT));
start.data = (unsigned char *)RAW(_start);
start.size = length(_start);
}
if(!isNull(_stop)) {
memset(&stop, 0, sizeof(DBT));
stop.data = (unsigned char *)RAW(_stop);
stop.size = length(_stop);
}
flags = (u_int32_t)INTEGER(_flags)[0];
/*memset(&end, 0, sizeof(end));*/
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
ret = dbp->compact(dbp, txnid, &start, &stop, NULL, flags, &end);
return ScalarInteger(ret);
}
SEXP R_copyStruct_tm_unz (tm_unz *value)
{
SEXP r_ans = R_NilValue, klass;
klass = MAKE_CLASS("tm_unz");
if(klass == R_NilValue) {
PROBLEM "Cannot find R class tm_unz "
ERROR;
}
PROTECT(klass);
PROTECT(r_ans = NEW(klass));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_sec"), ScalarInteger( value -> tm_sec ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_min"), ScalarInteger( value -> tm_min ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_hour"), ScalarInteger( value -> tm_hour ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_mday"), ScalarInteger( value -> tm_mday ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_mon"), ScalarInteger( value -> tm_mon ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tm_year"), ScalarInteger( value -> tm_year ) ));
UNPROTECT( 8 );
return(r_ans);
}
/* open a connection with the same parameters used for in conHandle */
SEXP RS_MySQL_cloneConnection(SEXP conHandle) {
return RS_MySQL_createConnection(
ScalarInteger(0),
RS_MySQL_cloneConParams(RS_DBI_getConnection(conHandle)->conParams));
}
SEXP mc_master_fd()
{
return ScalarInteger(master_fd);
}
SEXP attribute_hidden
do_mapply(SEXP f, SEXP varyingArgs, SEXP constantArgs, SEXP rho)
{
int i, j, m, *lengths, *counters, named, longest = 0, zero = 0;
SEXP vnames, fcall = R_NilValue, mindex, nindex, tmp1, tmp2, ans;
m = length(varyingArgs);
vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
named = vnames != R_NilValue;
lengths = (int *) R_alloc(m, sizeof(int));
for(i = 0; i < m; i++){
lengths[i] = length(VECTOR_ELT(varyingArgs, i));
if(lengths[i] == 0) zero++;
if (lengths[i] > longest) longest = lengths[i];
}
if (zero && longest)
error(_("Zero-length inputs cannot be mixed with those of non-zero length"));
counters = (int *) R_alloc(m, sizeof(int));
for(i = 0; i < m; counters[i++] = 0);
mindex = PROTECT(allocVector(VECSXP, m));
nindex = PROTECT(allocVector(VECSXP, m));
/* build a call like
f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
*/
if (constantArgs == R_NilValue)
PROTECT(fcall = R_NilValue);
else if(isVectorList(constantArgs))
PROTECT(fcall = VectorToPairList(constantArgs));
else
error(_("argument 'MoreArgs' of 'mapply' is not a list"));
for(j = m - 1; j >= 0; j--) {
SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
SET_VECTOR_ELT(nindex, j, allocVector(INTSXP, 1));
PROTECT(tmp1 = lang3(R_Bracket2Symbol,
install("dots"),
VECTOR_ELT(mindex, j)));
PROTECT(tmp2 = lang3(R_Bracket2Symbol,
tmp1,
VECTOR_ELT(nindex, j)));
UNPROTECT(3);
PROTECT(fcall = LCONS(tmp2, fcall));
if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
SET_TAG(fcall, install(translateChar(STRING_ELT(vnames, j))));
}
UNPROTECT(1);
PROTECT(fcall = LCONS(f, fcall));
PROTECT(ans = allocVector(VECSXP, longest));
for(i = 0; i < longest; i++) {
for(j = 0; j < m; j++) {
counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
INTEGER(VECTOR_ELT(nindex, j))[0] = counters[j];
}
SET_VECTOR_ELT(ans, i, eval(fcall, rho));
}
for(j = 0; j < m; j++) {
if (counters[j] != lengths[j])
warning(_("longer argument not a multiple of length of shorter"));
}
UNPROTECT(5);
return(ans);
}
SEXP attribute_hidden do_sys(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, n = -1, nframe;
SEXP rval, t;
RCNTXT *cptr;
checkArity(op, args);
/* first find the context that sys.xxx needs to be evaluated in */
cptr = R_GlobalContext;
t = cptr->sysparent;
while (cptr != R_ToplevelContext) {
if (cptr->callflag & CTXT_FUNCTION )
if (cptr->cloenv == t)
break;
cptr = cptr->nextcontext;
}
if (length(args) == 1) n = asInteger(CAR(args));
switch (PRIMVAL(op)) {
case 1: /* parent */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "n");
i = nframe = framedepth(cptr);
/* This is a pretty awful kludge, but the alternative would be
a major redesign of everything... -pd */
while (n-- > 0)
i = R_sysparent(nframe - i + 1, cptr);
return ScalarInteger(i);
case 2: /* call */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_syscall(n, cptr);
case 3: /* frame */
if(n == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
return R_sysframe(n, cptr);
case 4: /* sys.nframe */
return ScalarInteger(framedepth(cptr));
case 5: /* sys.calls */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t=rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_syscall(i, cptr));
UNPROTECT(1);
return rval;
case 6: /* sys.frames */
nframe = framedepth(cptr);
PROTECT(rval = allocList(nframe));
t = rval;
for(i = 1; i <= nframe; i++, t = CDR(t))
SETCAR(t, R_sysframe(i, cptr));
UNPROTECT(1);
return rval;
case 7: /* sys.on.exit */
if( R_GlobalContext->nextcontext != NULL)
return R_GlobalContext->nextcontext->conexit;
else
return R_NilValue;
case 8: /* sys.parents */
nframe = framedepth(cptr);
rval = allocVector(INTSXP, nframe);
for(i = 0; i < nframe; i++)
INTEGER(rval)[i] = R_sysparent(nframe - i, cptr);
return rval;
case 9: /* sys.function */
if(n == NA_INTEGER)
error(_("invalid '%s' value"), "which");
return(R_sysfunction(n, cptr));
default:
error(_("internal error in 'do_sys'"));
return R_NilValue;/* just for -Wall */
}
}
