From 4f474c0048ce17b6eb54fc7926eb7bda5d7f7907 Mon Sep 17 00:00:00 2001
From: Tomas Stupka <tomas.stupka@oracle.com>
Date: Mon, 29 Jan 2018 17:01:08 +0100
Subject: [PATCH] S4 representation for jclassName, float, byte, short,
character, long
---
com.oracle.truffle.r.pkgs/rJava/R/rj.R | 189 +++++++++++++++++--------
1 file changed, 131 insertions(+), 58 deletions(-)
diff --git a/com.oracle.truffle.r.pkgs/rJava/R/rj.R b/com.oracle.truffle.r.pkgs/rJava/R/rj.R
index 4657595133..238d2d9a91 100644
--- a/com.oracle.truffle.r.pkgs/rJava/R/rj.R
+++ b/com.oracle.truffle.r.pkgs/rJava/R/rj.R
@@ -13,7 +13,7 @@
.jnew <- function (class, ..., check = TRUE, silent = !check) {
class <- gsub("/", ".", as.character(class))
co <- new.java.class(class)
- args <- .fromS4(co, ...)
+ args <- .ellipsisToJObj(co, ...)
o <- .fastr.interop.try(function() { do.call(new.external, args) }, check)
new("jobjRef", jobj=o, jclass=class)
}
@@ -23,16 +23,14 @@
.jcall <- function (obj, returnSig = "V", method, ..., evalArray = TRUE,
evalString = TRUE, check = TRUE, interface = "RcallMethod",
simplify = FALSE, use.true.class = FALSE) {
- if (isS4(obj)) {
- obj <- obj@jobj
- }
- args <- .fromS4(...)
+ obj <- .toJObj(obj)
if (is.character(obj)) {
obj <- gsub("/", ".", as.character(obj))
obj <- new.java.class(obj)
}
+ args <- .ellipsisToJObj(...)
extMethod <- function(...) {obj[method](...)}
r <- .fastr.interop.try(function() { do.call(extMethod, args) }, check)
@@ -69,43 +67,51 @@
#' @export
.jbyte <- function (x) {
- x <- as.external.byte(x)
- invisible(x)
+ storage.mode( x ) <- "integer"
+ new("jbyte", x)
}
#' @export
.jchar <- function (x) {
- x <- as.external.char(x)
- invisible(x)
+ storage.mode( x ) <- "character"
+ new("jchar", x)
}
#' @export
.jshort <- function (x) {
- x <- as.external.short(x)
- invisible(x)
+ storage.mode( x ) <- "integer"
+ new("jshort", x)
}
#' @export
.jlong <- function (x) {
- x <- as.external.long(x)
- invisible(x)
+ storage.mode( x ) <- "double"
+ new("jlong", x)
}
#' @export
-.jfloat <- function (x) {
- x <- as.external.float(x)
- invisible(x)
+.jfloat <- function (x) {
+ storage.mode( x ) <- "double"
+ new("jfloat", x )
}
#' @export
-J <- function (class, method, ...) {
- class <- gsub("/", ".", as.character(class))
- javaClass <- new.java.class(class)
+J <- function (class, method, ...) {
if (nargs() == 1L && missing(method)) {
- javaClass
+ if(inherits(class, "jclassName")) {
+ return(class)
+ } else if(is.character(class)) {
+ className <- class
+ jobj <- .jfindClass(class)
+ } else {
+ className <- as.character(class)
+ jobj <- .jfindClass(className)
+ }
+ new("jclassName", name=className, jobj=jobj)
} else {
- .jcall(javaClass, ,method, ...)
- }
+ # .jrcall(class, method, ...)
+ .jcall(class, , method, ...)
+ }
}
#' @export
@@ -153,7 +159,17 @@ J <- function (class, method, ...) {
#' @export
.jfindClass <- function (cl, silent = FALSE) {
- new.java.class(cl)
+ if (inherits(cl, "jclassName")) return(cl@jobj)
+ if (!is.character(cl) || length(cl)!=1) {
+ stop("invalid class name")
+ }
+
+ cl <- gsub("/", ".", as.character(cl))
+ javaClass <- new.java.class(cl)
+ cls <- new('jobjRef', jobj=javaClass, jclass='java.lang.Class', stringValue=paste0("class ", cl))
+ .jcheck(silent)
+ if (!silent && is.jnull(cls)) stop("class not found")
+ cls
}
.toS4 <- function(obj) {
@@ -168,21 +184,28 @@ J <- function (class, method, ...) {
res
}
-.fromS4 <- function(...) {
- l <- list(...)
- if (length(l)) {
- for (i in 1:length(l)) {
- if (isS4(l[[i]])) {
- o <- l[[i]]@jobj
- if (is.null(o)) {
- l[i] <- list(NULL)
- } else {
- l[[i]] <- o
- }
- }
- }
- }
- l
+.ellipsisToJObj <- function(...) {
+ lapply(list(...), function(x) .toJObj(x))
+}
+
+.toJObj <- function(x) {
+ if (is(x, "jobjRef")) {
+ x@jobj
+ } else if (is(x, "jclassName")) {
+ x@jobj@jobj
+ } else if (is(x, "jbyte")) {
+ as.external.byte(x)
+ } else if (is(x, "jchar")) {
+ as.external.char(x)
+ } else if (is(x, "jfloat")) {
+ as.external.float(x)
+ } else if (is(x, "jlong")) {
+ as.external.long(x)
+ } else if (is(x, "jshort")) {
+ as.external.short(x)
+ } else {
+ x
+ }
}
#' @export
@@ -204,7 +227,7 @@ J <- function (class, method, ...) {
}
#' @export
-.jnull <- function (class = "java/lang/Object") {
+.jnull <- function (class = "java/lang/Object") {
new("jobjRef", jobj=NULL, jclass=class)
}
@@ -245,15 +268,22 @@ is.jnull <- function (x) {
#' @export
.jstrVal <- function (obj) {
- if (is.character(obj))
+ if (is.character(obj)) {
return(obj)
+ }
r <- NULL
- if (!is(obj, "jobjRef"))
+ 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 <- obj@jobj["toString"]()
- r
+ }
+ if(!is.null(obj@stringValue)) {
+ obj@stringValue
+ } else {
+ obj@jobj["toString"]()
+ }
+}
+
+.isJavaArray <- function(o){
+ is.external.array(o) && java.class(o) != NULL
}
#
@@ -262,43 +292,86 @@ is.jnull <- function (x) {
setClass("truffle.object", representation(jobj="ANY"))
setClassUnion("TruffleObjectOrNull",members=c("truffle.object", "NULL"))
+setClassUnion("characterOrNull",members=c("character", "NULL"))
+#
# jobjRef
-setClass("jobjRef", representation(jobj="TruffleObjectOrNull", jclass="character"), prototype=list(jobj=NULL, jclass="java/lang/Object"))
+#
+setClass("jobjRef", representation(jobj="TruffleObjectOrNull", jclass="character", stringValue="characterOrNull"), prototype=list(jobj=NULL, jclass="java/lang/Object", stringValue=NULL))
-._jobjRef_dollar <- function(x, name) {
+setMethod("$", c(x="jobjRef"), function(x, name) {
if(name %in% names(x@jobj)) {
if(is.external.executable(x@jobj[name])) {
function(...) { .jcall(x, , name, ...) }
} else {
.jfield(x, , name)
}
- } else if( is.character(name) && length(name) == 1L && name == "length" && is.external.array(x) ){
+ } else if( is.character(name) && length(name) == 1L && name == "length" && is.external.array(x) ) {
length( x@obj )
} else {
stop(sprintf( "no field, method or inner class called '%s' ", name))
}
-}
-setMethod("$", c(x="jobjRef"), ._jobjRef_dollar )
+})
-._jobjRef_dollargets <- function(x, name, value) {
+setMethod("$<-", c(x="jobjRef"), function(x, name, value) {
if(name %in% names(x@jobj)) {
if(!is.external.executable(x@jobj[name])) {
- if(isS4(value)) {
- value <- value@jobj
- }
+ value <- .toJObj(value)
x@jobj[name] <- value
}
}
x
-}
-setMethod("$<-", c(x="jobjRef"), ._jobjRef_dollargets )
+})
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)
+ if (is.jnull(object)) {
+ show("Java-Object<null>")
+ } else {
+ show(paste("Java-Object{", .jstrVal(object), "}", sep=''))
+ }
+ invisible(NULL)
})
+#
+# jclassName
+#
+
+setClass("jclassName", representation(name="character", jobj="jobjRef"))
+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)
+setMethod("$", c(x="jclassName"), function(x, name) {
+ if(name == "class") {
+ x@jobj
+ }
+ obj <- x@jobj@jobj
+ if(name %in% names(obj)) {
+ if(is.external.executable(obj[name])) {
+ function(...) { .jcall(obj, , name, ...) }
+ } else {
+ .jfield(obj, , name)
+ }
+ } else {
+ stop("no static field, method or inner class called `", name, "' in `", x@name, "'")
+ }
+})
+setMethod("$<-", c(x="jclassName"), function(x, name, value) {
+ value <- .toJObj(value)
+ x@jobj@jobj[name] <- value
+ x
+})
+
+# TODO makes CMD INSTALL complain
+# setGeneric("new")
+# setMethod("new", signature(Class="jclassName"), function(Class, ...) .jnew(Class, ...))
+
+setClass("jfloat", representation("array"))
+setClass("jlong", representation("array"))
+setClass("jbyte", representation("array"))
+setClass("jshort", representation("array"))
+setClass("jchar", representation("array"))
+
#
# noop stubs
#
--
GitLab