SEXP register_pointdata(jobject pdata)
{
// get the max key and add one
int datakey = (*(std::max_element(current_pointdata.begin(), current_pointdata.end(), intmap_keycompare<jobject>))).first + 1;
current_pointdata[datakey] = pdata;
SEXP datahandle;
PROTECT(datahandle = allocVector(INTSXP, 1));
INTEGER(datahandle)[0] = datakey;
UNPROTECT(1);
// convert the local data ref into a global ref
// and assign an R finalizer to delete it when all R
// references disappear.
env->NewGlobalRef(pdata);
SEXP nhandle;
PROTECT(nhandle = R_MakeExternalPtr(NULL, datahandle, R_NilValue));
R_RegisterCFinalizer(nhandle, java_data_ref_finalizer);
UNPROTECT(1);
return nhandle;
}
SEXP initialize_hbhmat(SEXP F, SEXP window,
SEXP wmask, SEXP fmask, SEXP weights,
SEXP circular) {
hbhankel_matrix *h;
ext_matrix *e;
SEXP hbhmat, N = NILSXP;
PROTECT(N = getAttrib(F, R_DimSymbol));
/* Allocate memory */
e = Calloc(1, ext_matrix);
e->type = "hbhankel matrix";
e->mulfn = hbhankel_matmul;
e->tmulfn = hbhankel_tmatmul;
e->ncol = hbhankel_ncol;
e->nrow = hbhankel_nrow;
/* Build toeplitz circulants for hankel matrix */
h = Calloc(1, hbhankel_matrix);
initialize_circulant(h, REAL(F), length(N), INTEGER(N), INTEGER(window), LOGICAL(circular));
/* TODO: add a check for correct window sizes */
h->col_ind = alloc_area2d(wmask, N);
h->row_ind = alloc_area2d(fmask, N);
h->weights = alloc_weights(weights);
e->matrix = h;
/* We do not need to protect N anymore */
UNPROTECT(1);
/* Make an external pointer envelope */
hbhmat = R_MakeExternalPtr(e, install("external matrix"), R_NilValue);
R_RegisterCFinalizer(hbhmat, hbhmat_finalizer);
return hbhmat;
}
SEXP initialize_hmat(SEXP F, SEXP window) {
R_len_t N, L;
hankel_matrix *h;
ext_matrix *e;
SEXP hmat;
N = length(F);
L = INTEGER(window)[0];
/* Allocate memory */
e = Calloc(1, ext_matrix);
e->type = "hankel matrix";
e->mulfn = hankel_matmul;
e->tmulfn = hankel_tmatmul;
e->ncol = hankel_ncol;
e->nrow = hankel_nrow;
/* Build toeplitz circulants for hankel matrix */
h = Calloc(1, hankel_matrix);
initialize_circulant(h, REAL(F), N, L);
e->matrix = h;
/* Make an external pointer envelope */
hmat = R_MakeExternalPtr(e, install("external matrix"), R_NilValue);
R_RegisterCFinalizer(hmat, hmat_finalizer);
return hmat;
}
SEXP
R_addXMLInternalDocument_finalizer(SEXP sdoc, SEXP fun)
{
R_CFinalizer_t action;
#if R_XML_DEBUG_WEAK_REFS
LastDoc = sdoc;
#endif
void *ptr = R_ExternalPtrAddr(sdoc);
if(TYPEOF(fun) == CLOSXP) {
R_RegisterFinalizer(sdoc, fun);
return(sdoc);
}
if(fun == R_NilValue) {
action = R_xmlFreeDoc;
} else if(TYPEOF(fun) == EXTPTRSXP)
action = (R_CFinalizer_t) R_ExternalPtrAddr(fun);
R_RegisterCFinalizer(sdoc, action);
#ifdef R_XML_DEBUG_WEAK_REFS
int status = R_findExtPtrWeakRef(ptr);
fprintf(stderr, "is weak ref %d\n", status);
#endif
return(sdoc);
}
SEXP NewPorStream (SEXP name){
#ifdef DEBUG
Rprintf("\nNewPorStream");
#endif
PROTECT(name = coerceVector(name,STRSXP));
// porStreamBuf *b = (porStreamBuf *)S_alloc(1,sizeof(porStreamBuf));
porStreamBuf *b = Calloc(1,porStreamBuf);
initPorStreamBuf(b);
b->f = fopen(CHAR(STRING_ELT(name, 0)),"rb");
#ifdef DEBUG
Rprintf("\nfile = %d",b->f);
#endif
if(b->f == NULL){
Free(b);
UNPROTECT(1);
return R_NilValue;
}
else {
fillPorStreamBuf(b);
SEXP ans = R_MakeExternalPtr(b, install("porStreamBuf"), R_NilValue);
PROTECT(ans);
R_RegisterCFinalizer(ans, (R_CFinalizer_t) closePorStream);
setAttrib(ans,install("file.name"),name);
UNPROTECT(2);
return ans;
}
}
SEXP initialize_hbhmat(SEXP F, SEXP windowx, SEXP windowy) {
R_len_t Nx, Ny, Lx, Ly;
hbhankel_matrix *h;
ext_matrix *e;
SEXP hbhmat;
int *dimF = INTEGER(getAttrib(F, R_DimSymbol));
Nx = dimF[0]; Ny = dimF[1];
Lx = INTEGER(windowx)[0]; Ly = INTEGER(windowy)[0];
/* Allocate memory */
e = Calloc(1, ext_matrix);
e->type = "hbhankel matrix";
e->mulfn = hbhankel_matmul;
e->tmulfn = hbhankel_tmatmul;
e->ncol = hbhankel_ncol;
e->nrow = hbhankel_nrow;
/* Build toeplitz circulants for hankel matrix */
h = Calloc(1, hbhankel_matrix);
initialize_circulant(h, REAL(F), Nx, Ny, Lx, Ly);
e->matrix = h;
/* Make an external pointer envelope */
hbhmat = R_MakeExternalPtr(e, install("external matrix"), R_NilValue);
R_RegisterCFinalizer(hbhmat, hbhmat_finalizer);
return hbhmat;
}
SEXP r_make_dt_obj_cont(SEXP cache, SEXP r_ic, SEXP r_br) {
SEXP info = getListElement(cache, "info");
int
neq = INTEGER(getListElement(info, "ny"))[0],
np = INTEGER(getListElement(info, "np"))[0];
/* Initial conditions and branches functions */
DtIcFun ic = (DtIcFun) R_ExternalPtrAddr(r_ic);
DtBrFun br = (DtBrFun) R_ExternalPtrAddr(r_br);
/* Return object */
dt_obj_cont *obj;
SEXP extPtr;
obj = (dt_obj_cont *)Calloc(1, dt_obj_cont);
obj->neq = neq;
obj->n_out = LENGTH(getListElement(cache, "len"));
obj->np = np;
obj->root = INTEGER(getListElement(cache, "root"))[0];
obj->ic = ic;
obj->br = br;
/* Set up storage */
obj->init = (double *)Calloc(obj->n_out * neq, double);
obj->base = (double *)Calloc(obj->n_out * neq, double);
obj->lq = (double *)Calloc(obj->n_out, double);
/* Set up tips and internal branches */
dt_cont_setup_tips(obj, cache);
dt_cont_setup_internal(obj, cache);
extPtr = R_MakeExternalPtr(obj, R_NilValue, R_NilValue);
R_RegisterCFinalizer(extPtr, dt_obj_cont_finalize);
return extPtr;
}
SEXP initialize_rextmat(SEXP f, SEXP tf, SEXP n, SEXP m, SEXP rho) {
ext_matrix *e;
rext_matrix *re;
SEXP emat;
/* Allocate memory */
re = Calloc(1, rext_matrix);
re->n = asInteger(n);
re->m = asInteger(m);
/* Create external matrix envelope */
e = Calloc(1, ext_matrix);
e->type = "external matrix from R";
e->mulfn = rextmat_matmul;
e->tmulfn = rextmat_tmatmul;
e->ncol = rextmat_ncol;
e->nrow = rextmat_nrow;
e->matrix = re;
/* Make an external pointer envelope */
PROTECT(emat = R_MakeExternalPtr(e, install("external matrix"), R_NilValue));
/* Attach the fields */
PROTECT(re->fcall = R_MakeWeakRef(emat, lang2(f, R_NilValue), R_NilValue, 1));
PROTECT(re->tfcall = R_MakeWeakRef(emat, lang2(tf, R_NilValue), R_NilValue, 1));
PROTECT(re->rho = R_MakeWeakRef(emat, rho, R_NilValue, 1));
R_RegisterCFinalizer(emat, rextmat_finalizer);
UNPROTECT(4);
return emat;
}
static SEXP
Rf_MakeRegisteredNativeSymbol(R_RegisteredNativeSymbol *symbol)
{
SEXP ref, klass;
R_RegisteredNativeSymbol *copy;
copy = (R_RegisteredNativeSymbol *) malloc(1 * sizeof(R_RegisteredNativeSymbol));
if(!copy) {
error(ngettext("cannot allocate memory for registered native symbol (%d byte)",
"cannot allocate memory for registered native symbol (%d bytes)",
(int) sizeof(R_RegisteredNativeSymbol)),
(int) sizeof(R_RegisteredNativeSymbol));
}
*copy = *symbol;
PROTECT(ref = R_MakeExternalPtr(copy,
R_registered_native_symbol,
R_NilValue));
R_RegisterCFinalizer(ref, freeRegisteredNativeSymbolCopy);
PROTECT(klass = mkString("RegisteredNativeSymbol"));
setAttrib(ref, R_ClassSymbol, klass);
UNPROTECT(2);
return(ref);
}
SEXP r_make_quasse_fft(SEXP r_nx, SEXP r_dx, SEXP r_nd, SEXP r_flags) {
quasse_fft *obj;
SEXP extPtr;
int nx = INTEGER(r_nx)[0];
double dx = REAL(r_dx)[0];
int n_fft = LENGTH(r_nd);
int i;
int flags;
int *nd = (int*)calloc(n_fft, sizeof(int));
for ( i = 0; i < n_fft; i++ )
nd[i] = INTEGER(r_nd)[i];
/* Simple interface to FFTW's flags */
if ( INTEGER(r_flags)[0] == -1 )
flags = FFTW_ESTIMATE;
else if ( INTEGER(r_flags)[0] == 1 )
flags = FFTW_PATIENT;
else if ( INTEGER(r_flags)[0] == 2 )
flags = FFTW_EXHAUSTIVE;
else
flags = FFTW_MEASURE;
obj = make_quasse_fft(n_fft, nx, dx, nd, flags);
extPtr = R_MakeExternalPtr(obj, R_NilValue, R_NilValue);
R_RegisterCFinalizer(extPtr, quasse_fft_finalize);
return extPtr;
}
/* {{{ rberkeley_db_set_errfile */
SEXP rberkeley_db_set_errfile (SEXP _dbp, SEXP _errfile)
{
DB *dbp;
FILE *errfile = NULL;
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_errfile)) {
/* highly unlikely to be portable --- FIXME */
errfile = fopen(CHAR(STRING_ELT(_errfile,0)),"w");
if(errfile == NULL)
error("open failed!\n");
} else errfile = NULL;
dbp->set_errfile(dbp, errfile);
if(errfile == NULL) {
return R_NilValue;
} else {
SEXP ptr = R_MakeExternalPtr(errfile, install("errfile"), ScalarLogical(TRUE));
R_RegisterCFinalizer(ptr, (R_CFinalizer_t) rberkeley_fclose);
return ptr;
}
}
// internal use only
SEXP register_stream(jobject stream)
{
// get the max key and add one
int streamkey = (*(std::max_element(current_streams.begin(), current_streams.end(), intmap_keycompare<jobject>))).first + 1;
current_streams[streamkey] = stream;
SEXP streamhandle;
PROTECT(streamhandle = allocVector(INTSXP, 1));
INTEGER(streamhandle)[0] = streamkey;
UNPROTECT(1);
// convert the local stream ref into a global stream ref
// and assign an R finalizer to delete it when all R
// references disappear.
env->NewGlobalRef(stream);
SEXP nhandle;
PROTECT(nhandle = R_MakeExternalPtr(NULL, streamhandle, R_NilValue));
R_RegisterCFinalizer(nhandle, java_stream_ref_finalizer);
UNPROTECT(1);
return nhandle;;
}
static SEXP makeRTclObject(Tcl_Obj *tclobj)
{
SEXP obj;
obj = R_MakeExternalPtr(tclobj, R_NilValue, R_NilValue);
Tcl_IncrRefCount(tclobj);
R_RegisterCFinalizer(obj, RTcl_dec_refcount);
return obj;
}
USER_OBJECT_
toRPointerWithFinalizer(gconstpointer val, const gchar *typeName, RPointerFinalizer finalizer)
{
USER_OBJECT_ ans;
USER_OBJECT_ r_finalizer = NULL_USER_OBJECT;
USER_OBJECT_ klass = NULL, rgtk_class;
int i = 0;
GType type = 0;
if(!val)
return(NULL_USER_OBJECT);
if (finalizer) {
PROTECT(r_finalizer = R_MakeExternalPtr(finalizer, NULL_USER_OBJECT, NULL_USER_OBJECT));
}
PROTECT(ans = R_MakeExternalPtr((gpointer)val, r_finalizer, NULL_USER_OBJECT));
if (finalizer) {
R_RegisterCFinalizer(ans, RGtk_finalizer);
}
if (typeName)
type = g_type_from_name(typeName);
if(type) {
if (G_TYPE_IS_INSTANTIATABLE(type) || G_TYPE_IS_INTERFACE(type))
type = G_TYPE_FROM_INSTANCE(val);
if (G_TYPE_IS_DERIVED(type)) {
setAttrib(ans, install("interfaces"), R_internal_getInterfaces(type));
PROTECT(klass = R_internal_getGTypeAncestors(type));
}
}
if (!klass && typeName) {
PROTECT(klass = asRString(typeName));
}
if (klass) { /* so much trouble just to add "RGtkObject" onto the end */
PROTECT(rgtk_class = NEW_CHARACTER(GET_LENGTH(klass)+1));
for (i = 0; i < GET_LENGTH(klass); i++)
SET_STRING_ELT(rgtk_class, i, STRING_ELT(klass, i));
} else {
PROTECT(rgtk_class = NEW_CHARACTER(1));
}
SET_STRING_ELT(rgtk_class, i, COPY_TO_USER_STRING("RGtkObject"));
SET_CLASS(ans, rgtk_class);
if (g_type_is_a(type, S_TYPE_G_OBJECT)) {
USER_OBJECT_ public_sym = install(".public");
setAttrib(ans, public_sym, findVar(public_sym, S_GOBJECT_GET_ENV(val)));
}
if (klass)
UNPROTECT(1);
if (finalizer)
UNPROTECT(1);
UNPROTECT(2);
return(ans);
}
SEXP
makeCIFSEXP(ffi_cif *ptr, ffi_type **argTypes, ffi_type *retType, SEXP r_obj, SEXP pointerInputs)
{
SEXP tmp;
SET_SLOT(r_obj, Rf_install("ref"), tmp = R_MakeExternalPtr(ptr, Rf_install("ffi_cif"), R_NilValue));
R_RegisterCFinalizer(tmp, releaseCIF);
SET_SLOT(r_obj, Rf_install("pointerParameters"), pointerInputs);
return(r_obj);
}
SEXP R_RngStreams_Clone (SEXP R_obj, SEXP R_stream, SEXP R_name)
/*----------------------------------------------------------------------*/
/* Make a clone (copy) of Stream object. */
/* */
/* parameters: */
/* obj ... (S4 class) ... rstream object */
/* R_stream ... (pointer) ... pointer the Stream object */
/* R_name ... (string) ... name of the Stream */
/* */
/* return: */
/* pointer to cloned Stream object */
/*----------------------------------------------------------------------*/
{
SEXP R_clone;
RngStream stream, clone;
const char *name;
size_t len;
/* check argument */
CHECK_STREAM_PTR(R_stream);
if (!R_name || TYPEOF(R_name) != STRSXP)
error("bad string\n");
/* Extract pointer to Stream */
stream = R_ExternalPtrAddr(R_stream);
CHECK_NULL(stream);
/* get pointer to argument string */
name = CHAR(STRING_ELT(R_name,0));
/* make clone */
clone = malloc(sizeof(struct RngStream_InfoState));
if (clone == NULL)
error("no more memory\n");
memcpy(clone,stream,sizeof(struct RngStream_InfoState));
/* we also need a name */
len = strlen(name);
clone->name = malloc(len + 1);
if (clone->name == NULL) {
free(clone);
error("no more memory\n");
}
strncpy(clone->name, name, len+1);
/* make R external pointer and store pointer to Stream generator */
PROTECT(R_clone = R_MakeExternalPtr(clone, RngStreams_tag(), R_obj));
UNPROTECT(1);
/* register destructor as C finalizer */
R_RegisterCFinalizer(R_clone, R_RngStreams_free);
/* return pointer to R */
return R_clone;
} /* end of R_RngStreams_Clone() */
SEXP
rsbml_create_doc_ptr(SBMLDocument_t *doc)
{
SEXP r_doc, class_vector;
PROTECT(class_vector = NEW_CHARACTER(1));
SET_STRING_ELT(class_vector, 0, mkChar("SBMLDocument"));
r_doc = R_MakeExternalPtr(doc, R_NilValue, R_NilValue);
R_RegisterCFinalizer(r_doc, (R_CFinalizer_t)rsbml_R_free_doc);
SET_CLASS(r_doc, class_vector);
UNPROTECT(1);
return r_doc;
}
USER_OBJECT_
makeForeignPerlReference(SV *ref, USER_OBJECT_ classes, ForeignReferenceTable *table)
{
int n;
USER_OBJECT_ rsRef, el;
char *key;
dTHX;
#ifdef USE_NEW_PERL_REFERENCES
SvREFCNT_inc(ref);
/* We make this into a list with the external pointer inside it as the first element
as some of the R code wants to treat it like a list. We will gradually remove this.*/
rsRef = NEW_LIST(1);
PROTECT(rsRef);
SET_VECTOR_ELT(rsRef, 0, el = R_MakeExternalPtr((void *) ref, Rf_install("PerlReference"), R_NilValue));
R_RegisterCFinalizer(el, Rperl_ReleaseReference);
SET_NAMES(rsRef, mkString("ref"));
if(GET_LENGTH(classes)) {
SET_CLASS(rsRef, classes);
}
UNPROTECT(1);
#else
if(table == NULL)
table= &exportReferenceTable;
if(table->entries == NULL) {
table->entries = newHV();
SvREFCNT_inc(table->entries);
n = 0;
} else
n = table->numReferences;
key = (char *) calloc(15, sizeof(char));
if(!key) {
PROBLEM "Cannot allocaate 15 bytes for perl foreign reference key"
ERROR;
}
sprintf(key, "%ld", (long) n);
hv_store(table->entries, key, strlen(key), ref, 0);
SvREFCNT_inc(ref);
table->numReferences++;
rsRef = makeRSReferenceObject(key, classes, table);
#endif
return(rsRef);
}
SEXP wrapPointer(void *ptr, QList<QByteArray> classNames,
R_CFinalizer_t finalizer)
{
SEXP ans;
PROTECT(ans = R_MakeExternalPtr(ptr, R_NilValue, R_NilValue));
if (finalizer)
R_RegisterCFinalizer(ans, finalizer);
SEXP rclassNames = allocVector(STRSXP, classNames.size());
SET_CLASS(ans, rclassNames);
for (int i = 0; i < length(rclassNames); i++)
SET_STRING_ELT(rclassNames, i, mkChar(classNames[i].constData()));
UNPROTECT(1);
return ans;
}
SEXP buildRagraph(Agraph_t *g) {
SEXP graphRef, klass, obj;
PROTECT(graphRef = R_MakeExternalPtr(g,Rgraphviz_graph_type_tag, R_NilValue));
R_RegisterCFinalizer(graphRef, (R_CFinalizer_t)Rgraphviz_fin);
klass = PROTECT(MAKE_CLASS("Ragraph"));
PROTECT(obj = NEW_OBJECT(klass));
SET_SLOT(obj, Rf_install("agraph"), graphRef);
SET_SLOT(obj, Rf_install("laidout"), Rgraphviz_ScalarLogicalFromRbool(FALSE));
UNPROTECT(3);
return(obj);
}
/*XXX Is this used or is it in SWinTypeLibs. */
SEXP
R_createRTypeLib(void *ref)
{
SEXP ans, obj, klass;
PROTECT(ans = R_MakeExternalPtr((void*) ref, R_ITypeLibSym, R_ITypeLibSym));
R_RegisterCFinalizer(ans, R_typelib_finalizer);
klass = MAKE_CLASS("ITypeLib");
PROTECT(obj = duplicate(NEW(klass)));
SET_SLOT(obj, Rf_install("ref"), ans);
UNPROTECT(2);
return(obj);
}
SEXP make_internal_distance_array(SEXP dmatrix, SEXP buflen)
{
if(buflen < 0)
return(R_NilValue);
jobject pdata = create_direct_buffer(dmatrix, buflen);
SEXP nhandle = register_pointdata(pdata);
// Add finalizer to the handle to clean up the matrix memory, and
// add matrix to the projected objects list.
protected_objects[*INTEGER(R_ExternalPtrTag(nhandle))] = dmatrix;
R_RegisterCFinalizer(nhandle, matrix_finalizer);
return nhandle;
}
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;
}
SEXP cr_connect(SEXP sHost, SEXP sPort, SEXP sTimeout, SEXP sReconnect, SEXP sRetry) {
const char *host = "localhost";
double tout = Rf_asReal(sTimeout);
int port = Rf_asInteger(sPort), reconnect = (Rf_asInteger(sReconnect) > 0),
retry = (Rf_asInteger(sRetry) > 0);
redisContext *ctx;
rconn_t *c;
SEXP res;
struct timeval tv;
if (TYPEOF(sHost) == STRSXP && LENGTH(sHost) > 0)
host = CHAR(STRING_ELT(sHost, 0));
tv.tv_sec = (int) tout;
tv.tv_usec = (tout - (double)tv.tv_sec) * 1000000.0;
if (port < 1)
ctx = redisConnectUnixWithTimeout(host, tv);
else
ctx = redisConnectWithTimeout(host, port, tv);
if (!ctx) Rf_error("connect to redis failed (NULL context)");
if (ctx->err){
SEXP es = Rf_mkChar(ctx->errstr);
redisFree(ctx);
Rf_error("connect to redis failed: %s", CHAR(es));
}
c = malloc(sizeof(rconn_t));
if (!c) {
redisFree(ctx);
Rf_error("unable to allocate connection context");
}
c->rc = ctx;
c->flags = (reconnect ? RCF_RECONNECT : 0) | (retry ? RCF_RETRY : 0);
c->host = strdup(host);
c->port = port;
c->timeout = tout;
redisSetTimeout(ctx, tv);
res = PROTECT(R_MakeExternalPtr(c, R_NilValue, R_NilValue));
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("redisConnection"));
R_RegisterCFinalizer(res, rconn_fin);
UNPROTECT(1);
return res;
}
SEXP
R_wxSize_new(SEXP r_width, SEXP r_height, SEXP r_addFinalizer)
{
int width = asInteger(r_width);
int height = asInteger(r_height);
R_CFinalizer_t finalizer = NULL;
wxSize *ans = new wxSize(width, height);
SEXP r_ans = R_make_wx_Ref(ans, "wxSize");
if(TYPEOF(r_addFinalizer) == LGLSXP && LOGICAL(r_addFinalizer)[0])
finalizer = R_finalize_wxSize;
if(finalizer) {
SEXP tmp = GET_SLOT(r_ans, Rf_install("ref"));
R_RegisterCFinalizer(tmp, finalizer);
}
return(r_ans);
}
SEXP R_RngStreams_Init (SEXP R_obj, SEXP R_name)
/*----------------------------------------------------------------------*/
/* Create and initialize Stream generator object. */
/* */
/* parameters: */
/* obj ... (S4 class) ... rstream object */
/* R_name ... (string) ... name of the Stream */
/* */
/* return: */
/* pointer to Stream object */
/*----------------------------------------------------------------------*/
{
SEXP R_newstream;
RngStream newstream; /* Notice: RngStream is a pointer to a structure */
const char *name;
/* check argument */
if (!R_name || TYPEOF(R_name) != STRSXP)
error("bad string\n");
/* get pointer to argument string */
name = CHAR(STRING_ELT(R_name,0));
/* create Stream generator object */
newstream = RngStream_CreateStream(name);
/* this must not be a NULL pointer */
if (newstream == NULL)
error("cannot create Stream object\n");
/* make R external pointer and store pointer to Stream generator */
PROTECT(R_newstream = R_MakeExternalPtr(newstream, RngStreams_tag(), R_obj));
UNPROTECT(1);
/* register destructor as C finalizer */
R_RegisterCFinalizer(R_newstream, R_RngStreams_free);
/* return pointer to R */
return R_newstream;
} /* end of R_RngStreams_init() */
SEXP audio_recorder(SEXP source, SEXP rate, SEXP channels) {
float fRate = -1.0;
int chs = Rf_asInteger(channels);
if (!current_driver)
load_default_audio_driver(0);
if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP)
fRate = (float) Rf_asReal(rate);
if (chs < 1) chs = 1;
if (!current_driver->create_recorder)
Rf_error("the currently used audio driver doesn't support recording");
audio_instance_t *p = current_driver->create_recorder(source, fRate, chs, 0);
if (!p) Rf_error("cannot start audio driver");
p->driver = current_driver;
p->kind = AI_RECORDER;
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;
}
SEXP
createRVariantObject(VARIANT *var, VARTYPE kind)
{
const char *className;
SEXP klass, ans, tmp;
VARIANT *dupvar;
switch(kind) {
case VT_DATE:
className = "DateVARIANT";
break;
case VT_CY:
className = "CurrencyVARIANT";
break;
default:
className = "VARIANT";
}
PROTECT(klass = MAKE_CLASS(className));
if(klass == NULL || klass == R_NilValue) {
PROBLEM "Can't locate S4 class definition %s", className
ERROR;
}
dupvar = (VARIANT *) malloc(sizeof(VARIANT));
VariantCopyInd(dupvar, var);
PROTECT(ans = NEW(klass));
PROTECT(tmp = R_MakeExternalPtr(dupvar, Rf_install(className), R_NilValue));
R_RegisterCFinalizer(tmp, R_Variant_finalizer);
SET_SLOT(ans, Rf_install("ref"), tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_INTEGER(1));
INTEGER(tmp)[0] = kind;
SET_SLOT(ans, Rf_install("kind"), tmp);
UNPROTECT(3);
return(ans);
}
/* {{{ rberkeley_db_set_msgfile */
SEXP rberkeley_db_set_msgfile (SEXP _dbp, SEXP _msgfile)
{
DB *dbp;
FILE *msgfile = NULL;
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_msgfile)) {
msgfile = fopen(CHAR(STRING_ELT(_msgfile,0)),"w");
if(msgfile == NULL)
error("open failed!\n");
} else msgfile = NULL;
dbp->set_msgfile(dbp, msgfile);
if(msgfile == NULL) {
return R_NilValue;
} else {
SEXP ptr = R_MakeExternalPtr(msgfile, install("msgfile"), ScalarLogical(TRUE));
R_RegisterCFinalizer(ptr, (R_CFinalizer_t) rberkeley_fclose);
return ptr;
}
}
SEXP jmoy_loaddata(SEXP nvars,
SEXP c_y,SEXP c_x,SEXP c_nobs,
SEXP uc_y,SEXP uc_x,SEXP uc_nobs)
{
Data *data;
SEXP handle;
data=(Data *)check_alloc(sizeof(Data));
data->nvars=INTEGER(nvars)[0];
data->c_nobs=INTEGER(c_nobs)[0];
data->c_y=vecdup(REAL(c_y),data->c_nobs);
data->c_x=vecdup(REAL(c_x),data->c_nobs*data->nvars);
data->uc_nobs=INTEGER(uc_nobs)[0];
data->uc_y=vecdup(REAL(uc_y),data->uc_nobs);
data->uc_x=vecdup(REAL(uc_x),data->uc_nobs*data->nvars);
handle=R_MakeExternalPtr(data,R_NilValue,R_NilValue);
PROTECT(handle);
R_RegisterCFinalizer(handle,data_finalizer);
UNPROTECT(1); /*handle*/
return handle;
}
