#include <R.h>

#include <Rversion.h>

#include <Rdefines.h>

#include "rJava.h"

#include <stdlib.h>

#include <string.h>

/* determine whether eenv chache should be used (has no effect if JNI_CACHE is not set) */

int use_eenv = 1;

/* cached environment. Do NOT use directly! Always use getJNIEnv()! */

JNIEnv *eenv;

/* -- hack to get at the current call from C code using contexts */

#if ( R_VERSION >= R_Version(1, 7, 0) )

#include <setjmp.h>

/* stuff we need to pull for Windows... */

#ifdef WIN32

/* this is from gnuwin32/fixed/h/psignal.h */

#ifndef _SIGSET_T_

#define _SIGSET_T_

typedef int sigset_t;

#endif /* Not _SIGSET_T_ */

typedef struct

{

jmp_buf jmpbuf; /* Calling environment. */

int mask_was_saved; /* Saved the signal mask? */

sigset_t saved_mask; /* Saved signal mask. */

} sigjmp_buf[1];

/* we need to set HAVE_POSIX_SETJMP since we don't have config.h on Win */

#ifndef HAVE_POSIX_SETJMP

#define HAVE_POSIX_SETJMP

#endif

#endif

#ifdef HAVE_POSIX_SETJMP

#define JMP_BUF sigjmp_buf

#else

#define JMP_BUF jmp_buf

#endif

#ifndef CTXT_BUILTIN

#define CTXT_BUILTIN 64

#endif

typedef struct RCNTXT { /* this RCNTXT structure is only partial since we need to get at "call" - it is safe form R 1.7.0 on */

struct RCNTXT *nextcontext; /* The next context up the chain <<-- we use this one to skip the .Call/.External call frame */

int callflag; /* The context "type" <<<-- we use this one to skip the .Call/.External call frame */

JMP_BUF cjmpbuf; /* C stack and register information */

int cstacktop; /* Top of the pointer protection stack */

int evaldepth; /* evaluation depth at inception */

SEXP promargs; /* Promises supplied to closure */

SEXP callfun; /* The closure called */

SEXP sysparent; /* environment the closure was called from */

SEXP call; /* The call that effected this context <<<--- we pass this one to the condition */

SEXP cloenv; /* The environment */

} RCNTXT;

#ifndef LibExtern

#define LibExtern extern

#endif

LibExtern RCNTXT* R_GlobalContext;

static SEXP getCurrentCall() {

RCNTXT *ctx = R_GlobalContext;

/* skip the .External/.Call context to get at the underlying call */

if (ctx->nextcontext && (ctx->callflag & CTXT_BUILTIN))

ctx = ctx->nextcontext;

/* skip .jcheck */

if (TYPEOF(ctx->call) == LANGSXP && CAR(ctx->call) == install(".jcheck") && ctx->nextcontext)

ctx = ctx->nextcontext;

return ctx->call;

}

#else

static SEXP getCurrentCall() {

return R_NilValue;

}

#endif

/* -- end of hack */

/** throw an exception using R condition code.

* @param msg - message string

* @param jobj - jobjRef object of the exception

* @param clazzes - simple name of all the classes in the inheritance tree of the exception plus "error" and "condition"

*/

HIDE void throwR(SEXP msg, SEXP jobj, SEXP clazzes) {

SEXP cond = PROTECT(allocVector(VECSXP, 3));

SEXP names = PROTECT(allocVector(STRSXP, 3));

SET_VECTOR_ELT(cond, 0, msg);

SET_VECTOR_ELT(cond, 1, getCurrentCall());

SET_VECTOR_ELT(cond, 2, jobj);

SET_STRING_ELT(names, 0, mkChar("message"));

SET_STRING_ELT(names, 1, mkChar("call"));

SET_STRING_ELT(names, 2, mkChar("jobj"));

setAttrib(cond, R_NamesSymbol, names);

setAttrib(cond, R_ClassSymbol, clazzes);

UNPROTECT(2); /* clazzes, names */

eval(LCONS(install("stop"), CONS(cond, R_NilValue)), R_GlobalEnv);

UNPROTECT(1); /* cond */

}

/* check for exceptions and throw them to R level */

