rJava/jri/src/Rengine.c at pre-R-3-6-0 · s-u/rJava

660 lines (561 loc) · 17.8 KB
/* Rengine - implements native rni methods called from the Rengine class */
#include <stdio.h>
#include "jri.h"
#include "org_rosuda_JRI_Rengine.h"
#include "rjava.h"
#include <Rversion.h>
#include <R_ext/Parse.h>
#ifndef WIN32 /* this is for interrupt handing since GD uses R_interrupts_pending */
#include <R_ext/GraphicsEngine.h>
/* Before R 2.7.0 R_interrupts_pending was not included, though */
#if R_VERSION < R_Version(2,7,0)
LibExtern int R_interrupts_pending;
/* the # of arguments to R_ParseVector changed since R 2.5.0 */
#if R_VERSION < R_Version(2,5,0)
#define RS_ParseVector R_ParseVector
#define RS_ParseVector(A,B,C) R_ParseVector(A,B,C,R_NilValue)
#include "Rcallbacks.h"
#include "Rinit.h"
#include "globals.h"
#include "Rdecl.h"
#ifdef Win32
#include <windows.h>
#ifdef _MSC_VER
__declspec(dllimport) int UserBreak;
#ifndef WIN64
#define UserBreak     (*_imp__UserBreak)
extern int UserBreak;
/* for R_runHandlers */
#include <R_ext/eventloop.h>
#include <signal.h>
#include <unistd.h>
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniGetVersion
(JNIEnv *env, jclass this)
    return (jlong) JRI_API;
JNIEXPORT jint JNICALL Java_org_rosuda_JRI_Rengine_rniSetupR
  (JNIEnv *env, jobject this, jobjectArray a)
      int initRes;
      char *fallbackArgv[]={"Rengine",0};
      char **argv=fallbackArgv;
      int argc=1;
