自学教程：C++ COPY_TO_USER_STRING函数代码示例

SEXP SP_PREFIX(SpatialPolygons_validate_c)(SEXP obj) {    int pc=0;    int i, n;    SEXP pls, ans;    char *cls="Polygons";    PROTECT(pls = GET_SLOT(obj, install("polygons"))); pc++;    n = length(pls);    for (i=0; i<n; i++) {        if (strcmp(CHAR(STRING_ELT(getAttrib(VECTOR_ELT(pls, i),           R_ClassSymbol), 0)), cls) != 0) {             PROTECT(ans = NEW_CHARACTER(1)); pc++;             SET_STRING_ELT(ans, 0,             COPY_TO_USER_STRING("polygons slot contains non-Polygons object"));             UNPROTECT(pc);             return(ans);        }    }    if (n != length(GET_SLOT(obj, install("plotOrder")))) {        PROTECT(ans = NEW_CHARACTER(1)); pc++;        SET_STRING_ELT(ans, 0,           COPY_TO_USER_STRING("plotOrder and polygons differ in length"));        UNPROTECT(pc);        return(ans);    }    PROTECT(ans = NEW_LOGICAL(1)); pc++;    LOGICAL_POINTER(ans)[0] = TRUE;    UNPROTECT(pc);    return(ans);}

SEXP ogrAutoIdentifyEPSG(SEXP p4s) {    OGRSpatialReference hSRS = NULL;    OGRErr thisOGRErr;    SEXP ans;    installErrorHandler();    if (hSRS.importFromProj4(CHAR(STRING_ELT(p4s, 0))) != OGRERR_NONE) {        uninstallErrorHandlerAndTriggerError();	error("Can't parse PROJ.4-style parameter string");    }    uninstallErrorHandlerAndTriggerError();    PROTECT(ans=NEW_CHARACTER(1));    installErrorHandler();    thisOGRErr = hSRS.AutoIdentifyEPSG();    uninstallErrorHandlerAndTriggerError();    if (thisOGRErr == OGRERR_NONE) {        installErrorHandler();        SET_STRING_ELT(ans, 0,            COPY_TO_USER_STRING(hSRS.GetAuthorityCode(NULL)));        uninstallErrorHandlerAndTriggerError();    } else if (thisOGRErr == OGRERR_UNSUPPORTED_SRS) {        SET_STRING_ELT(ans, 0,            COPY_TO_USER_STRING("OGRERR_UNSUPPORTED_SRS"));    }    UNPROTECT(1);    return(ans);}

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);}

/* Autoload default packages and names from autoloads.h * * This function behaves in almost every way like * R's autoload: * function (name, package, reset = FALSE, ...) * { *     if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE)) *        stop("an object with that name already exists") *     m <- match.call() *     m[[1]] <- as.name("list") *     newcall <- eval(m, parent.frame()) *     newcall <- as.call(c(as.name("autoloader"), newcall)) *     newcall$reset <- NULL *     if (is.na(match(package, .Autoloaded))) *        assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv) *     do.call("delayedAssign", list(name, newcall, .GlobalEnv, *                                                         .AutoloadEnv)) *     invisible() * } * * What's missing is the updating of the string vector .Autoloaded with the list * of packages, which by my code analysis is useless and only for informational * purposes. * */void autoloads(void){    SEXP da, dacall, al, alcall, AutoloadEnv, name, package;    int i,j, idx=0, errorOccurred, ptct;        /* delayedAssign call*/    PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));    PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));    if (AutoloadEnv == R_NilValue){        fprintf(stderr,"%s: Cannot find .AutoloadEnv!/n", programName);        exit(1);    }    PROTECT(dacall = allocVector(LANGSXP,5));    SETCAR(dacall,da);    /* SETCAR(CDR(dacall),name); */          /* arg1: assigned in loop */    /* SETCAR(CDR(CDR(dacall)),alcall); */  /* arg2: assigned in loop */    SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv); /* arg3 */    SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv); /* arg3 */    /* autoloader call */    PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));    PROTECT(alcall = allocVector(LANGSXP,3));    SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */    SETCAR(alcall,al);    /* SETCAR(CDR(alcall),name); */          /* arg1: assigned in loop */    /* SETCAR(CDR(CDR(alcall)),package); */  /* arg2: assigned in loop */    ptct = 5;    for(i = 0; i < packc; i++){        idx += (i != 0)? packobjc[i-1] : 0;        for (j = 0; j < packobjc[i]; j++){            /*printf("autload(%s,%s)/n",packobj[idx+j],pack[i]);*/                        PROTECT(name = NEW_CHARACTER(1));            PROTECT(package = NEW_CHARACTER(1));            SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));            SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));                        /* Set up autoloader call */            PROTECT(alcall = allocVector(LANGSXP,3));            SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */            SETCAR(alcall,al);            SETCAR(CDR(alcall),name);            SETCAR(CDR(CDR(alcall)),package);            /* Setup delayedAssign call */            SETCAR(CDR(dacall),name);            SETCAR(CDR(CDR(dacall)),alcall);                        R_tryEval(dacall,R_GlobalEnv,&errorOccurred);            if (errorOccurred){                fprintf(stderr,"%s: Error calling delayedAssign!/n", programName);                exit(1);            }                        ptct += 3;        }    }    UNPROTECT(ptct);}

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);}

