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

SEXP rsqlite_query_send(SEXP handle, SEXP statement, SEXP bind_data) {  SQLiteConnection* con = rsqlite_connection_from_handle(handle);  sqlite3* db_connection = con->drvConnection;  sqlite3_stmt* db_statement = NULL;  int state, bind_count;  int rows = 0, cols = 0;  if (con->resultSet) {    if (con->resultSet->completed != 1)      warning("Closing result set with pending rows");    rsqlite_result_free(con);  }  rsqlite_result_alloc(con);  SQLiteResult* res = con->resultSet;  /* allocate and init a new result set */  res->completed = 0;  char* dyn_statement = RS_DBI_copyString(CHAR(asChar(statement)));  res->statement = dyn_statement;  res->drvResultSet = db_statement;  state = sqlite3_prepare_v2(db_connection, dyn_statement, -1,      &db_statement, NULL);  if (state != SQLITE_OK) {    exec_error(con, "error in statement");  }  if (db_statement == NULL) {    exec_error(con, "nothing to execute");  }  res->drvResultSet = (void*) db_statement;  bind_count = sqlite3_bind_parameter_count(db_statement);  if (bind_count > 0 && bind_data != R_NilValue) {    rows = GET_LENGTH(GET_ROWNAMES(bind_data));    cols = GET_LENGTH(bind_data);  }  res->isSelect = sqlite3_column_count(db_statement) > 0;  res->rowCount = 0;      /* fake's cursor's row count */  res->rowsAffected = -1; /* no rows affected */  rsqlite_exception_set(con, state, "OK");  if (res->isSelect) {    if (bind_count > 0) {      select_prepared_query(db_statement, bind_data, bind_count, rows, con);    }  } else {    if (bind_count > 0) {      non_select_prepared_query(db_statement, bind_data, bind_count, rows, con);    } else {      state = sqlite3_step(db_statement);      if (state != SQLITE_DONE) {        exec_error(con, "rsqlite_query_send: could not execute1");      }    }    res->completed = 1;    res->rowsAffected = sqlite3_changes(db_connection);  }  return handle;}

SEXPR_wxSlider_new(SEXP r_parent, SEXP r_id, SEXP r_value, SEXP r_min, SEXP r_max, SEXP r_pos, SEXP r_size, SEXP r_style){  wxWindow *parent;  wxWindowID id;  wxSlider *ans;  SEXP r_ans;  int value, min, max;  long style;  wxPoint pos = wxDefaultPosition;  wxSize size = wxDefaultSize;  parent = (wxWindow *) R_get_wxWidget_Ref(r_parent, NULL);  id = INTEGER(r_id)[0];  value = INTEGER(r_value)[0];  min = INTEGER(r_min)[0];  max = INTEGER(r_max)[0];  style = (long) REAL(r_style)[0];  if(GET_LENGTH(r_pos)) pos = R_to_wxPoint(r_pos);  if(GET_LENGTH(r_size)) size = R_to_wxSize(r_size);  ans = new wxSlider(parent, id, value, min, max, pos, size, style);  r_ans = R_make_wxWidget_Ref(ans, "wxSlider");    return(r_ans);}

void BigSum(BigMatrix *mat, SEXP colIndices, SEXP rowIndices, double *value) {    BMAccessorType m( *mat );        double *cols = NUMERIC_DATA(colIndices);    double *rows = NUMERIC_DATA(rowIndices);        index_type i=0;    index_type j=0;    index_type xj=0;    index_type numCols = GET_LENGTH(colIndices);    index_type numRows = GET_LENGTH(rowIndices);    CType *pColumn;        double s = 0;        for (i = 0; i < numCols; ++i) {        pColumn = m[static_cast<index_type>(cols[i])-1];        for (j = 0; j < numRows; ++j) {            xj = static_cast<index_type>(rows[j])-1;            s += (double)pColumn[xj];        }    }        value[0] = s;        return;}

