rJava rewrite - initial commit

com.oracle.truffle.r.pkgs/rJava/DESCRIPTION

 Package: rJava
-Type: Package
-Title: FastR rJava compatibility layer
-Version: 1.0
-Date: 2017-05-18
-Author: Tomas Stupka
-Maintainer: Tomas Stupka <tomas.stupka@oracle.com>
-Description: Provides rJava R interface backed by FastR interoperability builtins.
+Version: (populated by mkdist!)
+Title: Low-Level R to Java Interface
+Author: Simon Urbanek <simon.urbanek@r-project.org>
+Maintainer: Simon Urbanek <simon.urbanek@r-project.org>
+Depends: R (>= 2.5.0), methods
+Description: Low-level interface to Java VM very much like .C/.Call and friends. Allows creation of objects, calling methods and accessing fields.
 License: GPL-2
-Suggests: testthat
-RoxygenNote: 6.0.1
+URL: http://www.rforge.net/rJava/
+SystemRequirements: Java JDK 1.2 or higher (for JRI/REngine JDK 1.4 or higher), GNU make
+BugReports: https://github.com/s-u/rJava/issues

com.oracle.truffle.r.pkgs/rJava/NAMESPACE

-# Generated by roxygen2: do not edit by hand
-
-export(.jaddClassPath)
-export(.jaddLibrary)
-export(.jarray)
-export(.jbyte)
-export(.jcall)
-export(.jcast)
-export(.jchar)
-export(.jcheck)
-export(.jclear)
-export(.jevalArray)
-export(.jfield)
-export(.jfindClass)
-export(.jfloat)
-export(.jgetEx)
-export(.jinit)
-export(.jlong)
-export(.jnew)
-export(.jnull)
-export(.jpackage)
-export(.jshort)
-export(.jsimplify)
-export(.jstrVal)
-export(.jthrow)
-export(J)
-export(is.jnull)
+exportPattern("^\\.j")
+export( "J" )
+export( "%instanceof%" )
+
+export( clone )
+S3method( clone, default ) 
+export(is.jnull, .r2j, .rJava.base.path, toJava)
+exportClasses(jobjRef, jarrayRef, jrectRef, jfloat, jlong, jbyte, jchar, jclassName)
+exportMethods(show, "$", "$<-", 
+	"==", "!=", "<", ">", "<=", ">=", 
+	names, new, as.character, length, head, tail, 
+	"[", "[[", "[[<-", str, "dim<-", 
+	unique, duplicated, anyDuplicated, 
+	sort, rev, 
+	min, max, range, 
+	rep, 
+	clone )
+import(methods)
+importFrom(utils,head)
+importFrom(utils,tail)
+importFrom(utils,str)
+importFrom(utils, assignInNamespace)
+
+S3method(with, jobjRef)
+S3method(with, jarrayRef)
+S3method(with, jclassName)
+
+S3method(within, jobjRef)
+S3method(within, jarrayRef)
+S3method(within, jclassName)
+
+# within requires that with.jobjRef is visible outside
+export(with.jobjRef)
+
+if( exists( ".DollarNames", asNamespace("utils") ) ) importFrom( utils, .DollarNames )
+S3method(.DollarNames, jobjRef)
+S3method(.DollarNames, jarrayRef)
+S3method(.DollarNames, jrectRef)
+S3method(.DollarNames, jclassName)
+
+S3method( as.list, jobjRef )
+S3method( as.list, jarrayRef )
+S3method( as.list, jrectRef )
+
+S3method( "$", "Throwable" )
+S3method( "$<-", "Throwable" )
+
+export( javaImport )
+

com.oracle.truffle.r.pkgs/rJava/R/0classes.R

+## S4 classes (jobjRef is re-defined in .First.lib to contain valid jobj)                                                                                                  
+#' java object reference
+setClass("jobjRef", representation(jobj="externalptr", jclass="character"), 
+	prototype=list(jobj=NULL, jclass="java/lang/Object"))
+
+#' rugged arrays
+setClass("jarrayRef", representation("jobjRef", jsig="character"))
+
+#' rectangular java arrays double[][] d = new double[m][n]
+setClass("jrectRef", 
+	representation("jarrayRef", dimension="integer" ) ) 
+
+
+
+# we extend array here so that we can keep dimensions
+# in the helper functions below, the storage mode is 
+# set when the objects are built
+# TODO: maybe an initialize method is needed here
+# TODO: maybe a validate method is needed here as well
+setClass("jfloat", representation("array" ) )
+setClass("jlong", representation("array" )  )
+setClass("jbyte", representation("array" )  )
+setClass("jshort", representation("array" ) )
+setClass("jchar", representation("array" )  )
+
+# there is no way to distinguish between double and float in R, so we need to mark floats specifically
+.jfloat <- function(x) {
+	storage.mode( x ) <- "double"
+	new("jfloat", x )
+}
+# the same applies to long
+.jlong <- function(x) {
+	storage.mode( x ) <- "double"
+	new("jlong", x)
+}
+# and byte
+.jbyte <- function(x) {
+	storage.mode( x ) <- "integer"
+	new("jbyte", x)
+}
+# and short
+.jshort <- function(x){
+	storage.mode( x ) <- "integer"
+	new("jshort", x)
+}
+# and char (experimental)
+.jchar <- function(x){
+	storage.mode( x ) <- "integer"
+	new("jchar", as.integer(x))
+}
+

com.oracle.truffle.r.pkgs/rJava/R/J.R

+setClass("jclassName", representation(name="character", jobj="jobjRef"))
+jclassName <- function(class){
+	if( is( class, "jobjRef" ) && .jinherits(class, "java/lang/Class" ) ){
+		jobj <- class
+		name <- .jcall( class, "Ljava/lang/String;", "getName", evalString = TRUE )
+	} else{
+		name <- gsub("/",".",as.character(class))
+		jobj <- .jfindClass(as.character(class))
+	}
+	new("jclassName", name=name, jobj=jobj)
+}
+
+setGeneric("new")
+setMethod("new", signature(Class="jclassName"), function(Class, ...) .J(Class@name, ...))
+
+setMethod("$", c(x="jclassName"), function(x, name) {
+	if( name == "class" ){
+		x@jobj
+	} else if (classHasField(x@jobj, name, TRUE)){
+		.jfield(x@name, , name) 
+	} else if (classHasMethod(x@jobj, name, TRUE)){
+		function(...) .jrcall(x@name, name, ...) 
+	} else if( classHasClass(x@jobj, name, FALSE) ){
+		inner.cl <- .jcall( "RJavaTools", "Ljava/lang/Class;", "getClass", x@jobj, name, FALSE ) 
+		new("jclassName", name=.jcall(inner.cl, "S", "getName"), jobj=inner.cl)
+	} else {
+		stop("no static field, method or inner class called `", name, "' in `", x@name, "'")
+	}
+})
+setMethod("$<-", c(x="jclassName"), function(x, name, value) .jfield(x@name, name) <- value)
+setMethod("show", c(object="jclassName"), function(object) invisible(show(paste("Java-Class-Name:",object@name))))
+setMethod("as.character", c(x="jclassName"), function(x, ...) x@name)
+
+## the magic `J'
+J<-function(class, method, ...) if (nargs() == 1L && missing(method)) jclassName(class) else .jrcall(class, method, ...)

com.oracle.truffle.r.pkgs/rJava/R/call.R

