Пример #1
0
/* 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;
}
Пример #2
0
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;
}
Пример #3
0
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));
  }
}
Пример #4
0
/**
 * 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;
}
Пример #5
0
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;
}
Пример #6
0
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.
}
Пример #7
0
/* {{{ 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);
}
Пример #8
0
/* {{{ 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);
}
Пример #9
0
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;
}
Пример #10
0
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));
  }
}
Пример #11
0
/* {{{ 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);
}
Пример #12
0
/* {{{ 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));
}
Пример #13
0
/* 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;
}
Пример #14
0
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);
}
Пример #15
0
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);
}
Пример #16
0
/* 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);
}
Пример #17
0
/* {{{ 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;
  }
}
Пример #18
0
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);
}
Пример #19
0
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);
}
Пример #20
0
Файл: array.c Проект: skyguy94/R
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));
}
Пример #21
0
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);
}
Пример #22
0
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;
}
Пример #23
0
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;
}
Пример #24
0
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);
}
Пример #25
0
/* {{{ 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);
}
Пример #26
0
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);
}
Пример #27
0
/* 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));
}
Пример #28
0
Файл: fork.c Проект: kschaab/RRO
SEXP mc_master_fd() 
{
    return ScalarInteger(master_fd);
}
Пример #29
0
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);
}
Пример #30
0
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 */
    }
}