SEXP geoddist_alongpath(SEXP lat, SEXP lon, SEXP a, SEXP f){  if (!isReal(lat))    error("latitude must be a numeric (floating-point) vector");  if (!isReal(lon))    error("longitude must be a numeric (floating-point) vector");  SEXP res;  //int n = INTEGER(GET_LENGTH(lat));  //int nlon = INTEGER(GET_LENGTH(lon));  int n = GET_LENGTH(lat);  int nlon = GET_LENGTH(lon);  if (n != nlon)    error("lengths of latitude and longitude vectors must match, but they are %d and %d, respectively", n, nlon);  double *latp = REAL(lat);  double *lonp = REAL(lon);  double *ap = REAL(a);  double *fp = REAL(f);  PROTECT(res = allocVector(REALSXP, n));  double *resp = REAL(res);  double last = 0.0;  resp[0] = ISNA(lonp[0]) ? NA_REAL : 0.0;  for (int i = 0; i < n-1; i++) {    double faz, baz, s;    if (ISNA(latp[i]) || ISNA(lonp[i]) || ISNA(latp[i+1]) || ISNA(lonp[i+1])) {      resp[i+1] = NA_REAL;      last = 0.0; // reset    } else {      geoddist_core(latp+i, lonp+i, latp+i+1, lonp+i+1, ap, fp, &faz, &baz, &s);      resp[i+1] = last + s;      last = resp[i+1];    }  }  UNPROTECT(1);  return(res);}

SEXP geoddist(SEXP lat1, SEXP lon1, SEXP lat2, SEXP lon2, SEXP a, SEXP f){  if (!isReal(lat1)) error("lat1 must be a numeric (floating-point) vector");  if (!isReal(lon1)) error("lon1 must be a numeric (floating-point) vector");  if (!isReal(lat2)) error("lat2 must be a numeric (floating-point) vector");  if (!isReal(lon2)) error("lon2 must be a numeric (floating-point) vector");  int n = GET_LENGTH(lat1);  if (n != GET_LENGTH(lon1))    error("lengths of lat1 and lon1 must match, but they are %d and %d respectively.", n, GET_LENGTH(lon1));  if (n != GET_LENGTH(lat2))    error("lengths of lat1 and lat2 must match, but they are %d and %d respectively.", n, GET_LENGTH(lat2));  if (n != GET_LENGTH(lon2))    error("lengths of lon1 and lon2 must match, but they are %d and %d respectively.", n, GET_LENGTH(lon2));  double *lat1p = REAL(lat1);  double *lon1p = REAL(lon1);  double *lat2p = REAL(lat2);  double *lon2p = REAL(lon2);  double *ap = REAL(a);  double *fp = REAL(f);  SEXP res;  PROTECT(res = allocVector(REALSXP, n));  double *resp = REAL(res);  for (int i = 0; i < n; i++) {    double faz, baz, s;    geoddist_core(lat1p+i, lon1p+i, lat2p+i, lon2p+i, ap, fp, &faz, &baz, &s);    resp[i] = s;  }  UNPROTECT(1);  return(res);}

////////////////////////////////////////////////////////////// C'torRootChainManager::RootChainManager(SEXP treeName, SEXP fileList, bool verbose, bool trace) :  m_chain(0),  m_verbose(verbose),  m_trace(trace){  // Check arguments  if ( ! IS_CHARACTER(treeName) ) error("treeName must be a string");  if ( GET_LENGTH(treeName) != 1) error("treeName must have length 1");  if ( ! IS_CHARACTER(fileList) ) error("fileList must be a list of strings");	   // Get the tree name	std::string treeNameC = CHAR(STRING_ELT(treeName, 0));	   if (m_verbose) REprintf("Will read tree %s/n", treeNameC.c_str());	   // Get the list of files to chain  if (m_verbose)     REprintf("There are %d files to add to the chain/n", GET_LENGTH(fileList) );	   // Form the chain from the file lists  m_chain = new TChain(treeNameC.c_str());	   // Add files  for ( unsigned int i = 0; i < GET_LENGTH(fileList); ++i ) {    		std::string fileNameC = CHAR(STRING_ELT(fileList, i) );    if (m_verbose) REprintf("Adding file %s to chain/n", fileNameC.c_str());    m_chain->Add( fileNameC.c_str(), 0 );  }}

void DeepCopy(BigMatrix *pInMat, BigMatrix *pOutMat, SEXP rowInds, SEXP colInds){    in_BMAccessorType inMat( *pInMat );    out_BMAccessorType outMat( *pOutMat );    double *pRows = NUMERIC_DATA(rowInds);    double *pCols = NUMERIC_DATA(colInds);    index_type nRows = GET_LENGTH(rowInds);    index_type nCols = GET_LENGTH(colInds);    if (nRows != pOutMat->nrow())        Rf_error("length of row indices does not equal # of rows in new matrix");    if (nCols != pOutMat->ncol())        Rf_error("length of col indices does not equal # of cols in new matrix");    index_type i = 0;    index_type j = 0;    in_CType *pInColumn;    out_CType *pOutColumn;    for (i = 0; i < nCols; ++i) {        pInColumn = inMat[static_cast<index_type>(pCols[i])-1];        pOutColumn = outMat[i];        for (j = 0; j < nRows; ++j) {            pOutColumn[j] = static_cast<out_CType>(                                pInColumn[static_cast<index_type>(pRows[j])-1]);        }    }    return;}

USER_OBJECT_RGnumeric_setCellComment(USER_OBJECT_ scell, USER_OBJECT_ stext, USER_OBJECT_ sauthor){  char *text = NULL, *author = NULL;  CellComment *comment;  Cell *cell;  USER_OBJECT_ ans = NULL_USER_OBJECT;  cell = RGnumeric_resolveCellReference(scell);  if(!cell)    PROBLEM "invalid cell reference object"    ERROR;  if(GET_LENGTH(stext))    text = CHAR_DEREF(STRING_ELT(stext, 0));  if(GET_LENGTH(sauthor))    author = CHAR_DEREF(STRING_ELT(sauthor, 0));  comment = cell_has_comment(cell);   if(!comment) {      Sheet *sheet;        sheet = RGnumeric_resolveSheetReference(VECTOR_ELT(scell, 1));        cell_set_comment(sheet, &(cell->pos), (const char*) author, (const char *)text);  } else {      if(text)        cell_comment_text_set(comment, text);      if(author)        cell_comment_author_set(comment, author);  }  return(ans);}

static int php_is_r_primitive(SEXP val, SEXPTYPE *type) /* {{{ */{	int is = 0;	if (GET_LENGTH(GET_DIM(val))) {		return 0;	}	if (GET_LENGTH(GET_CLASS(val))) {		return 0;	}	*type = TYPEOF(val);	switch (*type) {		case REALSXP:		case LGLSXP:		case STRSXP:		case INTSXP:			is = 1;		default:			break;	}	return is;}

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

SEXP Expect_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP theta0, SEXP theta1, SEXP matdiag){        int nvar, npoints, nprotect=0;        nvar = GET_LENGTH(lambda);    npoints = GET_LENGTH(time);        PROTECT(time = coerceVector(time,REALSXP)); nprotect++;    PROTECT(theta0 = coerceVector(theta0,REALSXP)); nprotect++;    PROTECT(theta1 = coerceVector(theta1,REALSXP)); nprotect++;    // results    SEXP expectation = PROTECT(allocVector(REALSXP,nvar*npoints)); nprotect++;        if(!isComplex(lambda)){    // eigenvectors    PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;    PROTECT(S = coerceVector(S,REALSXP)); nprotect++;    // matrix exponential    SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;    // Compute the exponential matrix    multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));        // Compute the expectations    optimum (&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), REAL(matexp), REAL(matdiag));    // Done.            }else{        double complex *matexp;    // complex eigenvalues & eigenvectors    PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;    PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;            // alloc a complex vector in C rather than R structure...    matexp = Calloc(nvar*nvar*npoints,double complex);            // Compute the exponential matrix    multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);            // Compute the expectations    optimum_complex(&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), matexp, REAL(matdiag));    // Done.    // Free the memory    Free(matexp);    }    UNPROTECT(nprotect);    return expectation;    }

// Weight matrixSEXP Weight_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP matdiag){        int nvar, npoints, vdim[2], nprotect = 0;    nvar = GET_LENGTH(lambda);    npoints = GET_LENGTH(time);    SEXP expectation;    vdim[0] = npoints*nvar; vdim[1] = nvar*2;    PROTECT(expectation = makearray(2,vdim)); nprotect++;        if(!isComplex(lambda)){        // eigenvectors        PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;        PROTECT(S = coerceVector(S,REALSXP)); nprotect++;        // matrix exponential        SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;            // Compute the exponential matrix        multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));            // Compute the expectations        build_w (&nvar, &npoints, REAL(time), REAL(expectation), REAL(matexp), REAL(matdiag));        // Done.    }else{                double complex *matexp;        // complex eigenvalues & eigenvectors        PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;        PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;                // alloc a complex vector in C rather than R structure...        matexp = Calloc(nvar*nvar*npoints,double complex);                // Compute the exponential matrix        multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);                // Compute the expectations        build_w_complex (&nvar, &npoints, REAL(time), REAL(expectation), matexp, REAL(matdiag));                // Done.        // Free the memory        Free(matexp);    }    UNPROTECT(nprotect);    return expectation;    }

USER_OBJECT_RS_PerlUndef(USER_OBJECT_ ids, USER_OBJECT_ types, USER_OBJECT_ interpreter){ int n, nt; int i,j; const char *id; int count; USER_OBJECT_ ans; n = GET_LENGTH(ids); nt = GET_LENGTH(types); PROTECT(ans = NEW_LIST(n));  for(i = 0; i < n; i++) {    id = CHAR_DEREF(STRING_ELT(ids, i));    count = 0;    for(j = 0; i < nt; i++) {	   if(LOGICAL_DATA(types)[i] == TRUE) {	     count++;	     switch(i) {		     case PERL_SCALAR:				     			break;		     case PERL_ARRAY:				     			break;		     case PERL_HASH:				     			break;		     case PERL_SUB:				     			break;		     default:                       break;	     } /* switch() */	   } /* end of if LOGICAL_DATA() */    } /* type loop */    if(count == 0) {      /* Was a composite identifier such as $x{'y'} so have to handle it specially. */    }  } /* ids loop */  UNPROTECT(1);  return(ans); }

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

/////////////////////////// Return a logical vector if entries are in the event listSEXP isInEventList(SEXP eventList, SEXP entryNums){    TEventList* el = checkForEventListWrapper(eventList);    SEXP l;  PROTECT(l = NEW_LOGICAL( GET_LENGTH(entryNums) ) );    for ( unsigned int i = 0; i < GET_LENGTH(entryNums); ++i ) {    LOGICAL(l)[i] = el->Contains( INTEGER(entryNums)[i] ) == 1;  }    UNPROTECT(1);    return l;}

RbooleanR_isInstanceOf(USER_OBJECT_ obj, const char *klass){    USER_OBJECT_ klasses;    int n, i;    SEXP e, r_ans;    Rboolean ans;    klasses = GET_CLASS(obj);    n = GET_LENGTH(klasses);    for(i = 0; i < n ; i++) {	if(strcmp(CHAR_DEREF(STRING_ELT(klasses, i)), klass) == 0)	    return(TRUE);    }    PROTECT(e = allocVector(LANGSXP, 3));    SETCAR(e, Rf_install("is"));    SETCAR(CDR(e), obj);    SETCAR(CDR(CDR(e)), mkString(klass));    r_ans = Rf_eval(e, R_GlobalEnv);    ans = LOGICAL(r_ans)[0];    UNPROTECT(1);    return(ans);}

guintasCFlag(USER_OBJECT_ s_flag, GType ftype){    GFlagsClass* fclass = g_type_class_ref(ftype);    guint flags = 0;    if (IS_INTEGER(s_flag) || IS_NUMERIC(s_flag)) {        if (asCNumeric(s_flag) > fclass->mask) {            PROBLEM "The flags value %f is too high", asCNumeric(s_flag)            ERROR;        }        flags = asCNumeric(s_flag);    } else {        int i;        for (i = 0; i < GET_LENGTH(s_flag); i++) {            const gchar *fname = CHAR_DEREF(STRING_ELT(s_flag, i));            /*Rprintf("Searching for flag value %s/n", fname);*/            GFlagsValue *fvalue = g_flags_get_value_by_name(fclass, fname);            if (!fvalue)                fvalue = g_flags_get_value_by_nick(fclass, fname);            if (!fvalue && atoi(fname) <= fclass->mask) {                flags |= atoi(fname);                continue;            }            if (!fvalue) {                PROBLEM "Could not find flag by name %s", fname                ERROR;            }            /*Rprintf("Found: %d/n", fvalue->value);*/            flags |= fvalue->value;        }    }    return(flags);}

// KErrBadDescriptor, if message length too small// KErrUnderFlow, if message length too big.// KErrCouldNotConnect, if receiver object is out of scope.TInt DISICLTransceiver::ValidateISIMessage(        TDes8& aMessage        )    {    C_TRACE( ( _T( "DISICLTransceiver::ValidateISIMessage 0x%x>" ), &aMessage ) );    const TUint16 descLength( aMessage.Length() );    TInt msgOk( KErrNone );    msgOk = ( ISI_HEADER_OFFSET_MESSAGEID >= descLength ) ? KErrBadDescriptor : msgOk;    TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );    // Get ISI message length after known that the descriptor is big enough.    const TUint8* msgPtr( aMessage.Ptr() );    const TUint16 isiMsgLength( GET_LENGTH( msgPtr ) + PN_HEADER_SIZE );    // If the descriptor length is less than ISI message length.    msgOk = ( ( msgOk == KErrNone && isiMsgLength > descLength ) ? KErrUnderflow : msgOk );    TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );    // If the ISI message length is bigger that the largest supported.    msgOk = ( ( msgOk == KErrNone && isiMsgLength > KMaxISIMsgSize ) ? KErrUnderflow : msgOk );    TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );    // If the ISI message length with PN_HEADER_SIZE is less or equal than ISI_HEADER_OFFSET_MESSAGEID.    msgOk = ( ( msgOk == KErrNone && isiMsgLength <= ISI_HEADER_OFFSET_MESSAGEID ) ? KErrUnderflow : msgOk );    TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );    TRACE_ASSERT_INFO( msgOk == KErrNone, isiMsgLength );    TRACE_ASSERT_INFO( msgOk == KErrNone, descLength );    C_TRACE( ( _T( "DISICLTransceiver::ValidateISIMessage %d<" ), msgOk ) );    return msgOk;    }

#include "RS_XML.h"#include <libxml/xpath.h>#include "Utils.h"static SEXPconvertNodeSetToR(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);}SEXPconvertXPathObjectToR(xmlXPathObjectPtr obj, SEXP fun, int encoding, SEXP manageMemory){  SEXP ans = NULL_USER_OBJECT;  switch(obj->type) {    case XPATH_NODESET:        ans = convertNodeSetToR(obj->nodesetval, fun, encoding, manageMemory);	break;    case XPATH_BOOLEAN:	ans = ScalarLogical(obj->boolval);	break;    case XPATH_NUMBER:	ans = ScalarReal(obj->floatval);	if(xmlXPathIsInf(obj->floatval))	    REAL(ans)[0] = xmlXPathIsInf(obj->floatval) < 0 ? R_NegInf : R_PosInf;        else if(xmlXPathIsNaN(obj->floatval))	    REAL(ans)[0] = NA_REAL;	break;    case XPATH_STRING:        ans = mkString(XMLCHAR_TO_CHAR(obj->stringval)); //XXX encoding 	break;    case XPATH_POINT:    case XPATH_RANGE:    case XPATH_LOCATIONSET:    case XPATH_USERS:	PROBLEM "currently unsupported xmlXPathObject type %d in convertXPathObjectToR. Please send mail to maintainer.", obj->type        WARN    default:	ans = R_NilValue;  }  return(ans);}//.........这里部分代码省略.........

doubleasCNumeric(USER_OBJECT_ s_num){	if (GET_LENGTH(s_num) == 0)		return(0);    return(NUMERIC_DATA(s_num)[0]);}

gucharasCRaw(USER_OBJECT_ s_raw){	if (GET_LENGTH(s_raw) == 0)		return(0);    return(RAW(s_raw)[0]);}

intasCInteger(USER_OBJECT_ s_int){	if (GET_LENGTH(s_int) == 0)		return(0);    return(INTEGER_DATA(s_int)[0]);}

gbooleanasCLogical(USER_OBJECT_ s_log){    if (GET_LENGTH(s_log) == 0)		return(FALSE);	return(LOGICAL_DATA(s_log)[0]);}

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

SEXPR_setInitialModuleFunction(SEXP v){   SEXP prev;   if(R_initializeModuleFunction && GET_LENGTH(R_initializeModuleFunction))       R_ReleaseObject(R_initializeModuleFunction);   prev = R_initializeModuleFunction ? R_initializeModuleFunction : R_NilValue;   if(GET_LENGTH(v))       R_PreserveObject(v);   R_initializeModuleFunction = v;      return(prev);}

/* * Open a connection to an existing kdb+ process. * * If we just have a host and port we call khp from the kdb+ interface. * If we have a host, port, "username:password" we call instead khpu. */SEXP kx_r_open_connection(SEXP whence){	SEXP result;	int connection, port;	char *host;	int length = GET_LENGTH(whence);	if (length < 2)		error("Can't connect with so few parameters..");	port = INTEGER_POINTER (VECTOR_ELT(whence, 1))[0];	host = (char*) CHARACTER_VALUE(VECTOR_ELT(whence, 0));	if (2 == length)		connection = khp(host, port);	else {		char *user = (char*) CHARACTER_VALUE(VECTOR_ELT (whence, 2));		connection = khpu(host, port, user);	}        if (!connection)          error("Could not authenticate");        else if (connection < 0) {#ifdef WIN32          char buf[256];          FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),                        MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), buf, 256, NULL);          error(buf);#else	  error(strerror(errno));#endif	}	PROTECT(result = NEW_INTEGER(1));	INTEGER_POINTER(result)[0] = connection;	UNPROTECT(1);	return result;}

static void php_r_to_zval(SEXP value, zval *result) /* {{{ */{	int value_len, i;	zval_dtor(result);	array_init(result);	value_len = GET_LENGTH(value);	if (value_len == 0) {		return;	}		for (i = 0; i < value_len; i++) {		switch (TYPEOF(value)) {			case INTSXP:				add_next_index_long(result, INTEGER_DATA(value)[i]);				break;			case REALSXP:				add_next_index_double(result, NUMERIC_DATA(value)[i]);				break;			case LGLSXP:				add_next_index_bool(result, LOGICAL_DATA(value)[i]);				break;			case STRSXP:				add_next_index_string(result, CHAR(STRING_ELT(value, 0)), 1);				break;		}	}	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_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);}

SEXPsimplifyRList(SEXP l){	int i, n;	int type = TYPEOF(VECTOR_ELT(l, 0));        SEXP  el;	n = GET_LENGTH(l);	for(i = 1; i < n  ; i++) {  	  el = VECTOR_ELT(l, i);          if(type != TYPEOF(el))    	     return(l);	}	if(type != INTSXP && type != LGLSXP && type != STRSXP && type != REALSXP && type != CPLXSXP)  	  return(l);	{		SEXP e;		PROTECT(e = allocVector(LANGSXP, 2));		SETCAR(e, Rf_install("unlist"));		SETCAR(CDR(e), l);		l = Rf_eval(e, R_GlobalEnv);		UNPROTECT(1);	}	return(l);}