+## This file is part of the rJava package - low-level R/Java interface
+## (C)2006 Simon Urbanek <simon.urbanek@r-project.org>
+## For license terms see DESCRIPTION and/or LICENSE
+##
+## $Id$
+
+# create a new object
+.jnew <- function(class, ..., check=TRUE, silent=!check, class.loader=NULL) {
+  class <- gsub("\\.", "/", as.character(class)) # allow non-JNI specifiation
+  # TODO: should this do "S" > "java/lang/String", ... like .jcall
+  
+  if (check) .jcheck(silent=TRUE)
+  o<-.External(RcreateObject, class, ..., silent=silent, class.loader=class.loader)
+  if (check) .jcheck(silent=silent)
+  if (is.null(o)) {
+  	  if (!silent) {
+    	  stop("Failed to create object of class `",class,"'")
+      } else {
+    	  o <- .jzeroRef
+      }
+  }
+  new("jobjRef", jobj=o, jclass=class)
+}
+
+# create a new object reference manually (avoid! for backward compat only!) 
+# the problem with this is that you need a valid `jobj' which 
+# is implementation-dependent so it is undefined outside rJava internals
+# it is now used by JRI.createRJavaRef, though
+.jmkref <- function(jobj, jclass="java/lang/Object") {
+  new("jobjRef", jobj=jobj, jclass=gsub('\\.','/',as.character(jclass)))
+}
+
+# evaluates an array reference. If rawJNIRefSignature is set, then obj is not assumed to be
+# jarrayRef, but rather direct JNI reference with the corresponding signature
+.jevalArray <- function(obj, rawJNIRefSignature=NULL, silent=FALSE, simplify=FALSE) {
+  jobj<-obj
+  sig<-rawJNIRefSignature
+  if (is.null(rawJNIRefSignature)) {
+    if(!inherits(obj,"jarrayRef")) {
+      if (!inherits(obj,"jobjRef"))
+        stop("object is not a Java object reference (jobjRef/jarrayRef).")
+      cl <- gsub("\\.","/",.jclass(obj))
+      if (is.null(cl) || !isJavaArraySignature(cl) )
+        stop("object is not a Java array.")
+      sig <- cl
+    } else sig <- obj@jsig
+    jobj<-obj@jobj
+  } else if (is(obj, "jobjRef")) jobj<-obj@jobj
+  if (sig=="[I")
+    return(.Call(RgetIntArrayCont, jobj))
+  else if (sig=="[J")
+    return(.Call(RgetLongArrayCont, jobj))
+  else if (sig=="[Z")
+    return(.Call(RgetBoolArrayCont, jobj))
+  else if (sig=="[B")
+    return(.Call(RgetByteArrayCont, jobj))
+  else if (sig=="[D")
+    return(.Call(RgetDoubleArrayCont, jobj))
+  else if (sig=="[S")
+    return(.Call(RgetShortArrayCont, jobj))
+  else if (sig=="[C")
+    return(.Call(RgetCharArrayCont, jobj))
+  else if (sig=="[F")
+    return(.Call(RgetFloatArrayCont, jobj))
+  else if (sig=="[Ljava/lang/String;")
+    return(.Call(RgetStringArrayCont, jobj))
+  else if (sig=="[Ljava/lang/Double;" && simplify) {
+    obj@jclass <- sig; return(.jcall("RJavaArrayTools", "[D", "unboxDoubles", obj)) }
+  else if (sig=="[Ljava/lang/Integer;" && simplify) {
+    obj@jclass <- sig; return(.jcall("RJavaArrayTools", "[I", "unboxIntegers", obj)) }
+  else if (sig=="[Ljava/lang/Boolean;" && simplify) {
+    obj@jclass <- sig; return(as.logical(.jcall("RJavaArrayTools", "[I", "unboxBooleans", obj))) }
+  else if (substr(sig,1,2)=="[L")
+    return(lapply(.Call(RgetObjectArrayCont, jobj),
+                  function(x) new("jobjRef", jobj=x, jclass=substr(sig, 3, nchar(sig)-1)) ))
+  else if (substr(sig,1,2)=="[[") {
+    if (simplify) { # try to figure out if this is a rectangular array in which case we can do better
+      o <- newArray(simplify=TRUE, jobj=jobj, signature=sig)
+      # if o is not a reference then we were able to simplify it
+      if (!is(o, "jobjRef")) return(o)
+    }
+    # otherwise simplify has no effect
+    return(lapply(.Call(RgetObjectArrayCont, jobj),
+                  function(x) newArray(jobj=x, signature=substr(sig, 2, 999), simplify=simplify)))
+  }
+  # if we don't know how to evaluate this, issue a warning and return the jarrayRef
+  if (!silent)
+    warning(paste("I don't know how to evaluate an array with signature",sig,". Returning a reference."))
+  newArray(jobj = jobj, signature = sig, simplify = FALSE)
+}
+
+.jcall <- function(obj, returnSig="V", method, ..., evalArray=TRUE, 
+	evalString=TRUE, check=TRUE, interface="RcallMethod", 
+	simplify=FALSE, use.true.class = FALSE) {
+  if (check) .jcheck()
+  iaddr <- .env[[interface]]
+  interface <- if (is.null(iaddr)) getNativeSymbolInfo(interface, "rJava", TRUE, FALSE)$address else iaddr
+  r<-NULL
+  # S is a shortcut for Ljava/lang/String;
+  if (returnSig=="S")
+    returnSig<-"Ljava/lang/String;"
+  if (returnSig=="[S")
+    returnSig<-"[Ljava/lang/String;"
+  # original S (short) is now mapped to T so we need to re-map it (we don't really support short, though)
+  if (returnSig=="T") returnSig <- "S"
+  if (returnSig=="[T") returnSig <- "[S"
+  
+  if (inherits(obj,"jobjRef") || inherits(obj,"jarrayRef") || inherits(obj,"jrectRef") )
+    r<-.External(interface, obj@jobj, returnSig, method, ...)
+  else
+    r<-.External(interface, as.character(obj), returnSig, method, ...)
+  if (returnSig=="V") return(invisible(NULL))
+  
+  if( use.true.class && !is.null( r ) ){
+  	  if( ! ( isPrimitiveTypeName(returnSig) || isArraySignature(returnSig) ) ){
+  	  	  # avoid calling .jcall since we work on external pointers directly here
+  	  	  clazz     <- .External(interface, r    , "Ljava/lang/Class;", "getClass")
+  	  	  clazzname <- .External(interface, clazz, "Ljava/lang/String;", "getName")
+  	  	  clazzname <- .External(RgetStringValue, clazzname)
+  	  	  returnSig <- tojniSignature( clazzname ) 
+  	  }
+  }
+  
+  if (isJavaArraySignature(returnSig)) {
+      # eval or return a reference
+      r <- if (evalArray) .jevalArray(r, rawJNIRefSignature=returnSig, simplify=simplify) else newArray(jobj = r, signature = returnSig, simplify = FALSE)
+  } else if ( substr(returnSig,1,1)=="L") {
+  	  if (is.null(r)){
+  	  	  if( check ) .jcheck( silent = FALSE )
+  	  	  return(r)
+  	  }
+    
+  	if (returnSig=="Ljava/lang/String;" && evalString){
+      if( check ) .jcheck( silent = FALSE )
+  	  return(.External(RgetStringValue, r))
+    }
+    r <- new("jobjRef", jobj=r, jclass=substr(returnSig,2,nchar(returnSig)-1))
+  }
+  if (check) .jcheck()
+  if (.conv.in$.) .convert.in(r) else r
+}
+
+.jstrVal <- function(obj) {
+  # .jstrVal(.jstrVal(...)) = .jstrVal(...)
+  if (is.character(obj))
+    return(obj)
+  r<-NULL
+  if (!is(obj,"jobjRef"))
+    stop("can get value of Java objects only")
+  if (!is.null(obj@jclass) && obj@jclass=="lang/java/String")
+    r<-.External(RgetStringValue, obj@jobj)
+  else
+    r<-.External(RtoString, obj@jobj)
+  r
+}
+
+#' casts java object into new.class
+#' 
+#' @param obj a java object reference
+#' @param new.class the new class (in JNI or Java)
+#' @param check logical. If TRUE the cast if checked
+#' @param convert.array logical. If TRUE and the new class represents an array, then a jarrayRef object is made
+.jcast <- function(obj, new.class="java/lang/Object", check = FALSE, convert.array = FALSE) {
+  if (!is(obj,"jobjRef"))
+    stop("cannot cast anything but Java objects")
+  if( check && !.jinstanceof( obj, new.class) ){
+  	  stop( sprintf( "cannot cast object to '%s'", new.class ) ) 
+  }
+  
+  new.class <- gsub("\\.","/", as.character(new.class)) # allow non-JNI specifiation
+  if( convert.array && !is( obj, "jarrayRef" ) && isJavaArray( obj ) ){
+  	 r <- .jcastToArray( obj, signature = new.class)
+  } else {
+  	 r <- obj
+  	 r@jclass <- new.class
+  }
+  r
+}
+
+# makes sure that a given object is jarrayRef 
+.jcastToArray <- function(obj, signature=NULL, class="", quiet=FALSE) {
+  if (!is(obj, "jobjRef"))
+    return(.jarray(obj))
+  if (is.null(signature)) {
+  	  # TODO: factor out these two calls into a separate function
+    cl <- .jcall(obj, "Ljava/lang/Class;", "getClass")
+    cn <- .jcall(cl, "Ljava/lang/String;", "getName")
+    if ( !isJavaArraySignature(cn) ) {
+      if (quiet)
+        return(obj)
+      else
+        stop("cannot cast to array, object signature is unknown and class name is not an array")
+    }
+    signature <- cn
+  } else{
+  	  if( !isJavaArraySignature(signature) ){
+  	  	  if( quiet ) {
+  	  	  	  return( obj )
+  	  	  } else{
+  	  	  	  stop( "cannot cast to array, signature is not an array signature" )
+  	  	  }
+  	  }
+  }
+  signature <- gsub('\\.', '/', signature)
+  if (inherits(obj, "jarrayRef")) {
+    obj@jsig <- signature
+    return(obj)
+  }
+  newArray(obj, simplify=FALSE)
+}
+
+# creates a new "null" object of the specified class
+# although it sounds weird, the class is important when passed as
+# a parameter (you can even cast the result)
+.jnull <- function(class="java/lang/Object") { 
+  new("jobjRef", jobj=.jzeroRef, jclass=as.character(class))
+}
+
+.jcheck <- function(silent=FALSE) invisible(.Call(RJavaCheckExceptions, silent))
+
+.jproperty <- function(key) {
+  if (length(key)>1)
+    sapply(key, .jproperty)
+  else
+    .jcall("java/lang/System", "S", "getProperty", as.character(key)[1])
+}
+
+#' gets the dim of an array, or its length if it is just a vector
+getDim <- function(x){
+	dim <- dim(x)
+	if( is.null( dim ) ) dim <- length(x)
+	dim
+}
+
+.jarray <- function(x, contents.class = NULL, dispatch = FALSE) {
+	# this already is an array, so don't bother
+	if( isJavaArray( x ) ) return( newArray( x, simplify = FALSE) ) 
+	
+	# this is a two stage process, first we need to convert into 
+	# a flat array using the jni code
+	# TODO: but this needs to move to the internal jni world to avoid 
+	#       too many copies
+	
+	# common mistake is to not specify a list but just a single Java object
+	# but, well, people just keep doing it so we may as well support it 
+	dim <- if (inherits(x,"jobjRef")) {
+		x <- list(x)
+		1L
+	} else getDim(x)
+
+	# the jni call
+	array <- .Call(RcreateArray, x, contents.class)
+	
+	if (!dispatch) return( array )
+	
+	if( is.list( x ) ){
+		# if the input of RcreateArray was a list, we need some more care
+		# because we cannot be sure the array is rectangular so we have to 
+		# check it 
+		newArray( array, simplify = FALSE )
+	} else {
+	
+		# then we transform this to a rectangular array of the proper dimensions
+		if( length( dim ) == 1L ) {
+			# single dimension array
+			new( "jrectRef", jobj = array@jobj, jsig = array@jsig, 
+					jclass = array@jclass, dimension = dim )
+		} else {
+			builder <- .jnew( "RectangularArrayBuilder", .jcast(array), dim )
+			clazz <- .jcall( builder, "Ljava/lang/String;", "getArrayClassName" )
+			
+			# we cannot use .jcall here since it will try to simplify the array
+			# or go back to java to calculate its dimensions, ...
+			r <- .External( "RcallMethod", builder@jobj, 
+				"Ljava/lang/Object;", "getArray", PACKAGE="rJava")
+			
+			new( "jrectRef", jobj = r, dimension = dim, 
+				jclass = clazz, jsig = tojni( clazz ) ) 
+		}  
+	}
+}
+
+# works on EXTPTR or jobjRef or NULL. NULL is always silently converted to .jzeroRef
+.jidenticalRef <- function(a,b) {        
+  if (is(a,"jobjRef")) a<-a@jobj
+  if (is(b,"jobjRef")) b<-b@jobj
+  if (is.null(a)) a <- .jzeroRef
+  if (is.null(b)) b <- .jzeroRef
+  if (!inherits(a,"externalptr") || !inherits(b,"externalptr")) stop("Invalid argument to .jidenticalRef, must be a pointer or jobjRef")
+  .Call(RidenticalRef,a,b)
+}
+
+# returns TRUE only for NULL or jobjRef with jobj=0x0
+is.jnull <- function(x) {
+  (is.null(x) || (is(x,"jobjRef") && .jidenticalRef(x@jobj,.jzeroRef)))
+}
+
+# should we move this to C?
+.jclassRef <- function(x, silent=FALSE) {
+  if (is.jnull(x)) {
+    if (silent) return(NULL) else stop("null reference has no class")
+  }
+  if (!is(x, "jobjRef")) {
+    if (silent) return(NULL) else stop("invalid object")
+  }
+  cl <- NULL
+  try(cl <- .jcall(x, "Ljava/lang/Class;", "getClass", check=FALSE))
+  .jcheck(silent=TRUE)
+  if (is.jnull(cl) && !silent) stop("cannot get class object")
+  cl
+}
+
+# return class object for a given class name; silent determines whether
+# an error should be thrown on failure (FALSE) or just null reference (TRUE)
+.jfindClass <- function(cl, silent=FALSE) {
+  if (inherits(cl, "jclassName")) return(cl@jobj)
+  if (!is.character(cl) || length(cl)!=1)
+    stop("invalid class name")
+  cl<-gsub("/",".",cl)
+  a <- NULL
+  if (!is.jnull(.rJava.class.loader))
+    try(a <- .jcall("java/lang/Class","Ljava/lang/Class;","forName",cl,TRUE,.jcast(.rJava.class.loader,"java.lang.ClassLoader"), check=FALSE))
+  else
+    try(a <- .jcall("java/lang/Class","Ljava/lang/Class;","forName",cl,check=FALSE))
+  # this is really .jcheck but we don't want it to appear on the call stack
+  .Call(RJavaCheckExceptions, silent)
+  if (!silent && is.jnull(a)) stop("class not found")
+  a
+}
+
+# Java-side inheritance check; NULL inherits from any class, because 
+# it can be cast to any class type; cl can be a class name or a jobjRef to a class object
+.jinherits <- function(o, cl) {
+  if (is.jnull(o)) return(TRUE)
+  if (!is(o, "jobjRef")) stop("invalid object")
+  if (is.character(cl)) cl <- .jfindClass(cl) else if (inherits(cl, "jclassName")) cl <- cl@jobj
+  if (!is(cl, "jobjRef")) stop("invalid class object")  
+  ocl <- .jclassRef(o)
+  .Call(RisAssignableFrom, ocl@jobj, cl@jobj)
+}
+
+# compares two things which may be Java objects. invokes Object.equals if applicable and thus even different pointers can be equal. if one parameter is not Java object, but scalar string/int/number/boolean then a corresponding Java object is created for comparison
+# strict comparison returns FALSE if Java-reference is compared with non-reference. otherwise conversion into Java scalar object is attempted
+.jequals <- function(a, b, strict=FALSE) {
+  if (is.null(a)) a <- new("jobjRef")
+  if (is.null(b)) b <- new("jobjRef")
+  if (is(a,"jobjRef")) o <- a else
+    if (is(b,"jobjRef")) { o <- b; b <- a } else
+    return(all.equal(a,b))
+  if (!is(b,"jobjRef")) {
+    if (strict) return(FALSE)
+    if (length(b)!=1) { warning("comparison of non-scalar values is always FALSE"); return(FALSE) }
+    if (is.character(b)) b <- .jnew("java/lang/String",b) else
+    if (is.integer(b)) b <- .jnew("java/lang/Integer",b) else
+    if (is.numeric(b)) b <- .jnew("java/lang/Double",b) else
+    if (is.logical(b)) b <- .jnew("java/lang/Boolean", b) else
+    { warning("comparison of non-trivial values to Java objects is always FALSE"); return(FALSE) }
+  }
+  if (is.jnull(a))
+    is.jnull(b)
+  else
+    .jcall(o, "Z", "equals", .jcast(b, "java/lang/Object"))
+}
+
+.jfield <- function(o, sig=NULL, name, true.class=is.null(sig), convert=TRUE) {
+  if (length(sig)) {
+    if (sig=='S') sig<-"Ljava/lang/String;"
+    if (sig=='T') sig<-"S"
+    if (sig=='[S') sig<-"[Ljava/lang/String;"
+    if (sig=='[T') sig<-"[S"
+  }
+  r <- .Call(RgetField, o, sig, as.character(name), as.integer(true.class))
+  if (inherits(r, "jobjRef")) {
+    if (isJavaArraySignature(r@jclass)) {
+    	r <- if (convert) .jevalArray(r, rawJNIRefSignature=r@jclass, simplify=TRUE) else newArray(r, simplify=FALSE)
+    }
+    if (convert && inherits(r, "jobjRef")) {
+      if (r@jclass == "java/lang/String")
+        return(.External(RgetStringValue, r@jobj))
+      if (.conv.in$.) return(.convert.in(r))
+    }
+  }
+  r
+}
+
+".jfield<-" <- function(o, name, value)
+  .Call(RsetField, o, name, value)
+

