C++ R_ExternalPtrTag函数代码示例

/**
  Convert R object into either a function or the address of a C routine.
  For a C routine, the caller can specify the name of the typedef which is
  checked using the TAG for the external pointer.
*/
void *
Rfrom_Callbable(SEXP obj, const char * const TypeDefName, CallableType *type) 
{

           /* If TypeDefName is NULL, we don't bother checking*/
        if(TYPEOF(obj) == EXTPTRSXP) {
	    if(TypeDefName && R_ExternalPtrTag(obj) != Rf_install(TypeDefName)) {
   	         PROBLEM "[RfromCallbable] incorrect type name for a native routine pointer %s, not %s",
		    CHAR(asChar(R_ExternalPtrTag(obj))), TypeDefName
		 ERROR;
	    }

	    if(type) 
		*type = NATIVE_ROUTINE;

	    return(R_ExternalPtrAddr(obj));
        } else if(TYPEOF(obj) == CLOSXP) {
	    if(type) 
		*type = R_FUNCTION;
	    return(obj);
	}

	PROBLEM  "the Rfrom_Callable routine only handles native routines and "
        ERROR;

	return((void *) NULL);
   }

void *
derefRDCOMPointer(SEXP el)
{
 void *ptr = NULL;

 if(TYPEOF(el) != EXTPTRSXP || el == R_NilValue) {
   PROBLEM "Looking at a COM object that does not have an external pointer in the ref slot"
   ERROR;
 }

#if USE_COM_SYMBOLS
 if(R_ExternalPtrTag(el) != R_IDispatchSym || R_ExternalPtrTag(el) != R_IUnknownSym) {
   PROBLEM "Unusual RCOM object since the internal tag is not one we have seen."
   WARN;
 }
#endif

 ptr = R_ExternalPtrAddr(el);

 if(!ptr) {
   PROBLEM "RDCOM Reference object is not valid (NULL). This may be due to restoring it from a previous session."
   ERROR;
 } 

 return(ptr);
}

void *
R_getExternalRef(SEXP obj, const char *className) 
{
   SEXP ref = GET_SLOT(obj, Rf_install("ref")); 
   void *ans;

   if(TYPEOF(ref) != EXTPTRSXP) { 
      PROBLEM "Expected external pointer object" 
      ERROR; 
   } 

   if(className && R_ExternalPtrTag(ref) != Rf_install(className)) { 
      PROBLEM "Expected external pointer to have internal tag %s, got %s",  
  	     className, CHAR(PRINTNAME(R_ExternalPtrTag(ref)))
      ERROR; 
   } 

   ans = R_ExternalPtrAddr(ref);
   if(!ans) {
       PROBLEM "Got NULL value in reference for %s", className
       ERROR;
   }

   return(ans); 
} 

void *
R_getNativeReference(SEXP arg, const char *type, const char *tag)
{
 SEXP el = GET_SLOT(arg, Rf_install("ref"));
 void *ans;
 if(R_ExternalPtrTag(el) != Rf_install(tag)) {

        /* So not a direct match. Now see if it is from a derived class
           by comparing the value in the object to the name of each of the
           ancestor classes.
         */
    SEXP ancestors = GET_SLOT(arg, Rf_install("classes"));
    int n, i;
    n = Rf_length(ancestors);
    for(i = 0; i < n  ; i ++) {
        if(strcmp(CHAR(STRING_ELT(ancestors, i)), tag) == 0)
  	   break;
    }
    if(i == n) {
      PROBLEM "Looking for %s, got %s",
	      type, CHAR(PRINTNAME(R_ExternalPtrTag(el)))
      ERROR;
    }
 }

 ans = R_ExternalPtrAddr(el);

 if(!ans) {
   PROBLEM "NULL value passed to R_getNativeReference. This may not be an error, but it could be very serious!"
   ERROR;
 }
 return(ans);
}

	void checkPointer(SEXP s) {
		if (TYPEOF(s) != EXTPTRSXP) {
			errorLog << "Pointer is not EXTPTRSXP" << endl << errorExit;
		}
		if (R_ExternalPtrTag(s) != install("AbstractMatrix") && R_ExternalPtrTag(s) != install("FilteredMatrix")) {
			errorLog << "R_ExternalPtrTag(s) = " << (void*)R_ExternalPtrTag(s) << endl;
			errorLog << "Pointer is not AbstractMatrix nor FilteredMatrix" << endl << errorExit;
		}
	}