HIDE void ckx(JNIEnv *env) {

SEXP xr, xobj, msg = 0, xclass = 0; /* note: we don't bother counting protections becasue we never return */

jthrowable x = 0;

if (env && !(x = (*env)->ExceptionOccurred(env))) return;

if (!env) {

env = getJNIEnv();

if (!env)

error("Unable to retrieve JVM environment.");

ckx(env);

return;

}

/* env is valid and an exception occurred */

/* we create the jobj first, because the exception may in theory disappear after being cleared,

yet this can be (also in theory) risky as it uses further JNI calls ... */

xobj = j2SEXP(env, x, 0);

(*env)->ExceptionClear(env);

/* grab the list of class names (without package path) */

SEXP clazzes = PROTECT( getSimpleClassNames_asSEXP( (jobject)x, (jboolean)1 ) ) ;

/* ok, now this is a critical part that we do manually to avoid recursion */

{

jclass cls = (*env)->GetObjectClass(env, x);

if (cls) {

jstring cname;

jmethodID mid = (*env)->GetMethodID(env, cls, "toString", "()Ljava/lang/String;");

if (mid) {

jstring s = (jstring)(*env)->CallObjectMethod(env, x, mid);

if (s) {

const char *c = (*env)->GetStringUTFChars(env, s, 0);

if (c) {

msg = PROTECT(mkString(c));

(*env)->ReleaseStringUTFChars(env, s, c);

}

}

}

/* beside toString() we also need to call getName() on cls to get the subclass */

cname = (jstring) (*env)->CallObjectMethod(env, cls, mid_getName);

if (cname) {

const char *c = (*env)->GetStringUTFChars(env, cname, 0);

if (c) {

/* convert full class name to JNI notation */

char *cn = strdup(c), *d = cn;

while (*d) { if (*d == '.') *d = '/'; d++; }

xclass = mkString(cn);

free(cn);

(*env)->ReleaseStringUTFChars(env, cname, c);

}

(*env)->DeleteLocalRef(env, cname);

}

if ((*env)->ExceptionOccurred(env))

(*env)->ExceptionClear(env);

(*env)->DeleteLocalRef(env, cls);

} else (*env)->ExceptionClear(env);

if (!msg)

msg = PROTECT(mkString("Java Exception <no description because toString() failed>"));

}

/* delete the local reference to the exception (jobjRef has a global copy) */

(*env)->DeleteLocalRef(env, x);

/* construct the jobjRef */

xr = PROTECT(NEW_OBJECT(MAKE_CLASS("jobjRef")));

if (inherits(xr, "jobjRef")) {

SET_SLOT(xr, install("jclass"), xclass ? xclass : mkString("java/lang/Throwable"));

SET_SLOT(xr, install("jobj"), xobj);

}

/* and off to R .. (we're keeping xr and clazzes protected) */

throwR(msg, xr, clazzes);

/* throwR never returns so don't even bother ... */

}

/* clear any pending exceptions */

HIDE void clx(JNIEnv *env) {

if (env && (*env)->ExceptionOccurred(env))

(*env)->ExceptionClear(env);

}

#ifdef JNI_CACHE

HIDE JNIEnv *getJNIEnvSafe();

HIDE JNIEnv *getJNIEnv() {

return (use_eenv)?eenv:getJNIEnvSafe();

}

HIDE JNIEnv *getJNIEnvSafe()

#else

HIDE JNIEnv *getJNIEnv()

#endif

{

JNIEnv *env;

jsize l;

jint res;

if (!jvm) { /* we're hoping that the JVM pointer won't change :P we fetch it just once */

res = JNI_GetCreatedJavaVMs(&jvm, 1, &l);

if (res != 0) {

error("JNI_GetCreatedJavaVMs failed! (result:%d)",(int)res); return 0;

}

if (l < 1)

error("No running JVM detected. Maybe .jinit() would help.");

if (!rJava_initialized)

error("rJava was called from a running JVM without .jinit().");

}

res = (*jvm)->AttachCurrentThread(jvm, (void**) &env, 0);

if (res!=0) {

error("AttachCurrentThread failed! (result:%d)", (int)res); return 0;

}

if (env && !eenv) eenv=env;

/* if (eenv!=env)

fprintf(stderr, "Warning! eenv=%x, but env=%x - different environments encountered!\n", eenv, env); */

return env;

}

REP void RuseJNICache(int *flag) {

if (flag) use_eenv=*flag;

}