com.oracle.truffle.r.pkgs/rJava/R/comparison.R

+
+#' if a and b are compatable, 
+#' in the sense of the java.util.Comparable interface
+#' then the result of the compareTo method is returned
+#' otherwise an error message is generated
+.jcompare <- function(a, b) {
+  if (is.null(a)) a <- new("jobjRef")
+  if (is.null(b)) b <- new("jobjRef")
+  
+  if( isJavaArray(a) || isJavaArray(b) ){
+  	  stop( "comparison (<,>,<=,>=) is not implemented for java arrays yet" )
+  }
+  
+  if( !is(a, "jobjRef" ) ) a <- ._java_valid_object( a )
+  if( !is(b, "jobjRef" ) ) b <- ._java_valid_object( b )
+  
+  .jcall( "RJavaComparator", "I", "compare", .jcast(a), .jcast(b) )
+  
+}
+._lower <- function(e1, e2){
+	.jcompare( e1, e2 ) <= 0L
+}
+._greater <- function(e1, e2 ){
+	.jcompare( e1, e2 ) >= 0L
+}
+._strictly_lower <- function(e1, e2 ){
+	.jcompare( e1, e2 ) < 0L
+}
+._strictly_greater <- function(e1, e2 ){
+	.jcompare( e1, e2 ) > 0L
+}
+
+setMethod("<" , c(e1="jobjRef",e2="jobjRef"), ._strictly_lower )
+setMethod("<" , c(e1="jobjRef")             , ._strictly_lower )
+setMethod("<" , c(e2="jobjRef")             , ._strictly_lower )
+              
+setMethod(">" , c(e1="jobjRef",e2="jobjRef"), ._strictly_greater )
+setMethod(">" , c(e1="jobjRef")             , ._strictly_greater )
+setMethod(">" , c(e2="jobjRef")             , ._strictly_greater )
+
+setMethod("<=", c(e1="jobjRef",e2="jobjRef"), ._lower )
+setMethod("<=", c(e1="jobjRef")             , ._lower )
+setMethod("<=", c(e2="jobjRef")             , ._lower )
+                                               
+setMethod(">=", c(e1="jobjRef",e2="jobjRef"), ._greater )
+setMethod(">=", c(e1="jobjRef")             , ._greater )
+setMethod(">=", c(e2="jobjRef")             , ._greater )
+
+