voidRXSLT_callNamedFunction(const char *name, xmlXPathParserContextPtr ctxt, int nargs, int leaveAsRObject){  USER_OBJECT_ e, ans;//  xmlXPathObjectPtr obj;  int errorOccurred;  int i, j;#if 0  PROTECT(e = allocVector(LANGSXP, 2));  SETCAR(e, Rf_install((char *) name));  SETCAR(CDR(e), tmp = NEW_CHARACTER(1));  obj = valuePop(ctxt);   SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(xmlXPathCastToString(obj)));#else  PROTECT(e = allocVector(LANGSXP, nargs+1));  SETCAR(e, Rf_install((char *) name));#if 0  for(i = 0; i < nargs; i++) {    ans = CDR(e);    for(j = nargs-1; j > i ; j--) {      ans = CDR(ans);    }    SETCAR(ans, tmp = NEW_CHARACTER(1));    obj = valuePop(ctxt);     SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(xmlXPathCastToString(obj)));  }#else  for(i = 0; i < nargs; i++) {    ans = CDR(e);    for(j = nargs-1; j > i ; j--) {      ans = CDR(ans);    }   SETCAR(ans, convertFromXPath(ctxt, valuePop(ctxt)));  }#endif#endif    ans = R_tryEval(e, R_GlobalEnv, &errorOccurred);  if(errorOccurred) {      RXSLT_Error(ctxt, "error in call to R function");   } else {     PROTECT(ans);     valuePush(ctxt, convertToXPath(ctxt, ans));     UNPROTECT(1);  }  UNPROTECT(1);  return;}

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);}

USER_OBJECT_asRFlag(guint value, GType ftype){    USER_OBJECT_ ans, names;    PROTECT(ans = NEW_INTEGER(1));    INTEGER_DATA(ans)[0] = value;    PROTECT(names = NEW_CHARACTER(2));    SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(ftype)));    SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("flag"));    SET_CLASS(ans, names);    UNPROTECT(2);    return(ans);}

SEXP GetRScalar(SV *val){  dTHX;  SEXP ans = NULL_USER_OBJECT;  if(SvIOKp(val)) {    PROTECT(ans = NEW_INTEGER(1));    INTEGER_DATA(ans)[0] = SvIV(val);    UNPROTECT(1);  } else if(SvNOKp(val)) {    PROTECT(ans = NEW_NUMERIC(1));    NUMERIC_DATA(ans)[0] = SvNV(val);    UNPROTECT(1);  } else if(SvPOK(val)) {    PROTECT(ans = NEW_CHARACTER(1));    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na)));    UNPROTECT(1);  } else if(SvROK(val)) {    fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!/n");fflush(stderr);  } else if(SvTYPE(val) == SVt_PVMG) {    /*XXX get more info about the type of the magic object.     struct magic *mg = SvMAGIC(val);    */    PROTECT(ans = createPerlReference(val));    UNPROTECT(1);  } else {    fprintf(stderr, "Cannot deal currently with Perl types %d/n", SvTYPE(val));fflush(stderr);  }  return(ans);}

SEXP wkt_to_p4s(SEXP wkt, SEXP esri) {    OGRSpatialReference hSRS = NULL;    char *pszSRS_P4 = NULL;    char **ppszInput = NULL;    SEXP ans;    ppszInput = CSLAddString(ppszInput, CHAR(STRING_ELT(wkt, 0)));    installErrorHandler();    if (hSRS.importFromWkt(ppszInput) != OGRERR_NONE) {        uninstallErrorHandlerAndTriggerError();	error("Can't parse WKT-style parameter string");    }    uninstallErrorHandlerAndTriggerError();    installErrorHandler();    if (INTEGER_POINTER(esri)[0] == 1) hSRS.morphFromESRI();    hSRS.exportToProj4(&pszSRS_P4);    uninstallErrorHandlerAndTriggerError();    PROTECT(ans=NEW_CHARACTER(1));    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(pszSRS_P4));    UNPROTECT(1);    return(ans);}

