/* 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 */ } }