com.oracle.truffle.r.pkgs/rJava/R/completion.R

+# :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1:
+
+# S4 dispatch does not work for .DollarNames, so we'll use S3
+# {{{ bring .DollarNames from the future if necessary
+if( !exists( ".DollarNames", envir = asNamespace("utils") ) ){
+	.DollarNames <- function(x, pattern)
+    	UseMethod(".DollarNames")
+} 
+# }}}
+
+# {{{ support function to retrieve completion names from RJavaTools
+### get completion names from RJavaTools
+classNamesMethod <- function (cl, static.only = TRUE ) {
+	# TODO: return both from java instead of two java calls
+  fieldnames <- .jcall( "RJavaTools", "[Ljava/lang/String;", 
+  	"getFieldNames", cl, static.only ) 
+  methodnames <- .jcall( "RJavaTools", "[Ljava/lang/String;", 
+  	"getMethodNames", cl, static.only )
+  c(fieldnames, methodnames)
+}
+# }}}
+
+# {{{ jclassName
+._names_jclassName <- function(x){
+	c( "class", classNamesMethod(x@jobj, static.only = TRUE ) )
+}
+.DollarNames.jclassName <- function(x, pattern = "" ){
+	grep( pattern, ._names_jclassName(x), value = TRUE ) 
+}
+
+setMethod("names", c(x="jclassName"), ._names_jclassName )
+# }}}
+
+# {{{ jobjRef
+._names_jobjRef <- function(x){
+	classNamesMethod(.jcall(x, "Ljava/lang/Class;", "getClass"), static.only = FALSE )
+}
+.DollarNames.jobjRef <- function(x, pattern = "" ){
+	grep( pattern, ._names_jobjRef(x), value = TRUE )
+}
+setMethod("names", c(x="jobjRef"), ._names_jobjRef )
+# }}}
+
+# {{{ jarrayRef and jrectRef
+._names_jarrayRef <- function(x ){
+	c("length", classNamesMethod(.jcall(x, "Ljava/lang/Class;", "getClass"), static.only = FALSE ) )
+}
+.DollarNames.jarrayRef <- .DollarNames.jrectRef <- function(x, pattern = ""){
+	grep( pattern, ._names_jarrayRef(x), value = TRUE )
+}
+
+setMethod("names", c(x="jarrayRef"), ._names_jarrayRef )
+setMethod("names", c(x="jrectRef"), ._names_jarrayRef )
+
+
+# }}}

com.oracle.truffle.r.pkgs/rJava/R/converter.R

+# in: Java -> R
+.conv.in <- new.env(parent=emptyenv())
+.conv.in$. <- FALSE
+# out: R -> Java
+.conv.out <- new.env(parent=emptyenv())
+.conv.out$. <- FALSE
+
+# --- internal fns
+.convert.in <- function(jobj, verify.class=TRUE) {  
+  jcl <- if (verify.class) .jclass(jobj) else gsub("/",".",jobj@jclass)
+  cv <- .conv.in[[jcl]]
+  if (!is.null(cv)) jobj else cv$fn(jobj)
+}
+
+.convert.out <- function(robj) {
+  for (cl in class(robj)) {
+    cv <- .conv.out[[cl]]
+    if (!is.null(cv)) return(cv$fn(robj))
+  }
+  robj
+}
+
+# external fns
+.jsetJConvertor <- function(java.class, fn) {
+  if (is.null(fn)) {
+    rm(list=java.class, envir=.conv.in)
+    if (!length(ls(.conv.in))) .conv.in$. <- FALSE
+  } else {
+    .conv.in$. <- TRUE
+    .conv.in[[java.class]] <- list(fn=fn)
+  }
+}
+
+.jsetRConvertor <- function(r.class, fn) {
+  if (is.null(fn)) {
+    rm(list=r.class, envir=.conv.out)
+    if (!length(ls(.conv.out))) .conv.out$. <- FALSE
+  } else {
+    .conv.out$. <- TRUE
+    .conv.out[[r.class]] <- list(fn=fn)
+  }
+}
+

com.oracle.truffle.r.pkgs/rJava/R/exceptions.R