USER_OBJECT_R_internal_getGTypeHierarchy(GType type){  USER_OBJECT_ ans;  int n = 0;  GType orig = type;  while(type != 0 && type != G_TYPE_INVALID) {     type = g_type_parent(type);     n++;  }  PROTECT(ans = NEW_CHARACTER(n));  n = 0;  type = orig;  while(type != G_TYPE_INVALID) {     const char *val;     val = g_type_name(type);     SET_STRING_ELT(ans, n, COPY_TO_USER_STRING(val));     n++;     type =  g_type_parent(type);  }  UNPROTECT(1);  return(ans);}

voidR_getKeyNames(void *el, void *data, xmlChar *name){    RXMLHashScannerInfo *info = ( RXMLHashScannerInfo *) data;    SET_STRING_ELT(info->els, info->i, COPY_TO_USER_STRING(name));    info->i++;}

intloadXSLPackage(void){  USER_OBJECT_ e, fun, tmp;  int isError;  PROTECT(fun = Rf_findFun(Rf_install("library"), R_GlobalEnv));  PROTECT(e = allocVector(LANGSXP, 2));  SETCAR(e, fun);  SETCAR(CDR(e), tmp = NEW_CHARACTER(1));  SET_VECTOR_ELT(tmp, 0, COPY_TO_USER_STRING("Sxslt"));  R_tryEval(e, R_GlobalEnv, &isError);  if(isError) {      Rf_error("Couldn't load Sxslt package. Check the setting of R_LIBS");/*      fprintf(stderr, "Couldn't load Sxslt package. Check the setting of R_LIBS/n");      fflush(stderr);*/  }     UNPROTECT(2);  return(TRUE);}

int source(char *file){    SEXP expr, s, f, p;    int errorOccurred;    /* Find source function */    s = Rf_findFun(Rf_install("source"), R_GlobalEnv);    PROTECT(s);    /* Make file argument */    PROTECT(f = NEW_CHARACTER(1));    SET_STRING_ELT(f, 0, COPY_TO_USER_STRING(file));    /* Make print.eval argument */    PROTECT(p = NEW_LOGICAL(1));    LOGICAL_DATA(p)[0] = (verbose)? TRUE : FALSE;    /* expression source(f,print.eval=p) */    PROTECT(expr = allocVector(LANGSXP,3));    SETCAR(expr,s);     SETCAR(CDR(expr),f);    SETCAR(CDR(CDR(expr)), p);    SET_TAG(CDR(CDR(expr)), Rf_install("print.eval"));        errorOccurred=0;    R_tryEval(expr,NULL,&errorOccurred);    UNPROTECT(4);    return errorOccurred;}