#ifdef JRI_DEBUG
      printf("rniSetupR\n");
      engineObj=(*env)->NewGlobalRef(env, this);
      engineClass=(*env)->NewGlobalRef(env, (*env)->GetObjectClass(env, engineObj));
      eenv=env;
      if (a) { /* retrieve the content of the String[] and construct argv accordingly */
          int len = (int)(*env)->GetArrayLength(env, a);
          if (len>0) {              
              int i=0;
              argv=(char**) malloc(sizeof(char*)*(len+2));
              argv[0]=fallbackArgv[0];
              while (i < len) {
                  jobject o=(*env)->GetObjectArrayElement(env, a, i);
                  if (o) {
                      const char *c;
                      c=(*env)->GetStringUTFChars(env, o, 0);
                      if (!c)
                          argv[i]="";
			  argv[i] = strdup(c);
                          (*env)->ReleaseStringUTFChars(env, o, c);
                  } else
                      argv[i]="";
              argc=len+1;
              argv[argc]=0;
      if (argc==2 && !strcmp(argv[1],"--zero-init")) {/* special case for direct embedding (exp!) */
	initRinside();
      initRes=initR(argc, argv);
      /* we don't release the argv in case R still needs it later (even if it shouldn't), but it's not really a significant leak */
      return initRes;
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniParse
  (JNIEnv *env, jobject this, jstring str, jint parts)
      ParseStatus ps;
      SEXP pstr, cv;
      PROTECT(cv=jri_getString(env, str));
#ifdef JRI_DEBUG
      printf("parsing \"%s\"\n", CHAR(STRING_ELT(cv,0)));
      pstr=RS_ParseVector(cv, parts, &ps);
#ifdef JRI_DEBUG
      printf("parse status=%d, result=%x, type=%d\n", ps, (int) pstr, (pstr!=0)?TYPEOF(pstr):0);
      UNPROTECT(1);
      return SEXP2L(pstr);
 * Evaluates one expression or a list of expressions
 * @param exp long reflection of the expression to evaluate
 * @param rho long reflection of the environment where to evaluate
 * @return 0 if an evaluation error ocurred or exp is 0
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniEval
  (JNIEnv *env, jobject this, jlong exp, jlong rho)
      SEXP es = R_NilValue, exps = L2SEXP(exp);
      SEXP eval_env = L2SEXP(rho);
      int er = 0;
      int i = 0, l;
      /* invalid (NULL) expression (parse error, ... ) */
      if (!exp) return 0;
      if (TYPEOF(exps) == EXPRSXP) { 
      	  /* if the object is a list of exps, eval them one by one */
          l = LENGTH(exps);
          while (i < l) {
              es = R_tryEval(VECTOR_ELT(exps,i), eval_env, &er);
              /* an error occured, no need to continue */
              if (er) return 0;
              i++;
      } else
          es = R_tryEval(exps, eval_env, &er);
      /* er is just a flag - on error return 0 */
      if (er) return 0;
      return SEXP2L(es);
struct safeAssign_s {
    SEXP sym, val, rho;
static void safeAssign(void *data) {
    struct safeAssign_s *s = (struct safeAssign_s*) data;
    defineVar(s->sym, s->val, s->rho);
JNIEXPORT jboolean JNICALL Java_org_rosuda_JRI_Rengine_rniAssign
(JNIEnv *env, jobject this, jstring symName, jlong valL, jlong rhoL)
    struct safeAssign_s s;
    s.sym = jri_installString(env, symName);
    if (!s.sym || s.sym == R_NilValue) return JNI_FALSE;
    s.rho = rhoL ? L2SEXP(rhoL) : R_GlobalEnv;
    s.val = valL ? L2SEXP(valL) : R_NilValue;
    /* we have to use R_ToplevelExec because defineVar may fail on locked bindings */
    return R_ToplevelExec(safeAssign, (void*) &s) ? JNI_TRUE : JNI_FALSE;
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniProtect
(JNIEnv *env, jobject this, jlong exp)
	PROTECT(L2SEXP(exp));
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniUnprotect
(JNIEnv *env, jobject this, jint count)
	UNPROTECT(count);
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniRelease
(JNIEnv *env, jobject this, jlong exp)
	if (exp) R_ReleaseObject(L2SEXP(exp));
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniPreserve
(JNIEnv *env, jobject this, jlong exp)
	if (exp) R_PreserveObject(L2SEXP(exp));
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniPrintValue
(JNIEnv *env, jobject this, jlong exp)
	Rf_PrintValue(exp ? L2SEXP(exp) : R_NilValue);
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniParentEnv
(JNIEnv *env, jobject this, jlong exp)
  return SEXP2L(ENCLOS(exp ? L2SEXP(exp) : R_GlobalEnv));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniFindVar
(JNIEnv *env, jobject this, jstring symName, jlong rho)
	SEXP sym = jri_installString(env, symName);
	if (!sym || sym == R_NilValue) return 0;
	return SEXP2L(Rf_findVar(sym, rho ? L2SEXP(rho) : R_GlobalEnv));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniListEnv
(JNIEnv *env, jobject this, jlong rho, jboolean all)
	return SEXP2L(R_lsInternal(rho ? L2SEXP(rho) : R_GlobalEnv, all));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniSpecialObject
(JNIEnv *env, jobject this, jint which)
  switch (which) {
  case 0: return SEXP2L(R_NilValue);
  case 1: return SEXP2L(R_GlobalEnv);
  case 2: return SEXP2L(R_EmptyEnv);
  case 3: return SEXP2L(R_BaseEnv);
  case 4: return SEXP2L(R_UnboundValue);
  case 5: return SEXP2L(R_MissingArg);
  case 6: return SEXP2L(R_NaString);
  case 7: return SEXP2L(R_BlankString);
  return 0;
JNIEXPORT jobject JNICALL Java_org_rosuda_JRI_Rengine_rniXrefToJava
(JNIEnv *env, jobject this, jlong exp)
	SEXP xp = L2SEXP(exp);
	if (TYPEOF(xp) != EXTPTRSXP) return 0;
	return (jobject) EXTPTR_PTR(xp);
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniJavaToXref
(JNIEnv *env, jobject this, jobject o)
  /* this is pretty much from Rglue.c of rJava */
  jobject go = (*env)->NewGlobalRef(env, o);
  return SEXP2L(R_MakeExternalPtr(go, R_NilValue, R_NilValue));
JNIEXPORT jstring JNICALL Java_org_rosuda_JRI_Rengine_rniGetString
  (JNIEnv *env, jobject this, jlong exp)
      return jri_putString(env, L2SEXP(exp), 0);
JNIEXPORT jobjectArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetStringArray
  (JNIEnv *env, jobject this, jlong exp)
      return jri_putStringArray(env, L2SEXP(exp));
JNIEXPORT jintArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetIntArray
  (JNIEnv *env, jobject this, jlong exp)
      return jri_putIntArray(env, L2SEXP(exp));
JNIEXPORT jbyteArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetRawArray
  (JNIEnv *env, jobject this, jlong exp)
      return jri_putByteArray(env, L2SEXP(exp));
JNIEXPORT jintArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetBoolArrayI
  (JNIEnv *env, jobject this, jlong exp)
      return jri_putBoolArrayI(env, L2SEXP(exp));
JNIEXPORT jintArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetDoubleArray
  (JNIEnv *env, jobject this, jlong exp)
      return jri_putDoubleArray(env, L2SEXP(exp));
JNIEXPORT jlongArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetVector
(JNIEnv *env, jobject this, jlong exp)
    return jri_putSEXPLArray(env, L2SEXP(exp));
JNIEXPORT jint JNICALL Java_org_rosuda_JRI_Rengine_rniExpType
  (JNIEnv *env, jobject this, jlong exp)
    return exp ? TYPEOF(L2SEXP(exp)) : 0;
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniIdle
  (JNIEnv *env, jobject this)
#ifdef Win32
	if(!UserBreak)R_ProcessEvents();
    R_runHandlers(R_InputHandlers, R_checkActivity(0, 1));
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniRunMainLoop
  (JNIEnv *env, jobject this)
      run_Rmainloop();
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutString
(JNIEnv *env, jobject this, jstring s)
    return SEXP2L(jri_getString(env, s));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutStringArray
(JNIEnv *env, jobject this, jobjectArray a)
    return SEXP2L(jri_getStringArray(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutIntArray
(JNIEnv *env, jobject this, jintArray a)
    return SEXP2L(jri_getIntArray(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutRawArray
(JNIEnv *env, jobject this, jbyteArray a)
    return SEXP2L(jri_getByteArray(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutBoolArrayI
(JNIEnv *env, jobject this, jintArray a)
    return SEXP2L(jri_getBoolArrayI(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutBoolArray
(JNIEnv *env, jobject this, jbooleanArray a)
    return SEXP2L(jri_getBoolArray(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutDoubleArray
(JNIEnv *env, jobject this, jdoubleArray a)
    return SEXP2L(jri_getDoubleArray(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutVector
(JNIEnv *env, jobject this, jlongArray a)
    return SEXP2L(jri_getSEXPLArray(env, a));
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniGetAttr
(JNIEnv *env, jobject this, jlong exp, jstring name)
    SEXP an = jri_installString(env, name);
    if (!an || an==R_NilValue || exp==0 || L2SEXP(exp)==R_NilValue) return 0;
        SEXP a = getAttrib(L2SEXP(exp), an);
        return (a==R_NilValue)?0:SEXP2L(a);
JNIEXPORT jobjectArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetAttrNames
(JNIEnv *env, jobject this, jlong exp)
    SEXP o = L2SEXP(exp);
    SEXP att = ATTRIB(o), ah = att;
    unsigned int ac = 0;
    jobjectArray sa;
    if (att == R_NilValue) return 0;
    /* count the number of attributes */
    while (ah != R_NilValue) {
	ah = CDR(ah);
    /* allocate Java array */
    sa = (*env)->NewObjectArray(env, ac, (*env)->FindClass(env, "java/lang/String"), 0);
    if (!sa) return 0;
    ac = 0;
    ah = att;
    /* iterate again and set create the strings */
    while (ah != R_NilValue) {
	SEXP t = TAG(ah);
	if (t != R_NilValue) {
	    jobject s = (*env)->NewStringUTF(env, CHAR_UTF8(PRINTNAME(t)));
	    (*env)->SetObjectArrayElement(env, sa, ac, s);
	ah = CDR(ah);
    return sa;
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniSetAttr
(JNIEnv *env, jobject this, jlong exp, jstring aName, jlong attr)
    SEXP an = jri_installString(env, aName);
    if (!an || an==R_NilValue || exp==0 || L2SEXP(exp)==R_NilValue) return;
    setAttrib(L2SEXP(exp), an, (attr==0)?R_NilValue:L2SEXP(attr));
	/* BTW: we don't need to adjust the object bit for "class", setAttrib does that already */
    /* this is not official API, but whoever uses this should know what he's doing
       it's ok for directly constructing attr lists, and that's what it should be used for
       SET_ATTRIB(L2SEXP(exp), (attr==0)?R_NilValue:L2SEXP(attr)); */
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniInstallSymbol
(JNIEnv *env, jobject this, jstring s)
    return SEXP2L(jri_installString(env, s));
JNIEXPORT jstring JNICALL Java_org_rosuda_JRI_Rengine_rniGetSymbolName
(JNIEnv *env, jobject this, jlong exp)
	return jri_putSymbolName(env, L2SEXP(exp));
JNIEXPORT jboolean JNICALL Java_org_rosuda_JRI_Rengine_rniInherits
(JNIEnv *env, jobject this, jlong exp, jstring s)
	jboolean res = 0;
	const char *c;
	c=(*env)->GetStringUTFChars(env, s, 0);
		if (inherits(L2SEXP(exp), (char*)c)) res = 1;
		(*env)->ReleaseStringUTFChars(env, s, c);
	return res;
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniCons
(JNIEnv *env, jobject this, jlong head, jlong tail, jlong tag, jboolean lang)
  if (lang)
    l = LCONS((head==0)?R_NilValue:L2SEXP(head), (tail==0)?R_NilValue:L2SEXP(tail));
    l = CONS((head==0)?R_NilValue:L2SEXP(head), (tail==0)?R_NilValue:L2SEXP(tail));
  if (tag) SET_TAG(l, L2SEXP(tag));
  return SEXP2L(l);
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniCAR
(JNIEnv *env, jobject this, jlong exp)
    if (exp) {
        SEXP r = CAR(L2SEXP(exp));
        return (r==R_NilValue)?0:SEXP2L(r);
    return 0;
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniCDR
(JNIEnv *env, jobject this, jlong exp)
    if (exp) {
        SEXP r = CDR(L2SEXP(exp));
        return (r==R_NilValue)?0:SEXP2L(r);
    return 0;
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniTAG
(JNIEnv *env, jobject this, jlong exp)
    if (exp) {
        SEXP r = TAG(L2SEXP(exp));
        return (r==R_NilValue)?0:SEXP2L(r);
    return 0;
/* creates a list from SEXPs provided in long[] */
JNIEXPORT jlong JNICALL Java_org_rosuda_JRI_Rengine_rniPutList
(JNIEnv *env, jobject this, jlongArray o)
    SEXP t=R_NilValue;
    int l,i=0;
    jlong *ap;
    if (!o) return 0;
    l=(int)(*env)->GetArrayLength(env, o);
    if (l<1) return SEXP2L(CONS(R_NilValue, R_NilValue));
    ap=(jlong*)(*env)->GetLongArrayElements(env, o, 0);
    if (!ap) return 0;
    while(i<l) {
        t=CONS((ap[i]==0)?R_NilValue:L2SEXP(ap[i]), t);
        i++;
    (*env)->ReleaseLongArrayElements(env, o, ap, 0);    
    return SEXP2L(t);
/* retrieves a list (shallow copy) and returns the SEXPs in long[] */
JNIEXPORT jlongArray JNICALL Java_org_rosuda_JRI_Rengine_rniGetList
(JNIEnv *env, jobject this, jlong exp)
    SEXP e=L2SEXP(exp);
    if (exp==0 || e==R_NilValue) return 0;
        unsigned len=0;
        SEXP t=e;
        while (t!=R_NilValue) { t=CDR(t); len++; };
            jlongArray da=(*env)->NewLongArray(env,len);
            jlong *dae;
            if (!da) return 0;
            if (len>0) {
                int i=0;
                dae=(*env)->GetLongArrayElements(env, da, 0);
                if (!dae) {
                    (*env)->DeleteLocalRef(env,da);
                    jri_error("rniGetList: newLongArray.GetLongArrayElements failed");
                    return 0;
                while (t!=R_NilValue && i<len) {
                    dae[i]=(CAR(t)==R_NilValue)?0:SEXP2L(CAR(t));
                    i++; t=CDR(t);
                (*env)->ReleaseLongArrayElements(env, da, dae, 0);
            return da;
/* by default those are disabled as it's a problem on Win32 ... */
#ifdef JRI_ENV_CALLS
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniSetEnv
(JNIEnv *env, jclass this, jstring key, jstring val) {
    const char *cKey, *cVal;
    if (!key || !val) return;
    cKey=(*env)->GetStringUTFChars(env, key, 0);
    cVal=(*env)->GetStringUTFChars(env, val, 0);
    if (!cKey || !cVal) {
        jri_error("rniSetEnv: can't retrieve key/value content");
        return;
#ifdef Win32
    SetEnvironmentVariable(cKey, cVal);
    setenv(cKey, cVal, 1);
    (*env)->ReleaseStringUTFChars(env, key, cKey);
    (*env)->ReleaseStringUTFChars(env, val, cVal);
JNIEXPORT jstring JNICALL Java_org_rosuda_JRI_Rengine_rniGetEnv
(JNIEnv *env, jclass this, jstring key) {
    const char *cKey, *cVal;
    if (!key) return;
    cKey=(*env)->GetStringUTFChars(env, key, 0);
    if (!cKey) {
        jri_error("rniSetEnv: can't retrieve key/value content");
        return;
    cVal=getenv(cKey);
    (*env)->ReleaseStringUTFChars(env, key, cKey);
    if (!cVal) return 0;
    return (*env)->NewStringUTF(env, cVal);
JNIEXPORT jint JNICALL Java_org_rosuda_JRI_Rengine_rniSetupRJava
(JNIEnv *env, jobject this, jint _in, jint _out) {
  RJava_setup(_in, _out);
  return 0;
JNIEXPORT jint JNICALL Java_org_rosuda_JRI_Rengine_rniRJavaLock
(JNIEnv *env, jobject this) {
  return RJava_request_lock();
JNIEXPORT jint JNICALL Java_org_rosuda_JRI_Rengine_rniRJavaUnlock
(JNIEnv *env, jobject this) {
  return RJava_clear_lock();
JNIEXPORT void JNICALL Java_org_rosuda_JRI_Rengine_rniPrint
(JNIEnv *env, jobject this, jstring s, jint oType) {
    const char *c = (*env)->GetStringUTFChars(env, s, 0);
    if (c) {
      if (oType)
	REprintf("%s", c);
	Rprintf("%s", c);
    (*env)->ReleaseStringUTFChars(env, s, c);
JNIEXPORT jint JNICALL Java_org_rosuda_JRI_Rengine_rniStop
(JNIEnv *env, jobject this, jint flag) {
#ifdef Win32
    UserBreak=1;
    /* there are three choices now:
       0 = cooperative (requires external interrupt of ReadConsole!)
       1 = SIGINT for compatibility with old rniStop()
       2 = R's onintr but that one works *only* if used on the R thread (which renders is essentially useless unless used in some synchronous interrupt handler). */
    if (flag == 0) R_interrupts_pending = 1;
    else if (flag == 1)  kill(getpid(), SIGINT);
    else Rf_onintr();
    return 0;
Provide feedback

Saved searches

Use saved searches to filter your results more quickly

FilesExpand file tree

Rengine.c

Latest commit

History

Rengine.c

File metadata and controls