+## functions for some basic exception handling
+
+# FIXME: should all these actually be deprecated or defunct
+
+## poll for an exception
+.jgetEx <- function(clear=FALSE) {
+  exo <- .Call(RpollException)
+  if (is.null(exo)) return(NULL)
+  x <- new("jobjRef", jobj=exo, jclass="java/lang/Throwable")
+  if (clear) .jclear()
+  x
+}
+
+## explicitly clear any pending exceptions
+.jclear <- function() {
+  .C(RclearException)
+  invisible(NULL)
+}
+
+## throw an exception
+.jthrow <- function(exception, message=NULL) {
+  if (is.character(exception))
+    exception <- .jnew(exception, as.character(message))
+  if (is(exception, "jobjRef"))
+    .Call(RthrowException, exception)
+  else
+    stop("Invalid exception.")
+}
+
+
+"$.Throwable" <- function( x, name ){
+	if( name %in% names(c(x)) ){
+		c(x)[[ name ]]
+	} else{
+		._jobjRef_dollar( x[["jobj"]], name )
+	}
+}
+
+"$<-.Throwable" <- function( x, name, value ){
+	if( name %in% names(x) ){
+		x[[ name ]] <- value
+	} else{
+		._jobjRef_dollargets( x[["jobj"]], name, value )
+	}
+	x
+	
+}
+

com.oracle.truffle.r.pkgs/rJava/R/import.R

+
+IMPORTER <- ".__rjava__import"
+
+java_class_importers <- new.env()
+assign( ".namespaces", NULL, envir = java_class_importers )
+
+getImporterFromNamespace <- function( nm, create = TRUE ){
+	.namespaces <- get(".namespaces", envir = java_class_importers )
+	if( !is.null( .namespaces ) ){
+		for( item in .namespaces ){
+			if( identical( item$nm, nm ) ){
+				return( item$importer )
+			}
+		}
+	}
+	if( create ){
+		addImporterNamespace(nm)
+	}
+	
+}
+addImporterNamespace <- function( nm ){
+	importer <- .jnew( "RJavaImport", .jcast( .rJava.class.loader, "java/lang/ClassLoader" ) )
+	assign( ".namespaces",	
+		append( list( list( nm = nm, importer = importer ) ), get(".namespaces", envir = java_class_importers ) ), 
+		envir = java_class_importers )
+	importer
+}
+
+getImporterFromEnvironment <- function(env, create = TRUE){
+	if( isNamespace( env ) ){
+		getImporterFromNamespace( env )
+	} else if( exists(IMPORTER, envir = env ) ){
+		get( IMPORTER, envir = env )
+	} else if( create ){
+		addImporterNamespace(env)
+	}
+}
+
+getImporterFromGlobalEnv <- function( ){
+	if( exists( "global", envir = java_class_importers ) ){
+		get( "global", envir = java_class_importers ) 
+	} else{
+		initGlobalEnvImporter()
+	}
+}
+initGlobalEnvImporter <- function(){
+	importer <- .jnew( "RJavaImport", .jcast( .rJava.class.loader, "java/lang/ClassLoader" ) )
+	assign( "global", importer , envir = java_class_importers )
+	importer
+}
+
+import <- function( package = "java.util", env = sys.frame(sys.parent()) ){
+	
+	if( missing(env) ){
+		caller <- sys.function(-1)
+		env <- environment( caller ) 
+		if( isNamespace( env ) ){
+			importer <- getImporterFromNamespace( env )
+		}
+	} else{
+		force(env)
+	
+		if( !is.environment( env ) ){
+			stop( "env is not an environment" ) 
+		}
+		
+		if( ! exists( IMPORTER, env ) || is.jnull( get( IMPORTER, envir = env ) ) ){
+			importer <- .jnew( "RJavaImport", .jcast( .rJava.class.loader, "java/lang/ClassLoader" ) )
+			if( isNamespace(env) ){
+				unlockBinding( IMPORTER, env = env )
+				assignInNamespace( IMPORTER, importer, envir = env ) 
+			}
+			assign( IMPORTER, importer, envir = env ) 
+		} else{
+			importer <- get( IMPORTER, envir = env )
+		}
+	}
+	mustbe.importer( importer )
+	.jcall( importer, "V", "importPackage", package )
+	
+}
+
+is.importer <- function(x){
+	is( x, "jobjRef" ) && .jinherits( x, "RJavaImport" )
+}
+mustbe.importer <- function(x){
+	if( !is.importer(x) ){
+		stop( "object not a suitable java package importer" )
+	}
+}
+
+#' collect importers
+getAvailableImporters <- function( frames = TRUE, namespace = TRUE, 
+	global = TRUE, caller = sys.function(-1L) ){
+	
+	importers <- .jnew( "java/util/HashSet" )
+	
+	addImporter <- function( importer ){
+		if( is.importer( importer ) ){
+			.jcall( importers, "Z", "add", .jcast(importer) )
+		}
+	}
+	if( isTRUE( global ) ){
+		addImporter( getImporterFromGlobalEnv() )
+	}
+	
+	if( isTRUE( frames ) ){
+		frames <- sys.frames()
+		if( length(frames) > 1L ){
+			sapply( head( frames, -1L ), function(env) {
+				if( !identical( env, .GlobalEnv ) ){
+					addImporter( getImporterFromEnvironment( env ) )
+				}
+			} )
+		}
+	}
+	
+	if( isTRUE( namespace ) ){
+		force(caller)
+		env <- environment( caller ) 
+		if( isNamespace( env ) ){
+			addImporter( getImporterFromNamespace( env ) )
+		}
+	}
+	
+	importers
+}
+
+#' lookup for a class name in the available importers
+lookup <- function( name = "Object", ..., caller = sys.function(-1L) ){
+	force(caller)
+	importers <- getAvailableImporters(..., caller = caller)
+	.jcall( "RJavaImport", "Ljava/lang/Class;", "lookup", 
+		name, .jcast( importers, "java/util/Set" )  )
+}
+
+
+javaImport <- function( packages = "java.lang" ){
+	importer <- .jnew( "RJavaImport", .jcast( .rJava.class.loader, "java/lang/ClassLoader" ) )
+	.jcall( importer, "V", "importPackage", packages )
+	.Call( "newRJavaLookupTable" , importer, 
+		PACKAGE = "rJava" )
+}
+

com.oracle.truffle.r.pkgs/rJava/R/instanceof.R

+`%instanceof%` <- .jinstanceof <- function( o, cl ){
+	
+	if( !inherits( o, "jobjRef" ) ){
+		stop( "o is not a java object" )
+	}
+	
+	# first get the class object that represents cl
+	if( inherits( cl, "jobjRef" ) ){
+		if( .jclass( cl ) == "java.lang.Class" ){
+			clazz <- cl
+		} else {
+			clazz <- .jcall( cl, "Ljava/lang/Class;", "getClass" ) 
+		}
+	} else if( inherits( cl, "jclassName" ) ) {
+		clazz <- cl@jobj
+	} else if( inherits( cl, "character" ) ){
+		clazz <- .jfindClass(cl)
+	} else {
+		return(FALSE)
+	}
+	
+	# then find out if o is an instance of the class
+	.jcall( clazz , "Z", "isInstance", .jcast(o, "java/lang/Object" ) )
+}
+

com.oracle.truffle.r.pkgs/rJava/R/jfirst.R

