C++ NEW_CHARACTER函数代码示例

SEXP
R_xslGetGlobalVariableNames(SEXP r_ctxt)
{
    xmlXPathParserContextPtr ctxt = NULL;
    xsltTransformContextPtr xslCtxt;
    int n;
    SEXP ans;
    RXMLHashScannerInfo data;

    ctxt = (xmlXPathParserContextPtr) R_ExternalPtrAddr(r_ctxt);
    xslCtxt = xsltXPathGetTransformContext(ctxt);

    if(!xslCtxt || !xslCtxt->globalVars) 
	return(NEW_CHARACTER(0));

    n = xmlHashSize(xslCtxt->globalVars);

    PROTECT(ans = NEW_CHARACTER(n));

    data.els = ans;
    data.i = 0;
    xmlHashScan(xslCtxt->globalVars, R_getKeyNames, &data);
    UNPROTECT(1);
    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);
}

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

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

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

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

void
RXSLT_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_
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);
}

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

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

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 rgeos_GEOSversion(void) {

    SEXP ans = NEW_CHARACTER(1);
    SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(GEOSversion()));

    return(ans);
}