C++ NEW_LIST函数代码示例

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