SEXP scan_bam_template(SEXP rname, SEXP tag)
{
if (R_NilValue != tag)
if (!IS_CHARACTER(tag))
Rf_error("'tag' must be NULL or 'character()'");
SEXP tmpl = PROTECT(NEW_LIST(N_TMPL_ELTS));
SET_VECTOR_ELT(tmpl, QNAME_IDX, NEW_CHARACTER(0));
SET_VECTOR_ELT(tmpl, FLAG_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, RNAME_IDX, rname);
SET_VECTOR_ELT(tmpl, STRAND_IDX, _tmpl_strand());
SET_VECTOR_ELT(tmpl, POS_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, QWIDTH_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, MAPQ_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, CIGAR_IDX, NEW_CHARACTER(0));
SET_VECTOR_ELT(tmpl, MRNM_IDX, rname);
SET_VECTOR_ELT(tmpl, MPOS_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, ISIZE_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, SEQ_IDX, _tmpl_DNAStringSet());
SET_VECTOR_ELT(tmpl, QUAL_IDX, _tmpl_PhredQuality());
SET_VECTOR_ELT(tmpl, PARTITION_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, MATES_IDX, NEW_INTEGER(0));
if (R_NilValue == tag) {
SET_VECTOR_ELT(tmpl, TAG_IDX, R_NilValue);
} else {
SET_VECTOR_ELT(tmpl, TAG_IDX, NEW_LIST(LENGTH(tag)));
SET_ATTR(VECTOR_ELT(tmpl, TAG_IDX), R_NamesSymbol, tag);
}
SEXP names = PROTECT(NEW_CHARACTER(N_TMPL_ELTS));
for (int i = 0; i < N_TMPL_ELTS; ++i)
SET_STRING_ELT(names, i, mkChar(TMPL_ELT_NMS[i]));
SET_ATTR(tmpl, R_NamesSymbol, names);
UNPROTECT(2);
return tmpl;
}
SEXP RS_DBI_createNamedList(char **names, SEXPTYPE *types, int *lengths, int n) {
SEXP output, output_names, obj = R_NilValue;
int num_elem;
int j;
PROTECT(output = NEW_LIST(n));
PROTECT(output_names = NEW_CHARACTER(n));
for(j = 0; j < n; j++){
num_elem = lengths[j];
switch((int)types[j]){
case LGLSXP:
PROTECT(obj = NEW_LOGICAL(num_elem));
break;
case INTSXP:
PROTECT(obj = NEW_INTEGER(num_elem));
break;
case REALSXP:
PROTECT(obj = NEW_NUMERIC(num_elem));
break;
case STRSXP:
PROTECT(obj = NEW_CHARACTER(num_elem));
break;
case VECSXP:
PROTECT(obj = NEW_LIST(num_elem));
break;
default:
error("unsupported data type");
}
SET_ELEMENT(output, (int)j, obj);
SET_CHR_EL(output_names, j, mkChar(names[j]));
}
SET_NAMES(output, output_names);
UNPROTECT(n+2);
return(output);
}
USER_OBJECT_
asRCairoPath(cairo_path_t *path)
{
static gchar *pathNames[] = { "status", "data", NULL };
cairo_path_data_t *data;
gint i, j;
USER_OBJECT_ s_path, s_data;
PROTECT(s_path = NEW_LIST(2));
SET_VECTOR_ELT(s_path, 0, asREnum(path->status, CAIRO_TYPE_STATUS));
for (i = 0, j = 0; i < path->num_data; i++, j++) {
i += path->data[i].header.length;
}
s_data = NEW_LIST(j);
SET_VECTOR_ELT(s_path, 1, s_data);
for (i = 0, j = 0; i < path->num_data; i+= data->header.length, j++) {
USER_OBJECT_ s_data_el = NULL_USER_OBJECT;
data = &path->data[i];
switch(data->header.type) {
case CAIRO_PATH_MOVE_TO:
case CAIRO_PATH_LINE_TO:
PROTECT(s_data_el = NEW_INTEGER(2));
INTEGER_DATA(s_data_el)[0] = data[1].point.x;
INTEGER_DATA(s_data_el)[1] = data[1].point.y;
break;
case CAIRO_PATH_CURVE_TO:
PROTECT(s_data_el = NEW_INTEGER(6));
INTEGER_DATA(s_data_el)[0] = data[1].point.x;
INTEGER_DATA(s_data_el)[1] = data[1].point.y;
INTEGER_DATA(s_data_el)[2] = data[2].point.x;
INTEGER_DATA(s_data_el)[3] = data[2].point.y;
INTEGER_DATA(s_data_el)[4] = data[3].point.x;
INTEGER_DATA(s_data_el)[5] = data[3].point.y;
break;
case CAIRO_PATH_CLOSE_PATH:
PROTECT(s_data_el = NEW_INTEGER(0));
break;
default:
PROBLEM "Converting Cairo path: did not understand type %d", data->header.type
ERROR;
}
setAttrib(s_data_el, install("type"), asRInteger(data->header.type));
UNPROTECT(1);
SET_VECTOR_ELT(s_data, j, s_data_el);
}
SET_NAMES(s_path, asRStringArray(pathNames));
UNPROTECT(1);
return(s_path);
}
/*
Loop over all the key-value pairs and convert
them to string and USER_OBJECT_ and put the latter
into an R/S LIST and use the vector of keys as the names.
*/
USER_OBJECT_
fromPerlHV(HV *table, unsigned int depth)
{
I32 len;
char *key;
SV *el;
I32 n, i;
Rboolean sameType;
svtype elType;
dTHX;
USER_OBJECT_ names, ans;
sameType = isHomogeneous((SV*)table, &elType);
if(sameType && isPerlPrimitiveType(elType, (SV *)table)) {
return(fromHomogeneousTable((SV *) table, elType));
}
n = hv_iterinit(table);
i = 0;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_LIST(n));
while(i < n) {
el = hv_iternextsv(table, &key, &len);
if(key == NULL)
break;
SET_VECTOR_ELT(ans, i, fromPerl(el, TRUE));
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key));
i++;
}
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
USER_OBJECT_
R_libxmlTypeTable_names(USER_OBJECT_ table, USER_OBJECT_ s_elType)
{
xmlHashTablePtr t;
int n = 0, ctr = 0;
int getElements = GET_LENGTH(s_elType) > 0;
HashGatherer d = {0, NULL_USER_OBJECT, NULL_USER_OBJECT, NULL};
t = R_getExternalRef(table, NULL); /* R_libxmlTypeTableGetRef(table); */
n = xmlHashSize(t);
PROTECT(d.names = NEW_CHARACTER(n)); ctr++;
if(getElements) {
PROTECT(d.els = NEW_LIST(n)); ctr++;
d.elType = (char *) CHAR_DEREF(STRING_ELT(s_elType, 0));
}
xmlHashScan(t, getKeys, &d);
if(getElements)
SET_NAMES(d.els, d.names);
else
d.els = d.names;
UNPROTECT(ctr);
return(d.els);
}
SEXP
R_Module_getNamedMDList(SEXP r_mod)
{
llvm::Module *mod = GET_REF(r_mod, Module);
const llvm::Module::NamedMDListType &node = mod->getNamedMDList();
int n = node.size();
R_xlen_t i = 0;
if(n == 0)
return(R_NilValue);
SEXP rans, names;
PROTECT(rans = NEW_LIST(n));
PROTECT(names = NEW_CHARACTER(n));
for(llvm::iplist<const llvm::NamedMDNode>::iterator it = node.begin(); it != node.end(); it++, i++) {
const llvm::NamedMDNode *cur = &(*it);
SET_STRING_ELT(names, i, mkChar(cur->getName().data()));
SET_VECTOR_ELT(rans, i, R_createRef(cur, "NamedMDNode"));
}
SET_NAMES(rans, names);
UNPROTECT(2);
return(rans);
}
SEXP
R_getFunctionArgs(SEXP r_func)
{
llvm::Function *fun;
fun = GET_REF(r_func, Function);
int n = 0;
llvm::Function::arg_iterator it = fun->arg_begin();
const llvm::FunctionType *fty = fun->getFunctionType();
n = fty->getNumParams();
#if 0
while(it++)// != it.end())
n++;
#endif
SEXP ans;
PROTECT(ans = NEW_LIST(n));
it = fun->arg_begin();
llvm::Value *el;
for(int i = 0; i < n ; i++, it++) {
el = it;
SET_VECTOR_ELT(ans, i, R_createRef(el, "Value"));
}
UNPROTECT(1);
return(ans);
}
SEXP
R_pthread_apply(SEXP routine, SEXP args)
{
SEXP ans;
int i, n;
n = Rf_length(args);
pthread_t *threads;
ThreadRoutine fun = (ThreadRoutine) R_ExternalPtrAddr(routine);
threads = (pthread_t *) malloc(sizeof(pthread_t) * n);
for(i = 0; i < n; i++) {
// thread = (pthread_t *) malloc(sizeof(pthread_t));
if(pthread_create(threads + i, NULL, fun, VECTOR_ELT(args, i)) != 0) {
PROBLEM "failed to create thread"
WARN;
// can have the threads in this this routine and then join on them and never let the threads out of this routine.
// SET_VECTOR_ELT(ans, i, tmp = R_MakeExternalPtr(thread, Rf_install("pthread_t"), R_NilValue));
}
}
PROTECT(ans = NEW_LIST(n));
for(i = 0; i < n; i++) {
void *val;
pthread_join(threads[i], &val);
SET_VECTOR_ELT(ans, i, (SEXP) val);
}
UNPROTECT(1);
return(ans);
}
USER_OBJECT_
RS_GGOBI(getDisplayVariables)(USER_OBJECT_ dpy)
{
USER_OBJECT_ buttons, vars, ans;
static gchar *button_names[] = { "X", "Y", "Z" };
gint i;
displayd *display = toDisplay(dpy);
/* get the currently plotted variables */
gint *plotted_vars = g_new (gint, display->d->ncols);
gint nplotted_vars = GGOBI_EXTENDED_DISPLAY_GET_CLASS (display)->plotted_vars_get(
display, plotted_vars, display->d, display->ggobi);
PROTECT(ans = NEW_LIST(2));
buttons = NEW_CHARACTER(nplotted_vars);
SET_VECTOR_ELT(ans, 1, buttons);
vars = NEW_INTEGER(nplotted_vars);
SET_VECTOR_ELT(ans, 0, vars);
for (i = 0; i < nplotted_vars; i++) {
gint var = plotted_vars[i], j;
for (j = 0; j < G_N_ELEMENTS(button_names); j++) {
GtkWidget *wid = varpanel_widget_get_nth(j, var, display->d);
if (gtk_toggle_button_get_active(GTK_TOGGLE_BUTTON(wid)))
SET_STRING_ELT(buttons, i, mkChar(button_names[j]));
}
INTEGER_DATA(vars)[i] = var;
}
UNPROTECT(1);
g_free(plotted_vars);
return(ans);
}
SEXP
R_getDefinedTypes()
{
ffi_type *types[] = {
&ffi_type_void,
&ffi_type_uint8,
&ffi_type_sint8,
&ffi_type_uint16,
&ffi_type_sint16,
&ffi_type_uint32,
&ffi_type_sint32,
&ffi_type_uint64,
&ffi_type_sint64,
&ffi_type_float,
&ffi_type_double,
&ffi_type_longdouble,
&ffi_type_pointer,
&ffi_type_string,
&ffi_type_sexp
};
SEXP ans;
int n = sizeof(types)/sizeof(types[0]), i;
ffi_type_sexp = ffi_type_pointer;
PROTECT(ans = NEW_LIST(n));
for(i = 0; i < n; i++)
// don't use this here MAKE_R_FFI_TYPE(types[i]));
// classes haven't been exported yet in the .onLoad
SET_VECTOR_ELT(ans, i, R_MakeExternalPtr(types[i], Rf_install("ffi_type"), R_NilValue));
UNPROTECT(1);
return(ans);
}
static SEXP vwhich_PDict3Parts_XStringSet(SEXP pptb, HeadTail *headtail,
SEXP subject,
SEXP max_mismatch, SEXP min_mismatch, SEXP fixed,
MatchPDictBuf *matchpdict_buf)
{
int S_length, j;
XStringSet_holder S;
SEXP ans, ans_elt;
Chars_holder S_elt;
S = _hold_XStringSet(subject);
S_length = _get_length_from_XStringSet_holder(&S);
PROTECT(ans = NEW_LIST(S_length));
for (j = 0; j < S_length; j++) {
S_elt = _get_elt_from_XStringSet_holder(&S, j);
match_pdict(pptb, headtail, &S_elt,
max_mismatch, min_mismatch, fixed,
matchpdict_buf);
PROTECT(ans_elt = _MatchBuf_which_asINTEGER(
&(matchpdict_buf->matches)));
SET_ELEMENT(ans, j, ans_elt);
UNPROTECT(1);
_MatchPDictBuf_flush(matchpdict_buf);
}
UNPROTECT(1);
return ans;
}
SEXP
convertStructToR(void *val, ffi_type *type)
{
int off = 0, numEls = 0, i;
ffi_type **els;
SEXP ans;
char *p;
if(!type->elements) {
PROBLEM "no type information for elements of structure"
ERROR;
}
els = type->elements;
while(*(els++))
numEls++;
PROTECT(ans = NEW_LIST(numEls));
els = type->elements;
p = (char *) val;
/*XXX need to do something with alignment and size to make portable. */
for(i = 0; i < numEls; i++) {
SET_VECTOR_ELT(ans, i, convertFromNative((void *) (p + off), els[i]));
if(i < numEls-1)
off = computeNextOffset(off, els[i], els[i+1]); // off += els[i+1]->alignment;
}
UNPROTECT(1);
return(ans);
}
SEXP
R_Function_getBasicBlockList(SEXP r_func)
{
llvm::Function *func = GET_REF(r_func, Function);
int n, i = 0;
SEXP rans, names;
llvm::iplist<llvm::BasicBlock> &blocks = func->getBasicBlockList();
n = blocks.size();
PROTECT(rans = NEW_LIST(n));
PROTECT(names = NEW_CHARACTER(n));
#if 1
for(llvm::iplist<const llvm::BasicBlock>::const_iterator it = blocks.begin(); it != blocks.end(); it++, i++)
{
const llvm::BasicBlock *cur = &(*it);
// SET_STRING_ELT(names, i, mkChar(cur->getNameStr().data())); // Worked for llvm 2.8
SET_STRING_ELT(names, i, mkChar(cur->getName().data()));
SET_VECTOR_ELT(rans, i, R_createRef(cur, "BasicBlock"));
}
#endif
SET_NAMES(rans, names);
UNPROTECT(2);
return(rans);
}
USER_OBJECT_
RS_GetPerlReferenceObjects(USER_OBJECT_ which)
{
USER_OBJECT_ ans, tmp;
int n, i = 0;
ForeignReferenceTable *table= &exportReferenceTable;
SV *el;
char *key;
I32 len;
dTHX;
if(table->entries == NULL) {
return(NULL_USER_OBJECT);
}
n = GET_LENGTH(which);
if(n == 0) {
n = hv_iterinit(table->entries);
PROTECT(ans = NEW_LIST(n));
while(i < n) {
el = hv_iternextsv(table->entries, &key, &len);
if(el == NULL)
break;
tmp = makeRSReferenceObject(key, computeRSPerlClassVector(el, NULL, TRUE), table);
SET_VECTOR_ELT(ans, i, tmp);
i++;
}
} else {
}
return(ans);
}
USER_OBJECT_
fromPerlArray(AV *val, unsigned int depth)
{
I32 n;
USER_OBJECT_ ans;
int i;
SV **el;
dTHX;
if(val == NULL)
return(NULL_USER_OBJECT);
n = av_len(val);
n++;
#ifdef R_PERL_DEBUG
fprintf(stderr, "Got an array %d\n", (int) n);
#endif
PROTECT(ans = NEW_LIST(n));
for(i = 0; i < n; i++) {
el = av_fetch(val, i, 0);
SET_VECTOR_ELT(ans, i, fromPerl(*el, TRUE));
}
UNPROTECT(1);
return(ans);
}
void
RS_XML(entityDeclaration)(void *ctx,
const xmlChar *name, int type, const xmlChar *publicId,
const xmlChar *systemId, xmlChar *content)
{
USER_OBJECT_ fun, opArgs, tmp;
RS_XMLParserData *parserData = (RS_XMLParserData*) ctx;
DECL_ENCODING_FROM_EVENT_PARSER(parserData)
/* check if there is a function to call before making the list of 5 elements. */
fun = RS_XML(findFunction)(HANDLER_FUN_NAME(parserData, "entityDeclaration"), parserData->methods);
if(fun == NULL || fun == NULL_USER_OBJECT)
return;
PROTECT(fun);
PROTECT(opArgs = NEW_LIST(5));
SET_VECTOR_ELT(opArgs, 0, RString(name));
PROTECT(tmp = ScalarInteger(type));
SET_NAMES(tmp, mkString(EntityTypeNames[type-1]));
SET_VECTOR_ELT(opArgs, 1, tmp);
UNPROTECT(1);
SET_VECTOR_ELT(opArgs, 2, RString(content));
SET_VECTOR_ELT(opArgs, 3, RString(systemId));
SET_VECTOR_ELT(opArgs, 4, RString(publicId));
(void) RS_XML(invokeFunction)(fun, opArgs, parserData->stateObject, parserData->ctx);
UNPROTECT(2);
}
static xmlEntityPtr
do_getEntityHandler(void *userData, const xmlChar *name, const char * r_funName)
{
SEXP opArgs, r_ans;
xmlEntityPtr ans = NULL;
RS_XMLParserData *parserData = (RS_XMLParserData*) userData;
DECL_ENCODING_FROM_EVENT_PARSER(parserData)
PROTECT(opArgs = NEW_LIST(1)) ;
SET_VECTOR_ELT(opArgs, 0, ScalarString(ENC_COPY_TO_USER_STRING(name))); /*XXX should we encode this? Done now! */
r_ans = RS_XML(callUserFunction)(r_funName, NULL, (RS_XMLParserData *) userData, opArgs);
PROTECT(r_ans) ;
if(r_ans != NULL_USER_OBJECT && GET_LENGTH(r_ans) > 0) {
if(TYPEOF(r_ans) == STRSXP) {
const char *value;
value = CHAR_DEREF(STRING_ELT(r_ans, 0));
ans = (xmlEntityPtr) malloc(sizeof(xmlEntity));
memset(ans, 0, sizeof(xmlEntity));
ans->type = XML_ENTITY_DECL;
ans->etype = XML_INTERNAL_GENERAL_ENTITY;
ans->name = xmlStrdup(name);
ans->orig = NULL; // xmlStrdup(CHAR_TO_XMLCHAR(value));
ans->content = xmlStrdup(CHAR_TO_XMLCHAR(value));
ans->length = strlen(value);
#ifndef NO_CHECKED_ENTITY_FIELD
ans->checked = 1;
#endif
}
}
UNPROTECT(2);
return(ans);
}
SEXP
R_parseURI(SEXP r_uri)
{
xmlURIPtr uri;
SEXP ans, names;
int i= 0;
uri = xmlParseURI( CHAR( STRING_ELT( r_uri, 0 )));
if(!uri) {
PROBLEM "cannot parse URI %s", CHAR( STRING_ELT( r_uri, 0) )
ERROR;
}
PROTECT(ans = NEW_LIST(8));
PROTECT(names = NEW_CHARACTER(8));
copyStrField(scheme);
copyStrField(authority);
copyStrField(server);
copyStrField(user);
copyStrField(path);
copyStrField(query);
copyStrField(fragment);
SET_VECTOR_ELT(ans, i, ScalarInteger(uri->port));
SET_STRING_ELT(names, i, mkChar("port"));
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
static SEXP make_LIST_from_ovenc_parts(SEXP Loffset, SEXP Roffset,
SEXP encoding)
{
SEXP ans, ans_names, ans_names_elt;
PROTECT(ans = NEW_LIST(3));
PROTECT(ans_names = NEW_CHARACTER(3));
PROTECT(ans_names_elt = mkChar("Loffset"));
SET_STRING_ELT(ans_names, 0, ans_names_elt);
UNPROTECT(1);
PROTECT(ans_names_elt = mkChar("Roffset"));
SET_STRING_ELT(ans_names, 1, ans_names_elt);
UNPROTECT(1);
PROTECT(ans_names_elt = mkChar("encoding"));
SET_STRING_ELT(ans_names, 2, ans_names_elt);
UNPROTECT(1);
SET_NAMES(ans, ans_names);
UNPROTECT(1);
SET_VECTOR_ELT(ans, 0, Loffset);
SET_VECTOR_ELT(ans, 1, Roffset);
SET_VECTOR_ELT(ans, 2, encoding);
UNPROTECT(1);
return ans;
}
USER_OBJECT_
RS_XML_copyNodesToDoc(USER_OBJECT_ s_node, USER_OBJECT_ s_doc, USER_OBJECT_ manageMemory)
{
xmlDocPtr doc;
xmlNodePtr node, ptr;
int len, i;
SEXP ans;
doc = (xmlDocPtr) R_ExternalPtrAddr(s_doc);
if(TYPEOF(s_node) == EXTPTRSXP) {
node = (xmlNodePtr) R_ExternalPtrAddr(s_node);
ptr = xmlDocCopyNode(node, doc, 1);
return(R_createXMLNodeRef(ptr, manageMemory));
}
len = Rf_length(s_node);
PROTECT(ans = NEW_LIST(len));
for(i = 0; i < len; i++) {
node = (xmlNodePtr) R_ExternalPtrAddr(VECTOR_ELT(s_node, i));
ptr = xmlDocCopyNode(node, doc, 1);
SET_VECTOR_ELT(ans, i, R_createXMLNodeRef(ptr, manageMemory));
}
UNPROTECT(1);
return(ans);
}
SEXP
R_unzGetGlobalInfo(SEXP r_file)
{
SEXP r_ans = R_NilValue;
unz_global_info pglobal_info ;
unzFile file ;
int ans ;
file = DEREF_REF_PTR_CLASS( r_file , unzFile, unzContent) ;
ans = unzGetGlobalInfo ( file, & pglobal_info ) ;
PROTECT(r_ans = NEW_LIST( 2 ));
SET_VECTOR_ELT(r_ans, 0, ScalarInteger( ans ) );
SET_VECTOR_ELT( r_ans, 1 , R_copyStruct_unz_global_info( &pglobal_info ) );
{
const char *names[] = {
"",
"pglobal_info"
};
SET_NAMES(r_ans, R_makeNames(names, 2 ));
};
UNPROTECT( 1 );
return(r_ans);
}
//-----------------------------------------------------------------------------------------------------------
//构建一个INSTANCE或者INSTANCE_LIST的函数
//-----------------------------------------------------------------------------------------------------------
PROPERTY *createProperty(char *property_id,char *property_type, char *property_value){
NEW_LIST(PROPERTY,p1);
SAFE_STRCPY(p1->property_id, property_id, MAX_PRIM_ID_LENGTH);
SAFE_STRCPY(p1->property_type, property_type, MAX_PRIM_ID_LENGTH);
SAFE_STRCPY((p1->property_value).property_string_value, property_value, MAX_PRIM_ID_LENGTH);
return p1;
}
SEXP
R_Module_getGlobalList(SEXP r_module)
{
llvm::Module *mod = GET_REF(r_module, Module);
int n, i = 0;
SEXP rans, names;
llvm::iplist<llvm::GlobalVariable> &funclist = mod->getGlobalList();
n = funclist.size();
PROTECT(rans = NEW_LIST(n));
PROTECT(names = NEW_CHARACTER(n));
for(llvm::iplist<const llvm::GlobalVariable>::iterator it = funclist.begin(); it != funclist.end(); it++, i++)
{
const llvm::GlobalVariable *curfunc = &(*it);
SET_STRING_ELT(names, i, mkChar(curfunc->getName().data()));
SET_VECTOR_ELT(rans, i, R_createRef(curfunc, "GlobalVariable"));
}
SET_NAMES(rans, names);
UNPROTECT(2);
return(rans);
}
PROPERTY *createProperty_Integer(char *property_id,char *property_type, int property_value){
NEW_LIST(PROPERTY,p1);
SAFE_STRCPY(p1->property_id, property_id, MAX_PRIM_ID_LENGTH);
SAFE_STRCPY(p1->property_type, property_type, MAX_PRIM_ID_LENGTH);
p1->property_value.property_num_value=property_value;
return p1;
}
/*
* 'mode' controls how empty list elements should be represented:
* 0 -> integer(0); 1 -> NULL; 2 -> NA
*/
SEXP _new_LIST_from_IntAEAE(const IntAEAE *aeae, int mode)
{
int nelt, i;
SEXP ans, ans_elt;
const IntAE *ae;
nelt = _IntAEAE_get_nelt(aeae);
PROTECT(ans = NEW_LIST(nelt));
for (i = 0; i < nelt; i++) {
ae = aeae->elts[i];
if (_IntAE_get_nelt(ae) != 0 || mode == 0) {
PROTECT(ans_elt = _new_INTEGER_from_IntAE(ae));
} else if (mode == 1) {
continue;
} else {
// Not sure new LOGICALs are initialized with NAs,
// need to check! If not, then LOGICAL(ans_elt)[0] must
// be set to NA but I don't know how to do this :-/
PROTECT(ans_elt = NEW_LOGICAL(1));
}
SET_VECTOR_ELT(ans, i, ans_elt);
UNPROTECT(1);
}
UNPROTECT(1);
return ans;
}
VIEW_CELL_LIB_REF *decideInstance_Ref(char *viewref_id,char *cellref_id, char *libref_id){
NEW_LIST(VIEW_CELL_LIB_REF,p1);
SAFE_STRCPY(p1->viewref_id,viewref_id,MAX_PRIM_ID_LENGTH);
SAFE_STRCPY(p1->cellref_id,cellref_id,MAX_PRIM_ID_LENGTH);
SAFE_STRCPY(p1->libref_id, libref_id,MAX_USER_ID_LENGTH);
return p1;
}
SEXP checkCRSArgs(SEXP args) {
SEXP res;
projPJ pj;
PROTECT(res = NEW_LIST(2));
SET_VECTOR_ELT(res, 0, NEW_LOGICAL(1));
SET_VECTOR_ELT(res, 1, NEW_CHARACTER(1));
LOGICAL_POINTER(VECTOR_ELT(res, 0))[0] = FALSE;
if (!(pj = pj_init_plus(CHAR(STRING_ELT(args, 0))))) {
SET_STRING_ELT(VECTOR_ELT(res, 1), 0,
COPY_TO_USER_STRING(pj_strerrno(*pj_get_errno_ref())));
UNPROTECT(1);
return(res);
}
SET_STRING_ELT(VECTOR_ELT(res, 1), 0,
COPY_TO_USER_STRING(pj_get_def(pj, 0)));
LOGICAL_POINTER(VECTOR_ELT(res, 0))[0] = TRUE;
UNPROTECT(1);
return(res);
}
NET *findNet(char *net_name,PORTREF *portref_list){
NEW_LIST(NET,p1);
SAFE_STRCPY(p1->net_name,net_name,MAX_USER_ID_LENGTH);
p1->portref_number=portref_list->list_cnt;
p1->portref_list =portref_list;
return p1;
}
static void
RS_XML(xmlSAX2EndElementNs)(void * ctx,
const xmlChar * localname,
const xmlChar * prefix,
const xmlChar * URI)
{
USER_OBJECT_ args, tmp, fun;
RS_XMLParserData *rinfo = (RS_XMLParserData *) ctx;
DECL_ENCODING_FROM_EVENT_PARSER(rinfo)
if(rinfo->current) {
R_endBranch(rinfo, localname, prefix, URI);
return;
}
PROTECT(args = NEW_LIST(2));
SET_VECTOR_ELT(args, 0, ScalarString(ENC_COPY_TO_USER_STRING(localname)));
PROTECT(tmp = ScalarString(ENC_COPY_TO_USER_STRING((XMLCHAR_TO_CHAR(URI)) ? XMLCHAR_TO_CHAR(URI) : "")));
if(prefix)
SET_NAMES(tmp, ScalarString(ENC_COPY_TO_USER_STRING(prefix)));
SET_VECTOR_ELT(args, 1, tmp);
fun = findEndElementFun(localname, rinfo);
if(fun) {
USER_OBJECT_ val = RS_XML(invokeFunction)(fun, args, rinfo->stateObject, rinfo->ctx);
updateState(val, rinfo);
} else
RS_XML(callUserFunction)(HANDLER_FUN_NAME(ctx, "endElement"), NULL, (RS_XMLParserData *)ctx, args);
UNPROTECT(2);
}
/*
This allocates an S vector of the type corresponding
to the Perl primitive type given in `elementType'
and of length n.
See PerlAddHomogeneousElement() below.
*/
USER_OBJECT_
PerlAllocHomogeneousVector(int n, svtype elementType)
{
USER_OBJECT_ ans = NULL_USER_OBJECT;
switch(elementType) {
case SVt_IV:
case SVt_PVIV:
ans = NEW_INTEGER(n);
break;
case SVt_NV:
case SVt_PVNV:
ans = NEW_NUMERIC(n);
break;
case SVt_PV:
ans = NEW_CHARACTER(n);
break;
default:
ans = NEW_LIST(n);
/*
PROBLEM "No code written yet to handle Perl type %d",
elementType
ERROR;
*/
break;
}
return(ans);
}