SEXP get_intervals_from_stream(SEXP streamid)
{
	int sid = *INTEGER(R_ExternalPtrTag(streamid));

	if(current_streams.find(sid) == current_streams.end())
		return (R_NilValue);

	jobject intervals = env->CallObjectMethod(p, fn["Persistence.computeIntervals"], current_streams[sid]);
	
	jfieldID dimension = env->GetFieldID(cl["PersistenceInterval.Float"], "dimension", "I");
	jfieldID start = env->GetFieldID(cl["PersistenceInterval.Float"], "start", "D");
	jfieldID end = env->GetFieldID(cl["PersistenceInterval.Float"], "end", "D");

	int len = env->GetArrayLength((jobjectArray)intervals);

	SEXP pintervals;

	PROTECT(pintervals = allocVector(REALSXP, 3*len));

	for(int i = 0; i < len; i++)
	{
		jobject firstint = env->GetObjectArrayElement((jobjectArray)intervals, i); 
		REAL(pintervals)[3*i + 0] = (double)env->GetIntField(firstint, dimension); 
		REAL(pintervals)[3*i + 1] = (double)env->GetDoubleField(firstint, start); 
		REAL(pintervals)[3*i + 2] = (double)env->GetDoubleField(firstint, end); 
	}

	UNPROTECT(1);

	if(env->ExceptionOccurred())
		return R_exception();

	return(pintervals);
} 

porStreamBuf *get_porStreamBuf(SEXP porStream){
  if(TYPEOF(porStream) != EXTPTRSXP || R_ExternalPtrTag(porStream) != install("porStreamBuf"))
    error("not a porStream");
  porStreamBuf *b = R_ExternalPtrAddr(porStream);
  if (b == NULL){
    b = Calloc(1,porStreamBuf);
    R_SetExternalPtrAddr(porStream,b);
    initPorStreamBuf(b);
    SEXP name = getAttrib(porStream,install("file.name"));
    if(name == R_NilValue || name == NULL){
      R_SetExternalPtrAddr(porStream,NULL);
      Free(b);
      error("need filename to reopen file");
      }
    b->f = fopen(CHAR(STRING_ELT(name, 0)),"rb");
    if(b->f == NULL){
      R_SetExternalPtrAddr(porStream,NULL);
      Free(b);
      error("cannot reopen file -- does it still exist?");
    }
    Rprintf("File '%s' reopened\n",CHAR(STRING_ELT(name, 0)));
  }
  if (b == NULL) error("something strange happened here!?");
  return(b);
}

SEXP attribute_hidden
do_getRegisteredRoutines(SEXP call, SEXP op, SEXP args, SEXP env)
{
    const char * const names[] = {".C", ".Call", ".Fortran", ".External"};

    checkArity(op, args);
    SEXP dll = CAR(args), ans, snames;

    if(TYPEOF(dll) != EXTPTRSXP &&
       R_ExternalPtrTag(dll) != install("DLLInfo"))
	error(_("R_getRegisteredRoutines() expects a DllInfo reference"));

    DllInfo *info = (DllInfo *) R_ExternalPtrAddr(dll);
    if(!info) error(_("NULL value passed for DllInfo"));


    PROTECT(ans = allocVector(VECSXP, 4));

    SET_VECTOR_ELT(ans, 0, R_getRoutineSymbols(R_C_SYM, info));
    SET_VECTOR_ELT(ans, 1, R_getRoutineSymbols(R_CALL_SYM, info));
    SET_VECTOR_ELT(ans, 2, R_getRoutineSymbols(R_FORTRAN_SYM, info));
    SET_VECTOR_ELT(ans, 3, R_getRoutineSymbols(R_EXTERNAL_SYM, info));

    PROTECT(snames = allocVector(STRSXP, 4));
    for(int i = 0; i < 4; i++)
	SET_STRING_ELT(snames, i, mkChar(names[i]));
    setAttrib(ans, R_NamesSymbol, snames);
    UNPROTECT(2);
    return(ans);
}