+# this part is common to all platforms and must be invoked
+# from .First.lib after library.dynam
+
+# actual namespace environment of this package
+.env <- environment()
+
+# variables in the rJava environment that will be initialized *after* the package is loaded
+# they need to be pre-created at load time and populated later by .jinit
+.delayed.export.variables <- c(".jniInitialized", ".jclassObject", ".jclassString", ".jclassClass",
+                               ".jclass.int", ".jclass.double", ".jclass.float", ".jclass.boolean",
+                               ".jclass.void", ".jinit.merge.error")
+# variables that are delayed but not exported are added here
+.delayed.variables <- c(.delayed.export.variables, ".rJava.class.loader")
+
+# C entry points to register
+.register.addr <- c( # .Call
+                    "PushToREXP", "RJava_checkJVM", "RJava_needs_init", "RJava_new_class_loader",
+                    "RJava_primary_class_loader", "RJava_set_class_loader", "RJava_set_memprof", "RJavaCheckExceptions",
+                    "RcreateArray", "RgetBoolArrayCont", "RgetByteArrayCont", "RgetCharArrayCont",
+                    "RgetDoubleArrayCont", "RgetField", "RgetFloatArrayCont", "RgetIntArrayCont",
+                    "RgetLongArrayCont", "RgetNullReference", "RgetObjectArrayCont",
+                    "RgetShortArrayCont", "RgetStringArrayCont", "RidenticalRef",
+                    "RisAssignableFrom", "RpollException", "RsetField", "RthrowException",
+                    "javaObjectCache",
+                     # .External
+                    "RcreateObject", "RgetStringValue", "RinitJVM", "RtoString",
+                     # .C
+                    "RclearException", "RuseJNICache"
+                    )
+
+.jfirst <- function(libname, pkgname) {
+  # register all C entry points
+  addr <- getNativeSymbolInfo(.register.addr, pkgname)
+  for (name in .register.addr)
+     .env[[name]] <- addr[[name]]$address
+
+  assign(".rJava.base.path", paste(libname, pkgname, sep=.Platform$file.sep), .env)
+  assign(".jzeroRef", .Call(RgetNullReference), .env)
+
+  for (x in .delayed.variables) assign(x, NULL, .env)
+  assign(".jniInitialized", FALSE, .env)
+
+  # default JVM initialization parameters
+  if (is.null(getOption("java.parameters")))
+    options("java.parameters"="-Xmx512m")
+  
+  ## S4 classes update - all classes are created earlier in classes.R, but jobjRef's prototype is only valid after the dylib is loaded
+  setClass("jobjRef", representation(jobj="externalptr", jclass="character"), prototype=list(jobj=.jzeroRef, jclass="java/lang/Object"), where=.env)  
+}

com.oracle.truffle.r.pkgs/rJava/R/jinit.R

