SEXP
R_makeEnumValue(int val, const char *elName, const char *className)
{
SEXP ans, klass;
#if defined(USE_S4_ENUMS)
SEXP tmp;
PROTECT(klass = MAKE_CLASS(className));
PROTECT(ans = NEW(klass));
PROTECT(tmp = ScalarInteger(val));
SET_NAMES(tmp, mkString(elName));
ans = SET_SLOT(ans, Rf_install(".Data"), tmp);
UNPROTECT(3);
#else
PROTECT(ans = ScalarInteger(val));
SET_NAMES(ans, mkString(elName));
PROTECT(klass = NEW_CHARACTER(2));
SET_STRING_ELT(klass, 0, mkChar(className));
SET_STRING_ELT(klass, 1, mkChar("EnumValue"));
SET_CLASS(ans, klass);
UNPROTECT(2);
#endif
return(ans);
}
static SEXP
convertNodeSetToR(xmlNodeSetPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans, expr = NULL, arg = NULL, ref;
int i;
if(!obj)
return(NULL_USER_OBJECT);
PROTECT(ans = NEW_LIST(obj->nodeNr));
if(GET_LENGTH(fun) && (TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)) {
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, fun);
arg = CDR(expr);
} else if(TYPEOF(fun) == LANGSXP) {
expr = fun;
arg = CDR(expr);
}
for(i = 0; i < obj->nodeNr; i++) {
xmlNodePtr el;
el = obj->nodeTab[i];
if(el->type == XML_ATTRIBUTE_NODE) {
#if 0
PROTECT(ref = mkString((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : ""));
SET_NAMES(ref, mkString(el->name));
#else
PROTECT(ref = ScalarString(mkCharCE((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : "", encoding)));
SET_NAMES(ref, ScalarString(mkCharCE(el->name, encoding)));
#endif
SET_CLASS(ref, mkString("XMLAttributeValue"));
UNPROTECT(1);
} else if(el->type == XML_NAMESPACE_DECL)
ref = R_createXMLNsRef((xmlNsPtr) el);
else
ref = R_createXMLNodeRef(el, manageMemory);
if(expr) {
PROTECT(ref);
SETCAR(arg, ref);
PROTECT(ref = Rf_eval(expr, R_GlobalEnv)); /*XXX do we want to catch errors here? Maybe to release the namespaces. */
SET_VECTOR_ELT(ans, i, ref);
UNPROTECT(2);
} else
SET_VECTOR_ELT(ans, i, ref);
}
if(expr) {
if(TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)
UNPROTECT(1);
} else
SET_CLASS(ans, mkString("XMLNodeSet"));
UNPROTECT(1);
return(ans);
}
USER_OBJECT_
createSAX2AttributesList(const xmlChar **attributes, int nb_attributes, int nb_defaulted, const xmlChar *encoding)
{
int i;
const char **ptr;
USER_OBJECT_ attr_names;
USER_OBJECT_ attr_values;
USER_OBJECT_ nsURI, nsNames;
if(nb_attributes < 1)
return(NULL_USER_OBJECT);
PROTECT(attr_values = NEW_CHARACTER(nb_attributes));
PROTECT(attr_names = NEW_CHARACTER(nb_attributes));
PROTECT(nsURI = NEW_CHARACTER(nb_attributes));
PROTECT(nsNames = NEW_CHARACTER(nb_attributes));
ptr = (const char **) attributes; /*XXX */
for(i=0; i < nb_attributes; i++, ptr+=5) {
char *tmp;
int len;
len = (ptr[4] - ptr[3] + 1);
tmp = malloc(sizeof(char) * len);
if(!tmp) {
PROBLEM "Cannot allocate space for attribute of length %d", (int) (ptr[4] - ptr[3] + 2)
ERROR;
}
memcpy(tmp, ptr[3], ptr[4] - ptr[3]);
tmp[len-1] = '\0'; /*XXX*/
SET_STRING_ELT(attr_values, i, ENC_COPY_TO_USER_STRING(tmp));
free(tmp);
SET_STRING_ELT(attr_names, i, ENC_COPY_TO_USER_STRING(ptr[0]));
if(ptr[2]) {
SET_STRING_ELT(nsURI, i, ENC_COPY_TO_USER_STRING(ptr[2]));
if(ptr[1])
SET_STRING_ELT(nsNames, i, ENC_COPY_TO_USER_STRING(ptr[1]));
}
}
SET_NAMES(nsURI, nsNames);
SET_NAMES(attr_values, attr_names);
Rf_setAttrib(attr_values, Rf_install("namespaces"), nsURI);
UNPROTECT(4);
return(attr_values);
}
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);
}
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);
}
/* --- .Call ENTRY POINT --- */
SEXP CompressedNormalIRangesList_max(SEXP x, SEXP use_names)
{
SEXP ans, ans_names;
cachedCompressedIRangesList cached_x;
cachedIRanges cached_ir;
int x_length, ir_length, i;
int *ans_elt;
cached_x = _cache_CompressedIRangesList(x);
x_length = _get_cachedCompressedIRangesList_length(&cached_x);
PROTECT(ans = NEW_INTEGER(x_length));
for (i = 0, ans_elt = INTEGER(ans); i < x_length; i++, ans_elt++) {
cached_ir = _get_cachedCompressedIRangesList_elt(&cached_x, i);
ir_length = _get_cachedIRanges_length(&cached_ir);
if (ir_length == 0) {
*ans_elt = R_INT_MIN;
} else {
*ans_elt = _get_cachedIRanges_elt_end(&cached_ir, ir_length - 1);
}
}
if (LOGICAL(use_names)[0]) {
PROTECT(ans_names = duplicate(_get_CompressedList_names(x)));
SET_NAMES(ans, ans_names);
UNPROTECT(1);
}
UNPROTECT(1);
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;
}
/*
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_
asREnum(int value, GType etype)
{
USER_OBJECT_ ans, names;
GEnumValue *evalue;
PROTECT(ans = NEW_INTEGER(1));
INTEGER_DATA(ans)[0] = value;
if (!(evalue = g_enum_get_value(g_type_class_ref(etype), value))) {
PROBLEM "Unknown enum value %d", value
ERROR;
}
PROTECT(names = NEW_CHARACTER(1));
SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(evalue->value_name));
SET_NAMES(ans, names);
PROTECT(names = NEW_CHARACTER(2));
SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(etype)));
SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("enum"));
SET_CLASS(ans, names);
UNPROTECT(3);
return(ans);
}
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);
}
SEXP rmysql_driver_info() {
MySQLDriver *mgr = rmysql_driver();
// Allocate output
SEXP output = PROTECT(allocVector(VECSXP, 6));
SEXP output_nms = PROTECT(allocVector(STRSXP, 6));
SET_NAMES(output, output_nms);
UNPROTECT(1);
SET_CHR_EL(output_nms, 0, mkChar("connectionIds"));
SEXP cons = PROTECT(allocVector(INTSXP, mgr->num_con));
RS_DBI_listEntries(mgr->connectionIds, mgr->num_con, INTEGER(cons));
SET_VECTOR_ELT(output, 0, cons);
UNPROTECT(1);
SET_CHR_EL(output_nms, 1, mkChar("fetch_default_rec"));
SET_VECTOR_ELT(output, 1, ScalarInteger(mgr->fetch_default_rec));
SET_CHR_EL(output_nms, 2, mkChar("length"));
SET_VECTOR_ELT(output, 2, ScalarInteger(mgr->length));
SET_CHR_EL(output_nms, 3, mkChar("num_con"));
SET_VECTOR_ELT(output, 3, ScalarInteger(mgr->num_con));
SET_CHR_EL(output_nms, 4, mkChar("counter"));
SET_VECTOR_ELT(output, 4, ScalarInteger(mgr->counter));
SET_CHR_EL(output_nms, 5, mkChar("clientVersion"));
SET_VECTOR_ELT(output, 5, mkString(mysql_get_client_info()));
UNPROTECT(1);
return output;
}
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);
}
/*
This assumes that `val' is actually a Perl Hash table
and that elementType identifies a _primitive_ Perl
type and that all the elements in the table are of
that type. This then creates an S vector of
the corresponding type and populates it with the
elements of the table and puts the names of the elements
as the names of the S vector.
*/
USER_OBJECT_
fromHomogeneousTable(SV *val, svtype elementType)
{
USER_OBJECT_ ans, names;
SV *av, *el;
I32 len;
char *key;
int n, i;
dTHX;
if(SvROK(val))
av = SvRV(val) ;
else
av = val;
n = hv_iterinit((HV *) av);
PROTECT(ans = PerlAllocHomogeneousVector(n, elementType));
PROTECT(names = NEW_CHARACTER(n));
for(i = 0; i < n; i++) {
el = hv_iternextsv((HV *) av, &key, &len);
if(el) {
PerlAddHomogeneousElement(el, i, ans, elementType);
}
if(key && key[0]) {
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key));
}
}
SET_NAMES(ans, names);
UNPROTECT(2);
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);
}
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);
}
USER_OBJECT_
RS_GGOBI(getDisplayOptions)(USER_OBJECT_ which)
{
USER_OBJECT_ ans, names;
gint NumOptions = 8;
DisplayOptions *options;
if (GET_LENGTH(which) == 0)
options = GGOBI(getDefaultDisplayOptions)();
else {
displayd *display = toDisplay(which);
g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT);
options = &(display->options);
}
g_return_val_if_fail(options != NULL, NULL_USER_OBJECT);
PROTECT(ans = NEW_LOGICAL(NumOptions));
PROTECT(names = NEW_CHARACTER(NumOptions));
LOGICAL_DATA(ans)[DOPT_POINTS] = options->points_show_p;
SET_STRING_ELT(names, DOPT_POINTS, COPY_TO_USER_STRING("Show points"));
LOGICAL_DATA(ans)[DOPT_AXES] = options->axes_show_p;
SET_STRING_ELT(names, DOPT_AXES, COPY_TO_USER_STRING("Show axes"));
LOGICAL_DATA(ans)[DOPT_AXESLAB] = options->axes_label_p;
SET_STRING_ELT(names, DOPT_AXESLAB,
COPY_TO_USER_STRING("Show tour axes"));
LOGICAL_DATA(ans)[DOPT_AXESVALS] = options->axes_values_p;
SET_STRING_ELT(names, DOPT_AXESVALS,
COPY_TO_USER_STRING("Show axes labels"));
LOGICAL_DATA(ans)[DOPT_EDGES_U] = options->edges_undirected_show_p;
SET_STRING_ELT(names, DOPT_EDGES_U, COPY_TO_USER_STRING("Undirected edges"));
LOGICAL_DATA(ans)[DOPT_EDGES_A] = options->edges_arrowheads_show_p;
SET_STRING_ELT(names, DOPT_EDGES_A, COPY_TO_USER_STRING("Arrowheads"));
LOGICAL_DATA(ans)[DOPT_EDGES_D] = options->edges_directed_show_p;
SET_STRING_ELT(names, DOPT_EDGES_D, COPY_TO_USER_STRING("Directed edges"));
LOGICAL_DATA(ans)[DOPT_WHISKERS] = options->whiskers_show_p;
SET_STRING_ELT(names, DOPT_WHISKERS,
COPY_TO_USER_STRING("Show whiskers"));
/* unused
LOGICAL_DATA(ans)[5] = options->missings_show_p;
SET_STRING_ELT(names, 5, COPY_TO_USER_STRING("Missing Values"));
LOGICAL_DATA(ans)[8] = options->axes_center_p;
SET_STRING_ELT(names, 8, COPY_TO_USER_STRING("Center axes"));
LOGICAL_DATA(ans)[9] = options->double_buffer_p;
SET_STRING_ELT(names, 9, COPY_TO_USER_STRING("Double buffer"));
LOGICAL_DATA(ans)[10] = options->link_p;
SET_STRING_ELT(names, 10, COPY_TO_USER_STRING("Link"));
*/
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
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);
}
SEXP
createREnumerationValue(int val, const char * const *names, const int *values, int namesLength, const char *name)
{
SEXP ans;
int i;
PROTECT(ans =allocVector(INTSXP, 1));
INTEGER(ans)[0] = val;
for(i = 0; i < namesLength; i++) {
if(val == values[i]) {
SET_NAMES(ans, mkString(names[i]));
break;
}
}
if(i == namesLength) {
PROBLEM "Unrecognized value (%d) in enumeration %s", val, name
ERROR;
}
/* Do we want an enumeration value element here also. */
SET_CLASS(ans, mkString(name));
Rf_PrintValue(ans);
UNPROTECT(1);
return(ans);
}
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);
}
SEXP
getAlternatives(tesseract::ResultIterator* ri, const char *word, float conf)
{
tesseract::ChoiceIterator ci_r(*ri);
int nels = 2;
while(ci_r.Next())
nels++;
SEXP ans, names;
PROTECT(ans = NEW_NUMERIC(nels));
PROTECT(names = NEW_CHARACTER(nels));
int i = 0;
SET_STRING_ELT(names, 0, Rf_mkChar(word));
REAL(ans)[0] = conf;
tesseract::ChoiceIterator ci(*ri);
for(i = 1; i < nels ; i++, ci.Next()) {
const char* choice = ci.GetUTF8Text();
conf = ci.Confidence();
if(choice)
SET_STRING_ELT(names, i, Rf_mkChar(choice));
REAL(ans)[i] = conf;
// delete [] choice;
}
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
void
Sexp_set_names(SEXP sexp,
const SEXP sexp_names) {
if (! RINTERF_ISREADY()) {
return;
}
SET_NAMES(sexp, sexp_names);
}
SEXP graph_sublist_assign(SEXP x, SEXP subs, SEXP sublist, SEXP values)
{
SEXP idx, names, tmpItem, newsubs, ans, ansnames, val;
int ns, i, j, nnew, nextempty, origlen, numVals, tmpIdx;
ns = length(subs);
origlen = length(x);
numVals = length(values);
if (numVals > 1 && ns != numVals)
error("invalid args: subs and values must be the same length");
names = GET_NAMES(x);
PROTECT(idx = match(names, subs, -1));
PROTECT(newsubs = allocVector(STRSXP, ns));
nnew = 0;
for (i = 0; i < ns; i++) {
if (INTEGER(idx)[i] == -1)
SET_STRING_ELT(newsubs, nnew++, STRING_ELT(subs, i));
}
PROTECT(ans = allocVector(VECSXP, origlen + nnew));
PROTECT(ansnames = allocVector(STRSXP, length(ans)));
for (i = 0; i < origlen; i++) {
SET_VECTOR_ELT(ans, i, duplicate(VECTOR_ELT(x, i)));
SET_STRING_ELT(ansnames, i, duplicate(STRING_ELT(names, i)));
}
j = origlen;
for (i = 0; i < nnew; i++)
SET_STRING_ELT(ansnames, j++, STRING_ELT(newsubs, i));
SET_NAMES(ans, ansnames);
UNPROTECT(1);
nextempty = origlen; /* index of next unfilled element of ans */
for (i = 0; i < ns; i++) {
if (numVals > 1)
PROTECT(val = graph_makeItem(values, i));
else if (numVals == 1 && isVectorList(values))
PROTECT(val = duplicate(VECTOR_ELT(values, 0)));
else
PROTECT(val = duplicate(values));
j = INTEGER(idx)[i];
if (j < 0) {
tmpItem = graph_addItemToList(R_NilValue, val, sublist);
SET_VECTOR_ELT(ans, nextempty, tmpItem);
nextempty++;
} else {
tmpItem = VECTOR_ELT(ans, j-1);
tmpIdx = graph_getListIndex(tmpItem, sublist);
if (tmpIdx == -1) {
tmpItem = graph_addItemToList(tmpItem, val, sublist);
SET_VECTOR_ELT(ans, j-1, tmpItem);
} else
SET_VECTOR_ELT(tmpItem, tmpIdx, val);
}
UNPROTECT(1);
}
UNPROTECT(3);
return ans;
}
static SEXP make_fasta_index_data_frame(const IntAE *recno_buf,
const IntAE *fileno_buf,
const LLongAE *offset_buf,
const CharAEAE *desc_buf,
const IntAE *seqlength_buf)
{
SEXP df, colnames, tmp;
int i;
PROTECT(df = NEW_LIST(5));
PROTECT(colnames = NEW_CHARACTER(5));
PROTECT(tmp = mkChar("recno"));
SET_STRING_ELT(colnames, 0, tmp);
UNPROTECT(1);
PROTECT(tmp = mkChar("fileno"));
SET_STRING_ELT(colnames, 1, tmp);
UNPROTECT(1);
PROTECT(tmp = mkChar("offset"));
SET_STRING_ELT(colnames, 2, tmp);
UNPROTECT(1);
PROTECT(tmp = mkChar("desc"));
SET_STRING_ELT(colnames, 3, tmp);
UNPROTECT(1);
PROTECT(tmp = mkChar("seqlength"));
SET_STRING_ELT(colnames, 4, tmp);
UNPROTECT(1);
SET_NAMES(df, colnames);
UNPROTECT(1);
PROTECT(tmp = new_INTEGER_from_IntAE(recno_buf));
SET_ELEMENT(df, 0, tmp);
UNPROTECT(1);
PROTECT(tmp = new_INTEGER_from_IntAE(fileno_buf));
SET_ELEMENT(df, 1, tmp);
UNPROTECT(1);
PROTECT(tmp = NEW_NUMERIC(LLongAE_get_nelt(offset_buf)));
for (i = 0; i < LENGTH(tmp); i++)
REAL(tmp)[i] = (double) offset_buf->elts[i];
SET_ELEMENT(df, 2, tmp);
UNPROTECT(1);
PROTECT(tmp = new_CHARACTER_from_CharAEAE(desc_buf));
SET_ELEMENT(df, 3, tmp);
UNPROTECT(1);
PROTECT(tmp = new_INTEGER_from_IntAE(seqlength_buf));
SET_ELEMENT(df, 4, tmp);
UNPROTECT(1);
/* list_as_data_frame() performs IN-PLACE coercion */
list_as_data_frame(df, IntAE_get_nelt(recno_buf));
UNPROTECT(1);
return df;
}
SEXP
R_ocr(SEXP filename, SEXP r_vars, SEXP r_level)
{
SEXP ans = R_NilValue;
int i;
tesseract::TessBaseAPI *api = new tesseract::TessBaseAPI();
if(api->Init(NULL, "eng")) {
PROBLEM "could not intialize tesseract engine."
ERROR;
}
Pix *image = pixRead(CHAR(STRING_ELT(filename, 0)));
api->SetImage(image);
SEXP r_optNames = GET_NAMES(r_vars);
for(i = 0; i < Rf_length(r_vars); i++)
api->SetVariable(CHAR(STRING_ELT(r_optNames, i)), CHAR(STRING_ELT(r_vars, i)));
api->Recognize(0);
tesseract::ResultIterator* ri = api->GetIterator();
tesseract::PageIteratorLevel level = (tesseract::PageIteratorLevel) INTEGER(r_level)[0]; //RIL_WORD;
if(ri != 0) {
int n = 1, i;
while(ri->Next(level)) n++;
// printf("num words %d\n", n);
delete ri; // XXX check
// api->Recognize(0);
ri = api->GetIterator();
SEXP names;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_NUMERIC(n));
i = 0;
do {
const char* word = ri->GetUTF8Text(level);
float conf = ri->Confidence(level);
SET_STRING_ELT(names, i, Rf_mkChar(word));
REAL(ans)[i] = conf;
delete[] word;
i++;
} while (ri->Next(level));
delete ri; // XXX check
SET_NAMES(ans, names);
UNPROTECT(2);
}
pixDestroy(&image);
return(ans);
}
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);
}
static inline SEXP named_return(R_len_t ind, SEXP names) {
if (isNull(names))
return ScalarInteger(ind + 1);
SEXP res;
PROTECT(res = ScalarInteger(ind + 1));
SET_NAMES(res, ScalarString(STRING_ELT(names, ind)));
UNPROTECT(1);
return res;
}
SEXP
R_foo(SEXP r_int)
{
SEXP r_ans, r_names;
int n = INTEGER(r_int)[0];
r_ans = NEW_LIST(n);
r_names = NEW_CHARACTER(n);
SET_NAMES(r_ans, r_names);
return(r_ans);
}
SEXP
R_getFunctionAttributes_logical(
#ifdef NEW_LLVM_ATTRIBUTES_SETUP
llvm::AttributeSet attr
#else
llvm::Attributes attr
#endif
)
{
SEXP ans, names;
/* Get the number correct. */
int i = 0, n = 28;
#ifdef NEW_LLVM_ATTRIBUTES_SETUP
n = 27;
#endif
PROTECT(ans = NEW_LOGICAL(n));
PROTECT(names = NEW_CHARACTER(n));
#ifndef NEW_LLVM_ATTRIBUTES_SETUP
SET_EL( AddressSafety)
#endif
SET_EL( Alignment)
SET_EL( AlwaysInline)
SET_EL( ByVal)
SET_EL( InlineHint)
SET_EL( InReg)
SET_EL( MinSize)
SET_EL( Naked)
SET_EL( Nest)
SET_EL( NoAlias)
SET_EL( NoCapture)
SET_EL( NoImplicitFloat)
SET_EL( NoInline)
SET_EL( NonLazyBind)
SET_EL( NoRedZone)
SET_EL( NoReturn)
SET_EL( NoUnwind)
SET_EL( OptimizeForSize)
SET_EL( ReadNone)
SET_EL( ReadOnly)
SET_EL( ReturnsTwice)
SET_EL( SExt)
SET_EL( StackAlignment)
SET_EL( StackProtect)
SET_EL( StackProtectReq)
SET_EL( StructRet)
SET_EL( UWTable)
SET_EL( ZExt )
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
void RS_DBI_allocOutput(SEXP output, RMySQLFields* flds, int num_rec, int expand) {
SEXP names, s_tmp;
int j;
int num_fields;
SEXPTYPE *fld_Sclass;
PROTECT(output);
num_fields = flds->num_fields;
if(expand){
for(j = 0; j < (int) num_fields; j++){
/* Note that in R-1.2.3 (at least) we need to protect SET_LENGTH */
s_tmp = LST_EL(output,j);
PROTECT(SET_LENGTH(s_tmp, num_rec));
SET_ELEMENT(output, j, s_tmp);
UNPROTECT(1);
}
UNPROTECT(1);
return;
}
fld_Sclass = flds->Sclass;
for(j = 0; j < (int) num_fields; j++){
switch((int)fld_Sclass[j]){
case LGLSXP:
SET_ELEMENT(output, j, NEW_LOGICAL(num_rec));
break;
case STRSXP:
SET_ELEMENT(output, j, NEW_CHARACTER(num_rec));
break;
case INTSXP:
SET_ELEMENT(output, j, NEW_INTEGER(num_rec));
break;
case REALSXP:
SET_ELEMENT(output, j, NEW_NUMERIC(num_rec));
break;
case VECSXP:
SET_ELEMENT(output, j, NEW_LIST(num_rec));
break;
default:
error("unsupported data type");
}
}
PROTECT(names = NEW_CHARACTER((int) num_fields));
for(j = 0; j< (int) num_fields; j++){
SET_CHR_EL(names,j, mkChar(flds->name[j]));
}
SET_NAMES(output, names);
UNPROTECT(2);
return;
}