SEXP attribute_hidden
do_getSymbolInfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
    const char *package = "", *name;
    R_RegisteredNativeSymbol symbol = {R_ANY_SYM, {NULL}, NULL};
    SEXP sym = R_NilValue;
    DL_FUNC f = NULL;

    checkArity(op, args);
    SEXP sname = CAR(args), spackage = CADR(args), 
	withRegistrationInfo = CADDR(args);

    name = translateChar(STRING_ELT(sname, 0));
    if(length(spackage)) {
	if(TYPEOF(spackage) == STRSXP)
	    package = translateChar(STRING_ELT(spackage, 0));
	else if(TYPEOF(spackage) == EXTPTRSXP &&
		R_ExternalPtrTag(spackage) == install("DLLInfo")) {
	    f = R_dlsym((DllInfo *) R_ExternalPtrAddr(spackage), name, &symbol);
	    package = NULL;
	} else
	    error(_("must pass package name or DllInfo reference"));
    }
    if(package)
	f = R_FindSymbol(name, package, &symbol);
    if(f)
	sym = createRSymbolObject(sname, f, &symbol,
				  LOGICAL(withRegistrationInfo)[0]);
    return sym;
}

USER_OBJECT_
directConvertFromPerl(SV * perlObj, USER_OBJECT_ convert)
{
  USER_OBJECT_ ans = NULL_USER_OBJECT;

  if(TYPEOF(convert) == CLOSXP) {
     SEXP e, ref;
     PROTECT(e = allocVector(LANGSXP, 2));
     SETCAR(e, convert);

     PROTECT(ref = makeForeignPerlReference((SV*) perlObj, makeRSPerlClassVector("PerlReference"), &exportReferenceTable));
/* Alternative way of creating the reference.
     SEXP classes;
     PROTECT(classes = computeRSPerlClassVector(val, &elementType, convert));
     PROTECT(ref = makeForeignPerlReference(perlObj, classes, &exportReferenceTable)); 
*/
     SETCAR(CDR(e), ref);
     ans = Rf_eval(e, R_GlobalEnv);

     UNPROTECT(2);
  } else if(TYPEOF(convert) == EXTPTRSXP) {
     FromPerlNativeConverter f;
     if(R_ExternalPtrTag(convert) != Rf_install("native symbol")) {
       PROBLEM  "Unrecognized external pointer passed to directConvertFromPerlRoutine"
       ERROR;
     }
     f = (FromPerlNativeConverter)  R_ExternalPtrAddr(convert);
     ans = f(perlObj);
  }

  return(ans);
}

static int _selfrefok(SEXP x, Rboolean checkNames, Rboolean verbose) {
    SEXP v, p, tag, prot, names;
    v = getAttrib(x, SelfRefSymbol);
    if (v==R_NilValue || TYPEOF(v)!=EXTPTRSXP) {
        // .internal.selfref missing is expected and normal for i) a pre v1.7.8 data.table loaded
        //  from disk, and ii) every time a new data.table is over-allocated for the first time.
        //  Not being an extptr is for when users contruct a data.table via structure() using dput, post
        //  a question, and find the extptr doesn't parse so put quotes around it (for example).
        //  In both cases the selfref is not ok.
        return 0;
    }
    p = R_ExternalPtrAddr(v);
    if (p==NULL) {
        if (verbose) Rprintf(".internal.selfref ptr is NULL. This is expected and normal for a data.table loaded from disk. If not, please report to datatable-help.\n");
        return -1;
    }
    if (!isNull(p)) error("Internal error: .internal.selfref ptr is not NULL or R_NilValue");
    tag = R_ExternalPtrTag(v);
    if (!(isNull(tag) || isString(tag))) error("Internal error: .internal.selfref tag isn't NULL or a character vector");
    names = getAttrib(x, R_NamesSymbol);
    if (names != tag && isString(names))
        SET_TRUELENGTH(names, LENGTH(names)); 
        // R copied this vector not data.table; it's not actually over-allocated. It looks over-allocated
        // because R copies the original vector's tl over despite allocating length.
    prot = R_ExternalPtrProtected(v);
    if (TYPEOF(prot) != EXTPTRSXP)   // Very rare. Was error(".internal.selfref prot is not itself an extptr").
        return 0;                    // See http://stackoverflow.com/questions/15342227/getting-a-random-internal-selfref-error-in-data-table-for-r
    if (x != R_ExternalPtrAddr(prot))
        SET_TRUELENGTH(x, LENGTH(x));  // R copied this vector not data.table, it's not actually over-allocated
    return checkNames ? names==tag : x==R_ExternalPtrAddr(prot);
}