+## This file is part of the rJava package - low-level R/Java interface
+## (C)2006 Simon Urbanek <simon.urbanek@r-project.org>
+## For license terms see DESCRIPTION and/or LICENSE
+##
+## $Id$
+
+.check.JVM <- function() 
+    .Call(RJava_checkJVM)
+.need.init <- function()
+    .Call(RJava_needs_init)
+
+## initialization
+.jinit <- function(classpath=NULL, parameters=getOption("java.parameters"), ..., silent=FALSE, force.init=FALSE) {
+  running.classpath <- character()
+  if (!.need.init()) {
+    running.classpath <- .jclassPath()
+    if (!force.init) {
+      if (length(classpath)) {
+        cpc <- unique(unlist(strsplit(classpath, .Platform$path.sep)))
+        if (length(cpc)) .jaddClassPath(cpc)
+      }
+      return(0)
+    }
+  }
+
+  ## determine path separator
+  path.sep <- .Platform$path.sep
+
+  if (!is.null(classpath)) {
+    classpath <- as.character(classpath)
+    if (length(classpath))
+      classpath <- paste(classpath,collapse=path.sep)
+  }
+  
+  # merge CLASSPATH environment variable if present
+  cp<-Sys.getenv("CLASSPATH")
+  if (!is.null(cp)) {
+    if (is.null(classpath))
+      classpath<-cp
+    else
+      classpath<-paste(classpath,cp,sep=path.sep)
+  }
+  
+  # set rJava/java/boot for boostrap (so we can get RJavaClassLoader)
+  boot.classpath <- file.path(.rJava.base.path,"java","boot")
+
+  # if running in a sub-arch, append -Dr.arch in case someone gets the idea to start JRI
+  if (is.character(.Platform$r_arch) && nzchar(.Platform$r_arch) && length(grep("-Dr.arch", parameters, fixed=TRUE)) == 0L)
+    parameters <- c(paste("-Dr.arch=/", .Platform$r_arch, sep=''), as.character(parameters))
+
+  ## unfortunately Sys/setlocale()/Sys.getlocale() have incompatible interfaces so there
+  ## is no good way to get/set locales -- so we have to hack around it ...
+  locale.list <- c("LC_COLLATE", "LC_CTYPE", "LC_MONETARY", "LC_NUMERIC", "LC_TIME", "LC_MESSAGES", "LC_PAPER", "LC_MEASUREMENT")
+  locales <- sapply(locale.list, Sys.getlocale)
+  loc.sig <- Sys.getlocale()
+
+  #cat(">> init CLASSPATH =",classpath,"\n")
+  #cat(">> boot class path: ", boot.classpath,"\n")
+  # call the corresponding C routine to initialize JVM
+  xr <- .External(RinitJVM, boot.classpath, parameters)
+
+  ## we have to re-set the locales right away
+  suppressWarnings(try(if (!identical(Sys.getlocale(), loc.sig)) for (i in names(locales)) try(Sys.setlocale(i, locales[i]), silent=TRUE),
+      silent=TRUE))
+
+  if (xr==-1) stop("Unable to initialize JVM.")
+  if (xr==-2) stop("Another VM is already running and rJava was unable to attach to that VM.")
+  # we'll handle xr==1 later because we need fully initialized rJava for that
+
+  # this should remove any lingering .jclass objects from the global env
+  # left there by previous versions of rJava
+  pj <- grep("^\\.jclass",ls(1,all.names=TRUE),value=TRUE)
+  if (length(pj)>0) { 
+    rm(list=pj,pos=1)
+    if (exists(".jniInitialized",1)) rm(list=".jniInitialized",pos=1)
+    if (!silent) warning("rJava found hidden Java objects in your workspace. Internal objects from previous versions of rJava were deleted. Please note that Java objects cannot be saved in the workspace.")
+  }
+
+  ##--- HACK-WARNING: we're operating directly on the namespace environment
+  ##                  this could be dangerous.
+  for (x in .delayed.variables) unlockBinding(x, .env)
+  assign(".jniInitialized", TRUE, .env)
+  # get cached class objects for reflection
+  assign(".jclassObject", .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Object"), .env)
+  assign(".jclassClass", .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Class"), .env)
+  assign(".jclassString", .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.String"), .env)
+
+  ic <- .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Integer")
+  f<-.jcall(ic,"Ljava/lang/reflect/Field;","getField", "TYPE")
+  assign(".jclass.int", .jcast(.jcall(f,"Ljava/lang/Object;","get",.jcast(ic,"java/lang/Object")),"java/lang/Class"), .env)
+  ic <- .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Double")
+  f<-.jcall(ic,"Ljava/lang/reflect/Field;","getField", "TYPE")
+  assign(".jclass.double", .jcast(.jcall(f,"Ljava/lang/Object;","get",.jcast(ic,"java/lang/Object")),"java/lang/Class"), .env)
+  ic <- .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Float")
+  f<-.jcall(ic,"Ljava/lang/reflect/Field;","getField", "TYPE")
+  assign(".jclass.float", .jcast(.jcall(f,"Ljava/lang/Object;","get",.jcast(ic,"java/lang/Object")),"java/lang/Class"), .env)
+  ic <- .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Boolean")
+  f<-.jcall(ic,"Ljava/lang/reflect/Field;","getField", "TYPE")
+  assign(".jclass.boolean", .jcast(.jcall(f,"Ljava/lang/Object;","get",.jcast(ic,"java/lang/Object")),"java/lang/Class"), .env)
+  ic <- .jcall("java/lang/Class","Ljava/lang/Class;","forName","java.lang.Void")
+  f<-.jcall(ic,"Ljava/lang/reflect/Field;","getField", "TYPE")
+  assign(".jclass.void", .jcast(.jcall(f,"Ljava/lang/Object;","get",.jcast(ic,"java/lang/Object")),"java/lang/Class"), .env)
+
+  ## if NOAWT is set, set AWT to headless
+  if (nzchar(Sys.getenv("NOAWT"))) .jcall("java/lang/System","S","setProperty","java.awt.headless","true")
+
+  lib <- "libs"
+  if (nchar(.Platform$r_arch)) lib <- file.path("libs", .Platform$r_arch)
+
+  rjcl <- NULL
+  if (xr==1) { # && nchar(classpath)>0) {
+    # ok, so we're attached to some other JVM - now we need to make sure that
+    # we can load our class loader. If we can't then we have to use our bad hack
+    # to be able to squeeze our loader in
+
+    # first, see if this is actually JRIBootstrap so we have a loader already
+    rjcl <- .Call(RJava_primary_class_loader)
+    if (is.null(rjcl) || .jidenticalRef(rjcl,.jzeroRef)) rjcl <- NULL
+    else rjcl <- new("jobjRef", jobj=rjcl, jclass="RJavaClassLoader")
+    if (is.jnull(rjcl))
+      rjcl <- .jnew("RJavaClassLoader", .rJava.base.path,
+                                      file.path(.rJava.base.path, lib), check=FALSE)
+    .jcheck(silent=TRUE)
+    if (is.jnull(rjcl)) {
+      ## it's a hack, so we run it in try(..) in case BadThings(TM) happen ...
+      cpr <- try(.jmergeClassPath(boot.classpath), silent=TRUE)
+      if (inherits(cpr, "try-error")) {
+        .jcheck(silent=TRUE)
+        if (!silent) warning("Another VM is running already and the VM did not allow me to append paths to the class path.")
+        assign(".jinit.merge.error", cpr, .env)
+      }
+      if (length(parameters)>0 && any(parameters!=getOption("java.parameters")) && !silent)
+        warning("Cannot set VM parameters, because VM is running already.")
+    }
+  }
+
+  if (is.jnull(rjcl))
+    rjcl <- .jnew("RJavaClassLoader", .rJava.base.path,
+                  file.path(.rJava.base.path, lib), check=FALSE )
+
+  if (!is.jnull(rjcl)) {
+    ## init class loader
+    assign(".rJava.class.loader", rjcl, .env)
+
+    ##-- set the class for native code
+    .Call(RJava_set_class_loader, .env$.rJava.class.loader@jobj)
+
+    ## now it's time to add any additional class paths
+    cpc <- unique(strsplit(classpath, .Platform$path.sep)[[1]])
+    if (length(cpc)) .jaddClassPath(cpc)
+  } else stop("Unable to create a Java class loader.")
+  
+  ##.Call(RJava_new_class_loader, .rJava.base.path, file.path(.rJava.base.path, lib))
+
+  ## lock namespace bindings
+  for (x in .delayed.variables) lockBinding(x, .env)
+  
+  ## now we need to update the attached namespace (package env)  as well
+  m <- match(paste("package", getNamespaceName(.env), sep = ":"), search())[1]
+  if (!is.na(m)) { ## only is it is attached
+    pe <- as.environment(m)
+    for (x in .delayed.export.variables) {
+      unlockBinding(x, pe)
+      pe[[x]] <- .env[[x]]
+      lockBinding(x, pe)
+    }
+  }
+  
+  # FIXME: is this the best place or should this be done 
+  #        internally right after the RJavaClassLoader is instanciated
+  # init the cached RJavaTools class in the jni side
+  .Call( "initRJavaTools", PACKAGE = "rJava" ) 
+  
+  # not yet
+  # import( c( "java.lang", "java.util") )
+  
+  invisible(xr)
+}
+
+# FIXME: this is not always true: osgi, eclipse etc use a different
+#        class loader strategy, we should add some sort of hook to let people
+#        define how they want this to be done
+.jmergeClassPath <- function(cp) {
+  ccp <- .jcall("java/lang/System","S","getProperty","java.class.path")
+  ccpc <- strsplit(ccp, .Platform$path.sep)[[1]]
+  cpc <- strsplit(cp, .Platform$path.sep)[[1]]
+  rcp <- unique(cpc[!(cpc %in% ccpc)])
+  if (length(rcp) > 0) {
+    # the loader requires directories to include trailing slash
+    # Windows: need / or \ ? (untested)
+    dirs <- which(file.info(rcp)$isdir)
+    for (i in dirs)
+      if (substr(rcp[i],nchar(rcp[i]),nchar(rcp[i]))!=.Platform$file.sep)
+        rcp[i]<-paste(rcp[i], .Platform$file.sep, sep='')
+
+    ## this is a hack, really, that exploits the fact that the system class loader
+    ## is in fact a subclass of URLClassLoader and it also subverts protection
+    ## of the addURL class using reflection - yes, bad hack, but we use it
+    ## only if the boot class path doesn't contain our own class loader so
+    ## we cannot replace the system loader with our own (this will happen when we
+    ## need to attach to an existing VM)
+    ## The original discussion and code for this hack was at:
+    ## http://forum.java.sun.com/thread.jspa?threadID=300557&start=15&tstart=0
+
+    ## it should probably be run in try(..) because chances are that it will
+    ## break if Sun changes something...
+    cl <- .jcall("java/lang/ClassLoader", "Ljava/lang/ClassLoader;", "getSystemClassLoader")
+    urlc <- .jcall("java/lang/Class", "Ljava/lang/Class;", "forName", "java.net.URL")
+    clc <- .jcall("java/lang/Class", "Ljava/lang/Class;", "forName", "java.net.URLClassLoader")
+    ar <- .jcall("java/lang/reflect/Array", "Ljava/lang/Object;",
+                         "newInstance", .jclassClass, 1:1)
+    .jcall("java/lang/reflect/Array", "V", "set",
+                  .jcast(ar, "java/lang/Object"), 0:0,
+                  .jcast(urlc, "java/lang/Object"))
+    m<-.jcall(clc, "Ljava/lang/reflect/Method;", "getDeclaredMethod", "addURL", .jcast(ar,"[Ljava/lang/Class;"))
+    .jcall(m, "V", "setAccessible", TRUE)
+
+    ar <- .jcall("java/lang/reflect/Array", "Ljava/lang/Object;",
+                 "newInstance", .jclassObject, 1:1)
+    
+    for (fn in rcp) {
+      f <- .jnew("java/io/File", fn)
+      url <- .jcall(f, "Ljava/net/URL;", "toURL")
+      .jcall("java/lang/reflect/Array", "V", "set",
+             .jcast(ar, "java/lang/Object"), 0:0,
+             .jcast(url, "java/lang/Object"))
+      .jcall(m, "Ljava/lang/Object;", "invoke",
+             .jcast(cl, "java/lang/Object"), .jcast(ar, "[Ljava/lang/Object;"))
+    }
+
+    # also adjust the java.class.path property to not confuse others
+    if (length(ccp)>1 || (length(ccp)==1 && nchar(ccp[1])>0))
+      rcp <- c(ccp, rcp)
+    acp <- paste(rcp, collapse=.Platform$path.sep)
+    .jcall("java/lang/System","S","setProperty","java.class.path",as.character(acp))
+  } # if #rcp>0
+  invisible(.jcall("java/lang/System","S","getProperty","java.class.path"))
+}

com.oracle.truffle.r.pkgs/rJava/R/jri.R

+## bindings into JRI
+
+## warning: JRI REXP class has currently no finalizers! (RReleaseREXP must be used manually for now)
+## warning: this produces JRI-API pbjects - that should go away! use toJava below
+.r2j <- function(x, engine = NULL, convert = TRUE) {
+  if (is.null(engine)) engine <- .jcall("org/rosuda/JRI/Rengine","Lorg/rosuda/JRI/Rengine;","getMainEngine")
+  if (!is(engine, "jobjRef")) stop("invalid or non-existent engine")
+  new("jobjRef",jobj=.Call(PushToREXP,"org/rosuda/JRI/REXP",engine@jobj,engine@jclass,x,convert),jclass="org/rosuda/JRI/REXP")
+}
+
+toJava <- function(x, engine = NULL) {
+  ## this is really the wrong place for all this REngine checking stuff, but so far .jengine uses JRI API only and legacy code may rely on that
+  ## so this is the only place that assumes REngine API and thus will load it ...
+  ec <- .jfindClass("org.rosuda.JRI.Rengine", silent=TRUE)
+  if (is.jnull(ec)) {
+    .jcheck(TRUE)
+    stop("JRI is not loaded. Please start JRI first - see ?.jengine")
+  }
+  ec <- .jfindClass("org.rosuda.REngine.REngine", silent=TRUE)
+  if (is.jnull(ec)) {
+    .jcheck(TRUE)
+    fn <- system.file("jri","REngine.jar",package="rJava")
+    if (nzchar(fn)) .jaddClassPath(fn)
+    fn <- system.file("jri","JRIEngine.jar",package="rJava")
+    if (nzchar(fn)) .jaddClassPath(fn)
+    ec <- .jfindClass("org.rosuda.REngine.REngine", silent=TRUE)
+    if (is.jnull(ec)) {
+      .jcheck(TRUE)
+      stop("Cannot find REngine API classes. Please make sure you have installed and loaded the REngine API")
+    }
+  }
+  if (is.null(engine)) engine <- .jcall("org/rosuda/REngine/REngine","Lorg/rosuda/REngine/REngine;","getLastEngine")
+  if (is.jnull(engine)) { # no last engine, but there may be JRI engine already running ...
+    me <- .jcall("org/rosuda/JRI/Rengine","Lorg/rosuda/JRI/Rengine;","getMainEngine", check=FALSE)
+    .jcheck(TRUE)
+    if (is.jnull(me)) stop("JRI is not running. Please start JRI first - see ?.jengine")
+    engine <- .jnew("org/rosuda/REngine/JRI/JRIEngine", me)
+    .jcheck(TRUE)
+  }
+  .jcheck(TRUE)
+  if (!is(engine, "jobjRef")) stop("invalid or non-existent engine")
+  new("jobjRef",jobj=.Call(PushToREXP,"org/rosuda/REngine/REXPReference",engine@jobj,"org/rosuda/REngine/REngine",x,NULL),jclass="org/rosuda/REngine/REXPReference")
+}
+
+.setupJRI <- function(new=TRUE) {
+  ec <- .jfindClass("org.rosuda.JRI.Rengine", silent=TRUE)
+  if (is.jnull(ec)) {
+    .jcheck(TRUE)
+    .jaddClassPath(system.file("jri","JRI.jar",package="rJava"))
+    ec <- .jfindClass("org.rosuda.JRI.Rengine", silent=TRUE)
+    .jcheck(TRUE)
+    if (is.jnull(ec))
+      stop("Cannot find JRI classes")
+  }
+  me <- .jcall("org/rosuda/JRI/Rengine","Lorg/rosuda/JRI/Rengine;","getMainEngine", check=FALSE)
+  .jcheck(TRUE)
+  if (!is.jnull(me)) {
+    if (!new) return(TRUE)
+    warning("JRI engine is already running.")
+    return(FALSE)
+  }
+  e <- .jnew("org/rosuda/JRI/Rengine")
+  !is.jnull(e)
+}
+
+.jengine <- function(start=FALSE, silent=FALSE) {
+  me <- NULL
+  ec <- .jfindClass("org.rosuda.JRI.Rengine", silent=TRUE)
+  .jcheck(TRUE)
+  if (!is.jnull(ec)) {
+    me <- .jcall("org/rosuda/JRI/Rengine","Lorg/rosuda/JRI/Rengine;","getMainEngine", check=FALSE)
+    .jcheck(TRUE)
+  }
+  if (is.jnull(me)) {
+    if (!start) {
+      if (silent) return(NULL)
+      stop("JRI engine is not running.")
+    }
+    .setupJRI(FALSE)
+    me <- .jcall("org/rosuda/JRI/Rengine","Lorg/rosuda/JRI/Rengine;","getMainEngine", check=FALSE)
+    .jcheck(TRUE)
+  }
+  if (is.jnull(me) && !silent)
+    stop("JRI engine is not running.")
+  me
+}

com.oracle.truffle.r.pkgs/rJava/R/loader.R

+.jaddClassPath <- function(path) {
+    if (!length(path)) return(invisible(NULL))
+    if (!is.jnull(.rJava.class.loader))
+        invisible(.jcall(.rJava.class.loader,"V","addClassPath",as.character(path)))
+    else {
+        cpr <- try(.jmergeClassPath(paste(path,collapse=.Platform$path.sep)), silent=TRUE)
+        invisible(!inherits(cpr, "try-error"))
+    }
+}
+
+.jclassPath <- function() {
+    if (is.jnull(.rJava.class.loader)) {
+        cp <- .jcall("java/lang/System", "S", "getProperty", "java.class.path")
+        unlist(strsplit(cp, .Platform$path.sep))
+    } else {
+        .jcall(.rJava.class.loader,"[Ljava/lang/String;","getClassPath")
+    }
+}
+
+.jaddLibrary <- function(name, path) {
+    if (!is.jnull(.rJava.class.loader))
+        invisible(.jcall(.rJava.class.loader, "V", "addRLibrary", as.character(name)[1], as.character(path)[1]))
+}
+
+.jrmLibrary <- function(name) {
+  ## FIXME: unimplemented
+}
+
+.jclassLoader <- function() {
+    .rJava.class.loader
+}
+
+.jpackage <- function(name, jars='*', morePaths='', nativeLibrary=FALSE, lib.loc=NULL) {
+  if (!.jniInitialized) .jinit()
+  classes <- system.file("java", package=name, lib.loc=lib.loc)
+  if (nchar(classes)) {
+    .jaddClassPath(classes)
+    if (length(jars)) {
+      if (length(jars)==1 && jars=='*') {
+        jars <- grep(".*\\.jar",list.files(classes,full.names=TRUE),TRUE,value=TRUE)
+        if (length(jars)) .jaddClassPath(jars)
+      } else .jaddClassPath(paste(classes,jars,sep=.Platform$file.sep))
+    }
+  }  
+  if (any(nchar(morePaths))) {
+    cl <- as.character(morePaths)
+    cl <- cl[nchar(cl)>0]
+    .jaddClassPath(cl)
+  }
+  if (is.logical(nativeLibrary)) {
+    if (nativeLibrary) {
+      libs <- "libs"
+      if (nchar(.Platform$r_arch)) lib <- file.path("libs", .Platform$r_arch)
+      lib <- system.file(libs, paste(name, .Platform$dynlib.ext, sep=''), package=name, lib.loc=lib.loc)
+      if (nchar(lib))
+        .jaddLibrary(name, lib)
+      else
+        warning("Native library for `",name,"' could not be found.")
+    }
+  } else {
+    .jaddLibrary(name, nativeLibrary)
+  }
+  invisible(TRUE)
+}

com.oracle.truffle.r.pkgs/rJava/R/memprof.R

+.jmemprof <- function(file = "-") {
+  if (is.null(file)) file <- ""
+  invisible(.Call(RJava_set_memprof, as.character(file)))
+}

com.oracle.truffle.r.pkgs/rJava/R/methods.R

+## methods for jobjRef class
+##
+## additional methods ($ and $<-) are defined in reflection.R
+
+# show method
+# FIXME: this should show the class of the object instead of Java-Object
+setMethod("show", c(object="jobjRef"), function(object) {
+  if (is.jnull(object)) show("Java-Object<null>") else show(paste("Java-Object{", .jstrVal(object), "}", sep=''))
+  invisible(NULL)
+})
+
+setMethod("show", c(object="jarrayRef"), function(object) {
+  show(paste("Java-Array-Object",object@jsig,":", .jstrVal(object), sep=''))
+  invisible(NULL)
+})
+
+# map R comparison operators to .jequals
+setMethod("==", c(e1="jobjRef",e2="jobjRef"), function(e1,e2) .jequals(e1,e2))
+setMethod("==", c(e1="jobjRef"), function(e1,e2) .jequals(e1,e2))
+setMethod("==", c(e2="jobjRef"), function(e1,e2) .jequals(e1,e2))
+
+setMethod("!=", c(e1="jobjRef",e2="jobjRef"), function(e1,e2) !.jequals(e1,e2))
+setMethod("!=", c(e1="jobjRef"), function(e1,e2) !.jequals(e1,e2))
+setMethod("!=", c(e2="jobjRef"), function(e1,e2) !.jequals(e1,e2))
+
+# other operators such as <,> are defined in comparison.R
+

com.oracle.truffle.r.pkgs/rJava/R/options.R

+.joptions <- function(...) {
+  l <- list(...)
+  if (length(l)==0) return(list())
+  if ("jni.cache" %in% names(l)) {
+    v <- l[["jni.cache"]]
+    if (!is.logical(v) || length(v)!=1)
+      stop("jni.cache must be a logical vector of length 1")
+    .C(RuseJNICache,v)
+    invisible(NULL)
+  }
+}