SEXP string_to_try_error__impl( const std::string& str){
// form simple error condition based on a string
Scoped<SEXP> simpleErrorExpr = ::Rf_lang2(::Rf_install("simpleError"), Rf_mkString(str.c_str()));
Scoped<SEXP> simpleError = Rf_eval(simpleErrorExpr, R_GlobalEnv);
Scoped<SEXP> tryError = Rf_mkString( str.c_str() ) ;
Rf_setAttrib( tryError, R_ClassSymbol, Rf_mkString("try-error") ) ;
Rf_setAttrib( tryError, Rf_install( "condition") , simpleError ) ;
return tryError;
}
SEXP audio_load_driver(SEXP path) {
#ifdef HAS_DLSYM
if (TYPEOF(path) == STRSXP && LENGTH(path) > 0) {
const char *cPath = CHAR(STRING_ELT(path, 0));
audio_driver_t *drv;
void *(*fn)();
void *ad, *dl = dlopen(cPath, RTLD_LAZY | RTLD_LOCAL); /* try local first */
if (!dl) dl = dlopen(cPath, RTLD_LAZY | RTLD_GLOBAL); /* try global if local failed */
if (!dl) Rf_error("cannot load '%s' dynamically", cPath);
fn = dlsym(dl, "create_audio_driver");
if (!fn) fn = dlsym(dl, "_create_audio_driver");
if (!fn) {
dlclose(dl);
Rf_error("specified module is not an audio driver");
}
ad = fn();
if (!ad) {
dlclose(dl);
Rf_error("audio driver could not be initialized");
}
/* FIXME: we never unload the driver module ... */
drv = (audio_driver_t*) ad;
if (!drv) Rf_error("unable to initialize the audio driver");
if (drv->length != sizeof(audio_driver_t)) Rf_error("the driver is incompatible with this version of the audio package");
current_driver = drv;
return Rf_mkString(current_driver->name);
} else
Rf_error("invalid module name");
#else
Rf_error("dynamic loading is not supported on this system");
#endif
return R_NilValue;
}
SEXP audio_use_driver(SEXP sName) {
if (sName == R_NilValue) { /* equivalent to saying 'load default driver' */
if (!current_driver) load_default_audio_driver(1);
current_driver = audio_drivers.driver;
if (!current_driver || !current_driver->name) {
Rf_warning("no audio drivers are available");
return R_NilValue;
}
return Rf_mkString(current_driver->name);
}
if (TYPEOF(sName) != STRSXP || LENGTH(sName) < 1)
Rf_error("invalid audio driver name");
else {
const char *drv_name = CHAR(STRING_ELT(sName, 0));
audio_driver_list_t *l = &audio_drivers;
if (!current_driver)
load_default_audio_driver(1);
while (l && l->driver) {
if (l->driver->name && !strcmp(l->driver->name, drv_name)) {
current_driver = l->driver;
return sName;
}
l = l->next;
}
Rf_warning("driver '%s' not found", drv_name);
}
return R_NilValue;
}
BB* BBTransform::lowerExpect(Code* code, BB* src, BB::Instrs::iterator position,
Value* condition, bool expected, BB* deoptBlock,
const std::string& debugMessage) {
auto split = BBTransform::split(code->nextBBId++, src, position + 1, code);
static SEXP print = Rf_findFun(Rf_install("cat"), R_GlobalEnv);
if (debugMessage.size() != 0) {
BB* debug = new BB(code, code->nextBBId++);
SEXP msg = Rf_mkString(debugMessage.c_str());
auto ldprint = new LdConst(print);
auto ldmsg = new LdConst(msg);
debug->append(ldmsg);
debug->append(ldprint);
debug->append(new Call(Env::elided(), ldprint, {ldmsg},
Tombstone::framestate(), 0));
debug->setNext(deoptBlock);
deoptBlock = debug;
}
src->replace(position, new Branch(condition));
if (expected) {
src->next1 = deoptBlock;
src->next0 = split;
} else {
src->next0 = deoptBlock;
src->next1 = split;
}
splitEdge(code->nextBBId++, src, deoptBlock, code);
return split;
}
SEXP jr_data_frame(jl_value_t *tt)
{
SEXP ans = R_NilValue;
SEXP rnames, d;
jl_array_t *names = (jl_array_t *) jl_get_nth_field(jl_get_nth_field(tt, 1), 1);
jl_array_t *columns = (jl_array_t *) jl_get_nth_field(tt, 0);
JL_GC_PUSH2(&names, &columns);
size_t n = jl_array_len(jl_get_nth_field(jl_arrayref(columns, 0), 0));
size_t m = jl_array_len(columns);
PROTECT(ans = Rf_allocVector(VECSXP, m));
PROTECT(rnames = Rf_allocVector(STRSXP, m));
for(size_t i=0; i<m; i++)
{
SET_VECTOR_ELT(ans, i, jr_data_array((jl_value_t *) jl_arrayref(columns, i)));
SET_STRING_ELT(rnames, i, Rf_mkChar(((jl_sym_t *) jl_arrayref(names, i))->name));
}
Rf_setAttrib(ans, R_NamesSymbol, rnames);
Rf_setAttrib(ans, R_ClassSymbol, Rf_mkString("data.frame"));
d = PROTECT(Rf_allocVector(INTSXP ,n));
for(size_t i=0; i<n; i++){
INTEGER(d)[i] = i+1;
}
Rf_setAttrib(ans, R_RowNamesSymbol, d);
UNPROTECT(3);
JL_GC_POP();
return ans;
}
SEXP R_mpc_mul(SEXP e1, SEXP e2) {
/* N.B. We always use signed integers for e2 given R's type system. */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_mul(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_mul_si(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_mul_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc multiplication.");
}
} else {
Rf_error("Invalid first operand for MPC multiplication.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP R_mpc_pow(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_pow(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_si(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_d(*z, *z1, REAL(e2)[0], Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc power.");
}
} else {
Rf_error("Invalid first operand for MPC power.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP audio_driver_descr(SEXP instance) {
if (TYPEOF(instance) != EXTPTRSXP)
Rf_error("invalid audio instance");
audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance);
if (!p) Rf_error("invalid audio instance");
return Rf_mkString(p->driver->descr);
}
SEXP R_get_function(char *fname)
{
SEXP expr, res;
int error;
printf("fname: %s\n", fname);
SEXP robj = Rf_findVar(Rf_install(fname), R_GlobalEnv);
if (robj == R_UnboundValue)
return R_NilValue;
robj = Rf_findFun(Rf_install(fname), R_GlobalEnv);
printf("VALUE: \n");
Rf_PrintValue(robj);
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, install("get"));
SETCAR(CDR(expr), Rf_mkString(fname));
res = R_tryEval(expr, R_GlobalEnv, &error);
// Rf_PrintValue(res);
if (error) {
// rb_raise(rb_eRException, "R execution exception. %s", expr);
UNPROTECT(1);
return NULL;
}
UNPROTECT(1);
return res;
}
SEXP ocl_get_device_info_char(SEXP device, SEXP item) {
cl_device_id device_id = getDeviceID(device);
cl_device_info pn = (cl_device_info) Rf_asInteger(item);
*infobuf = 0;
if ((last_ocl_error = clGetDeviceInfo(device_id, pn, sizeof(infobuf), &infobuf, NULL)) != CL_SUCCESS)
ocl_err("clGetDeviceInfo");
return Rf_mkString(infobuf);
}
/* MakeMPC - Create an MPC ExternalPtr object for R based on a C mpc_t.
*
* Args:
* z - An mpc_t pointer.
* Returns:
* An S3 object of type "mpc" containing the external pointer to z.
*/
SEXP MakeMPC(mpc_t *z) {
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP ocl_get_device_info_char(SEXP device, SEXP item) {
char buf[512];
cl_device_id device_id = getDeviceID(device);
cl_device_info pn = (cl_device_info) Rf_asInteger(item);
buf[0] = 0;
if (clGetDeviceInfo(device_id, pn, sizeof(buf), &buf, NULL) != CL_SUCCESS)
ocl_err("clGetDeviceInfo");
return Rf_mkString(buf);
}
template <> SEXP wrap(const RcppDateVector& datevec) {
SEXP value = PROTECT(Rf_allocVector(REALSXP, datevec.size()));
double* p = REAL(value) ;
for (int i = 0; i < datevec.size(); i++,p++) {
*p = datevec(i).getJDN() - RcppDate::Jan1970Offset;
}
Rf_setAttrib(value, R_ClassSymbol, Rf_mkString("Date"));
UNPROTECT(1);
return value;
}
// only used for debugging
SEXP get_rcpp_cache() {
if( ! Rcpp_cache_know ){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
Rcpp_cache_know = true ;
}
return Rcpp_cache ;
}
void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn) {
SEXP ptr = PROTECT(R_MakeExternalPtrFn(fn, R_NilValue, R_NilValue));
SEXP ptr_obj = PROTECT(Rf_allocVector(VECSXP, 1));
SET_VECTOR_ELT(ptr_obj, 0, ptr);
Rf_setAttrib(ptr_obj, R_ClassSymbol, Rf_mkString("fn_pointer"));
Rf_defineVar(Rf_install(ptr_name), ptr_obj, rlang_namespace(ns));
UNPROTECT(2);
}
static au_instance_t *audiounits_create_recorder(SEXP source, float rate, int chs, int flags) {
UInt32 propsize=0;
OSStatus err;
au_instance_t *ap = (au_instance_t*) calloc(sizeof(au_instance_t), 1);
ap->source = source;
ap->sample_rate = rate;
ap->done = NO;
ap->position = 0;
ap->length = LENGTH(source);
ap->stereo = (chs == 2) ? YES : NO;
propsize = sizeof(ap->inDev);
err = AudioHardwareGetProperty(kAudioHardwarePropertyDefaultInputDevice, &propsize, &ap->inDev);
if (err) {
free(ap);
Rf_error("unable to find default audio input (%08x)", err);
}
propsize = sizeof(ap->fmtIn);
err = AudioDeviceGetProperty(ap->inDev, 0, YES, kAudioDevicePropertyStreamFormat, &propsize, &ap->fmtIn);
if (err) {
free(ap);
Rf_error("unable to retrieve audio input format (%08x)", err);
}
/* Rprintf(" recording format: %f, chs: %d, fpp: %d, bpp: %d, bpf: %d, flags: %x\n", ap->fmtIn.mSampleRate, ap->fmtIn.mChannelsPerFrame, ap->fmtIn.mFramesPerPacket, ap->fmtIn.mBytesPerPacket, ap->fmtIn.mBytesPerFrame, ap->fmtIn.mFormatFlags); */
ap->srFrac = 1.0;
if (ap->fmtIn.mSampleRate != ap->sample_rate) ap->srFrac = ap->sample_rate / ap->fmtIn.mSampleRate;
ap->srRun = 0.0;
#if defined(MAC_OS_X_VERSION_10_5) && (MAC_OS_X_VERSION_MIN_REQUIRED>=MAC_OS_X_VERSION_10_5)
err = AudioDeviceCreateIOProcID(ap->inDev, inputRenderProc, ap, &ap->inIOProcID );
#else
err = AudioDeviceAddIOProc(ap->inDev, inputRenderProc, ap);
#endif
if (err) {
free(ap);
Rf_error("unable to register recording callback (%08x)", err);
}
R_PreserveObject(ap->source);
Rf_setAttrib(ap->source, Rf_install("rate"), Rf_ScalarInteger(rate)); /* we adjust the rate */
Rf_setAttrib(ap->source, Rf_install("bits"), Rf_ScalarInteger(16)); /* we say it's 16 because we don't know - float is always 32-bit */
Rf_setAttrib(ap->source, Rf_install("class"), Rf_mkString("audioSample"));
if (ap->stereo) {
SEXP dim = Rf_allocVector(INTSXP, 2);
INTEGER(dim)[0] = 2;
INTEGER(dim)[1] = LENGTH(ap->source) / 2;
Rf_setAttrib(ap->source, R_DimSymbol, dim);
}
return ap;
}
SEXP R_mongo_get_default_database(SEXP ptr_client) {
mongoc_client_t *client = r2client(ptr_client);
mongoc_database_t *db = mongoc_client_get_default_database(client);
if(db){
SEXP out = PROTECT(Rf_mkString(mongoc_database_get_name(db)));
mongoc_database_destroy(db);
UNPROTECT(1);
return out;
} else {
return R_NilValue;
}
}
// only used for debugging
SEXP get_rcpp_cache() {
if( ! Rcpp_cache_know ){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
Rcpp_cache_know = true ;
Rcpp_protection_stack = VECTOR_ELT(Rcpp_cache, RCPP_PROTECTION_STACK_INDEX) ;
UNPROTECT(1) ;
}
return Rcpp_cache ;
}
void plot::save_snapshot_variable() {
rhost::util::errors_to_exceptions([&] {
pGEDevDesc ge_dev_desc = Rf_desc2GEDesc(_device_desc);
SEXP snapshot = Rf_protect(GEcreateSnapshot(ge_dev_desc));
SEXP klass = Rf_protect(Rf_mkString("recordedplot"));
Rf_classgets(snapshot, klass);
Rf_defineVar(Rf_install(_snapshot_varname.c_str()), snapshot, R_GlobalEnv);
Rf_unprotect(2);
});
}
SEXP print_mpc(SEXP ptr) {
mpc_ptr z = (mpc_ptr)R_ExternalPtrAddr(ptr);
SEXP retVal;
Rprintf("Rounding: %s\n",
CHAR(STRING_ELT(Rf_GetOption(Rf_install("mpc.rounding"),
R_BaseEnv), 0)));
if (z) {
char *mystring = mpc_get_str(10, 0, z, Rmpc_get_rounding());
PROTECT(retVal = Rf_mkString(mystring));
UNPROTECT(1);
return retVal;
}
return R_NilValue;
}
static SEXP make_condition(const std::string& ex_msg, SEXP call, SEXP cppstack, SEXP classes){
Scoped<SEXP> res = Rf_allocVector( VECSXP, 3 ) ;
Scoped<SEXP> message = Rf_mkString( ex_msg.c_str() ) ;
RCPP_SET_VECTOR_ELT( res, 0, message ) ;
RCPP_SET_VECTOR_ELT( res, 1, call ) ;
RCPP_SET_VECTOR_ELT( res, 2, cppstack ) ;
Scoped<SEXP> names = Rf_allocVector( STRSXP, 3 ) ;
SET_STRING_ELT( names, 0, Rf_mkChar( "message" ) ) ;
SET_STRING_ELT( names, 1, Rf_mkChar( "call" ) ) ;
SET_STRING_ELT( names, 2, Rf_mkChar( "cppstack" ) ) ;
Rf_setAttrib( res, R_NamesSymbol, names ) ;
Rf_setAttrib( res, R_ClassSymbol, classes ) ;
return res ;
}
SEXP R_mpc_conj(SEXP x) {
if (!Rf_inherits(x, "mpc")) {
Rf_error("Invalid operand for conj.mpc");
}
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(x);
mpc_init2(*z, mpc_get_prec(*z1));
mpc_conj(*z, *z1, Rmpc_get_rounding());
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP jr_func(void* p)
{
ParseStatus status;
SEXP s, t, ext;
s = t = PROTECT(R_ParseVector(
Rf_mkString("function(...) {.External(\".RCall\", NULL, ...)}"),
-1, &status, R_NilValue));
ext = PROTECT(R_MakeExternalPtr(p, R_NilValue, R_NilValue));
SETCADDR(CADR(CADDR(VECTOR_ELT(t ,0))), ext);
int errorOccurred = 0;
SEXP ret;
ret = PROTECT(R_tryEval(VECTOR_ELT(s,0), R_GlobalEnv, &errorOccurred));
UNPROTECT(3);
return ret;
}
SEXP init_Rcpp_cache(){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp::Shield<SEXP> cache( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
// the Rcpp namespace
SET_VECTOR_ELT( cache, 0, RCPP ) ;
set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
set_current_error( cache, R_NilValue ) ; // current error
SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
return cache ;
}
void plot::set_snapshot(const rhost::util::protected_sexp& snapshot) {
// Ignore if we already created a snapshot
if (_snapshot_varname.empty()) {
_snapshot_varname = get_snapshot_varname();
}
rhost::util::errors_to_exceptions([&] {
SEXP klass = Rf_protect(Rf_mkString("recordedplot"));
Rf_classgets(snapshot.get(), klass);
SEXP duplicated_snapshot = Rf_protect(Rf_duplicate(snapshot.get()));
Rf_defineVar(Rf_install(_snapshot_varname.c_str()), duplicated_snapshot, R_GlobalEnv);
Rf_unprotect(2);
});
}
SEXP audio_player(SEXP source, SEXP rate) {
float fRate = -1.0;
if (!current_driver)
load_default_audio_driver(0);
if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP)
fRate = (float) Rf_asReal(rate);
audio_instance_t *p = current_driver->create_player(source, fRate, 0);
if (!p) Rf_error("cannot start audio driver");
p->driver = current_driver;
p->kind = AI_PLAYER;
SEXP ptr = R_MakeExternalPtr(p, R_NilValue, R_NilValue);
Rf_protect(ptr);
R_RegisterCFinalizer(ptr, audio_instance_destructor);
Rf_setAttrib(ptr, Rf_install("class"), Rf_mkString("audioInstance"));
Rf_unprotect(1);
return ptr;
}
/* convert a numeric vector to a single precision object */
SEXP double2float(SEXP dObject) {
const double *d;
float *f;
SEXP res;
int i, n;
dObject = Rf_coerceVector(dObject, REALSXP);
n = LENGTH(dObject);
d = REAL(dObject);
res = PROTECT(Rf_allocVector(RAWSXP, n * sizeof(float)));
f = (float*) RAW(res);
for (i = 0; i < n; i++)
f[i] = d[i];
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("clFloat"));
UNPROTECT(1);
return res;
}
SEXP audio_drivers_list() {
int n = 0;
SEXP res = Rf_allocVector(VECSXP, 3), sName, sDesc, /* sCopy, */ sCurr, sLN, sRN;
audio_driver_list_t *l = &audio_drivers;
if (!current_driver)
load_default_audio_driver(1);
Rf_protect(res);
if (l->driver) {
while (l) {
n++;
l = l->next;
}
}
sName = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 0, sName);
sDesc = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 1, sDesc);
sCurr = Rf_allocVector(LGLSXP, n); SET_VECTOR_ELT(res, 2, sCurr);
/* sCopy = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 3, sCopy); */
if (n) {
n = 0;
l = &audio_drivers;
while (l) {
const char *s = l->driver->name;
SET_STRING_ELT(sName, n, Rf_mkChar(s ? s : ""));
s = l->driver->descr;
SET_STRING_ELT(sDesc, n, Rf_mkChar(s ? s : ""));
s = l->driver->copyright;
/* SET_STRING_ELT(sCopy, n, Rf_mkChar(s ? s : "")); */
LOGICAL(sCurr)[n] = (l->driver == current_driver) ? 1 : 0;
l = l->next;
n++;
}
}
sLN = Rf_allocVector(STRSXP, 3);
Rf_setAttrib(res, R_NamesSymbol, sLN);
SET_STRING_ELT(sLN, 0, Rf_mkChar("name"));
SET_STRING_ELT(sLN, 1, Rf_mkChar("description"));
SET_STRING_ELT(sLN, 2, Rf_mkChar("current"));
/* SET_STRING_ELT(sLN, 3, Rf_mkChar("author")); */
sRN = Rf_allocVector(INTSXP, 2);
Rf_setAttrib(res, R_RowNamesSymbol, sRN);
INTEGER(sRN)[0] = R_NaInt;
INTEGER(sRN)[1] = -n;
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("data.frame"));
Rf_unprotect(1);
return res;
}
SEXP R_mpc_neg(SEXP e1) {
/* Garbage collector will be confused if we just call
* mpc_neg(*z, *z, ...) */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_init2(*z, mpc_get_prec(*z1));
mpc_neg(*z, *z1, Rmpc_get_rounding());
} else {
Rf_error("Invalid operands for mpc negation.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
/* set the length ofthe clFloat object, effectively resizing it */
SEXP clFloat_length_set(SEXP fObject, SEXP value) {
SEXP res;
int newLen = Rf_asInteger(value), cpy;
if (newLen == LENGTH(fObject)) return fObject;
if (newLen < 0)
Rf_error("invalid length");
if (newLen > 536870912)
Rf_error("clFloat length cannot exceed 512Mb due to R vector length limitations");
newLen *= sizeof(float);
res = PROTECT(Rf_allocVector(RAWSXP, newLen));
cpy = (newLen > LENGTH(fObject)) ? LENGTH(fObject) : newLen;
memcpy(RAW(res), RAW(fObject), cpy);
if (newLen > cpy) /* FIXME: we initialize to 0.0 - maybe we need NAs ? */
memset(RAW(res) + cpy, 0, newLen - cpy);
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("clFloat"));
UNPROTECT(1);
return res;
}