SEXP make_random_landmarks(SEXP pdata_handle, SEXP landmark_count)
{
	int sid = *INTEGER(R_ExternalPtrTag(pdata_handle));
	if(current_pointdata.find(sid) == current_pointdata.end())
		return (R_NilValue);

	jobject arr = env->CallStaticObjectMethod(cl["WitnessStream"], fn["WitnessStream.<s>makeRandomLandmarks"],
		current_pointdata[sid], *INTEGER(landmark_count));

	int len = env->GetArrayLength((jintArray)arr);

	SEXP landmarks_arr;

	PROTECT(landmarks_arr = allocVector(INTSXP, len));

	int *parr = env->GetIntArrayElements((jintArray)arr, NULL);
	memcpy(INTEGER(landmarks_arr), parr, len*sizeof(int));
	env->ReleaseIntArrayElements((jintArray)arr, parr, JNI_ABORT);

	UNPROTECT(1);

	if(env->ExceptionOccurred())
		return R_exception();

	return landmarks_arr;
}

/* {{{ rberkeley_db_exists */
SEXP rberkeley_db_exists (SEXP _dbp, SEXP _txnid, SEXP _key, SEXP _flags)
{
  DB *dbp;
  DB_TXN *txnid;
  DBT key;
  u_int32_t flags;
  int ret;

  memset(&key, 0, sizeof(DBT));

  if(TYPEOF(_flags) == INTSXP)
    flags = (u_int32_t)INTEGER(_flags)[0];
  else flags=0;

  flags = 0; /* only accepts 0 */

  key.data = (unsigned char *)RAW(_key);
  key.size = length(_key);

  dbp = R_ExternalPtrAddr(_dbp);
  if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
    error("invalid 'db' handle");

  if(!isNull(_txnid)) {
    txnid = R_ExternalPtrAddr(_txnid);
  } else txnid = NULL;

  ret = dbp->exists(dbp, txnid, &key, flags);
  
  return ScalarInteger(ret);
}

/*
  This is the routine associated with the getNativeSymbolInfo()
  function and it takes the name of a symbol and optionally an
  object identifier (package usually) in which to restrict the search
  for this symbol. It resolves the symbol and returns it to the caller
  giving the symbol address, the package information (i.e. name and
  fully qualified shared object name). If the symbol was explicitly
  registered (rather than dynamically resolved by R), then we pass
  back that information also, giving the number of arguments it
  expects and the interface by which it should be called.
  The returned object has class NativeSymbol. If the symbol was
  registered, we add a class identifying the interface type
  for which it is intended (i.e. .C(), .Call(), etc.)
 */
SEXP attribute_hidden
R_getSymbolInfo(SEXP sname, SEXP spackage, SEXP withRegistrationInfo)
{
    const void *vmax = vmaxget();
    const char *package, *name;
    R_RegisteredNativeSymbol symbol = {R_ANY_SYM, {NULL}, NULL};
    SEXP sym = R_NilValue;
    DL_FUNC f = NULL;

    package = "";

    name = translateChar(STRING_ELT(sname, 0));

    if(length(spackage)) {
	if(TYPEOF(spackage) == STRSXP)
	    package = translateChar(STRING_ELT(spackage, 0));
	else if(TYPEOF(spackage) == EXTPTRSXP &&
		R_ExternalPtrTag(spackage) == install("DLLInfo")) {
	    f = R_dlsym((DllInfo *) R_ExternalPtrAddr(spackage), name, &symbol);
	    package = NULL;
	} else
	    error(_("must pass package name or DllInfo reference"));
    }

    if(package)
	f = R_FindSymbol(name, package, &symbol);

    if(f)
	sym = createRSymbolObject(sname, f, &symbol,
				  LOGICAL(withRegistrationInfo)[0]);

    vmaxset(vmax);
    return sym;
}

SEXP is_extmat(SEXP ptr) {
  SEXP ans;
  ext_matrix *e = NULL;

  PROTECT(ans = allocVector(LGLSXP, 1));
  LOGICAL(ans)[0] = 1;

  /* object is an external pointer */
  if (TYPEOF(ptr) != EXTPTRSXP)
    LOGICAL(ans)[0] = 0;

  /* tag should be 'external matrix' */
  if (LOGICAL(ans)[0] &&
      R_ExternalPtrTag(ptr) != install("external matrix"))
    LOGICAL(ans)[0] = 0;

  /* pointer itself should not be null */
  if (LOGICAL(ans)[0]) {
    e = R_ExternalPtrAddr(ptr);
    if (!e)
      LOGICAL(ans)[0] = 0;
  }

  /* finally, type should be nonnull */
  if (LOGICAL(ans)[0] && e && e->type == NULL)
    LOGICAL(ans)[0] = 0;

  UNPROTECT(1);

  return ans;
}