SEXP rgeos_node(SEXP env, SEXP obj) {    SEXP ans, id;    int pc=0;        GEOSContextHandle_t GEOShandle = getContextHandle(env);    SEXP p4s = GET_SLOT(obj, install("proj4string"));    GEOSGeom geom = rgeos_convert_R2geos(env, obj);//    int type = GEOSGeomTypeId_r(GEOShandle, geom);//Rprintf("type: %d, %s/n", type, GEOSGeomType_r(GEOShandle, geom));        GEOSGeom res = GEOSNode_r(GEOShandle, geom);    //    type = GEOSGeomTypeId_r(GEOShandle, res);    int ng = GEOSGetNumGeometries_r(GEOShandle, res);//Rprintf("ng: %d, type: %d, %s/n", ng, type, GEOSGeomType_r(GEOShandle, res));    char buf[BUFSIZ];    PROTECT(id = NEW_CHARACTER(ng)); pc++;    for (int i=0; i<ng; i++) {        sprintf(buf, "%d", i);        SET_STRING_ELT(id, i, COPY_TO_USER_STRING(buf));    }    GEOSGeom_destroy_r(GEOShandle, geom);    ans = rgeos_convert_geos2R(env, res, p4s, id);     UNPROTECT(pc);    return(ans);}

/*  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);}

/* 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);}

SEXPRClosureTable_callWithName(R_ObjectTableAction handlerType, const char * const name, R_ObjectTable *tb){    SEXP obj, fun, val, e;    int errorOccurred = FALSE;    obj = (SEXP) tb->privateData;    fun = RClosureTable_getFunction(obj, handlerType);    if(!fun || fun == R_NilValue) {        return(NEW_LOGICAL(1));    }    PROTECT(e = allocVector(LANGSXP,2));    SETCAR(e, fun);    SETCAR(CDR(e), val = NEW_CHARACTER(1));    SET_STRING_ELT(val, 0, COPY_TO_USER_STRING(name));#ifndef TRY_EVAL    val = eval(e, R_GlobalEnv);#else    val = R_tryEval(e, NULL, &errorOccurred);#endif    if(errorOccurred) {        UNPROTECT(1);	return(R_UnboundValue);    }    UNPROTECT(1);    return(val);}

static USER_OBJECT_ convertRegistryValueToS(BYTE *val, DWORD size, DWORD valType){   USER_OBJECT_ ans = R_NilValue;;   switch(valType) {    case REG_DWORD:       ans = NEW_INTEGER(1);       INTEGER_DATA(ans)[0] = *((int *) val);       break;    case REG_SZ:    case REG_EXPAND_SZ:       PROTECT(ans = NEW_CHARACTER(1));       SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING((char *) val));       UNPROTECT(1);       break;   case REG_MULTI_SZ:     fprintf(stderr, "Muti_sz entry/n");     break;   case REG_BINARY:     fprintf(stderr, "Binary entry/n");     break;    default:      PROBLEM "No such type %d", (int) valType     ERROR;   }  return(ans);}

SEXP rgeos_GEOSversion(void) {    SEXP ans = NEW_CHARACTER(1);    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(GEOSversion()));    return(ans);}

USER_OBJECT_createFactor(USER_OBJECT_ vals, vartabled *vt, GGobiData *d, int which){  USER_OBJECT_ labels, levels, ans, e;  int i;  PROTECT(levels = NEW_INTEGER(vt->nlevels));  PROTECT(labels = NEW_CHARACTER(vt->nlevels));  for(i = 0; i < vt->nlevels; i++) {     INTEGER_DATA(levels)[i] = vt->level_values[i];	 if (vt->level_names[i])		 SET_STRING_ELT(labels, i, COPY_TO_USER_STRING(vt->level_names[i]));  }  PROTECT(e = allocVector(LANGSXP, 4));  SETCAR(e, Rf_install("factor"));  SETCAR(CDR(e), vals);  SETCAR(CDR(CDR(e)), levels);  SETCAR(CDR(CDR(CDR(e))), labels);  ans = eval(e, R_GlobalEnv);  UNPROTECT(3);   return(ans);}

SEXP R_G_get_cygwinstring() {      SEXP ans;      PROTECT(ans=NEW_CHARACTER(1));      SET_STRING_ELT(ans, 0,              COPY_TO_USER_STRING(G_get_cygwinstring()));      UNPROTECT(1);      return(ans);}

SEXP Rshapeinfo1(SEXP shpname){    SEXP res, nms;    SHPHandle	hSHP;    int    nShapeType, nEntities, i, pc=0;    double  adfMinBound[4], adfMaxBound[4];    PROTECT(res = NEW_LIST(5)); pc++;    PROTECT(nms = NEW_CHARACTER(5)); pc++;    SET_STRING_ELT(nms, 0, COPY_TO_USER_STRING("fname"));    SET_STRING_ELT(nms, 1, COPY_TO_USER_STRING("type"));    SET_STRING_ELT(nms, 2, COPY_TO_USER_STRING("entities"));    SET_STRING_ELT(nms, 3, COPY_TO_USER_STRING("minbounds"));    SET_STRING_ELT(nms, 4, COPY_TO_USER_STRING("maxbounds"));    setAttrib(res, R_NamesSymbol, nms);    SET_VECTOR_ELT(res, 0, NEW_CHARACTER(1));    SET_VECTOR_ELT(res, 1, NEW_INTEGER(1));    SET_VECTOR_ELT(res, 2, NEW_INTEGER(1));    SET_VECTOR_ELT(res, 3, NEW_NUMERIC(4));    SET_VECTOR_ELT(res, 4, NEW_NUMERIC(4));    SET_STRING_ELT(VECTOR_ELT(res, 0), 0, STRING_ELT(shpname, 0));    /*      const char 	*pszPlus; *//* -------------------------------------------------------------------- *//*      Open the passed shapefile.                                      *//* -------------------------------------------------------------------- */    hSHP = SHPOpen(CHAR(STRING_ELT(shpname, 0)), "rb" );    if( hSHP == NULL ) error("Error opening SHP file");/* -------------------------------------------------------------------- *//*      Print out the file bounds.                                      *//* -------------------------------------------------------------------- */    SHPGetInfo( hSHP, &nEntities, &nShapeType, adfMinBound, adfMaxBound );     INTEGER_POINTER(VECTOR_ELT(res, 1))[0] = nShapeType;    INTEGER_POINTER(VECTOR_ELT(res, 2))[0] = nEntities;    for (i=0; i<4; i++) {         NUMERIC_POINTER(VECTOR_ELT(res, 3))[i] = adfMinBound[i];        NUMERIC_POINTER(VECTOR_ELT(res, 4))[i] = adfMaxBound[i];    }    SHPClose( hSHP );       UNPROTECT(pc);    return(res);}

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);}

static voidgetKeys(void *el, void *data, xmlChar *name){   HashGatherer *d = (HashGatherer *)data;   SET_STRING_ELT(d->names, d->pos, COPY_TO_USER_STRING(name));   if(d->elType) {      SET_VECTOR_ELT(d->els, d->pos, R_makeRefObject(el, d->elType));   }   d->pos++;}