diff --git a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/RCallNode.java b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/RCallNode.java
index 00da0b6a7e35ea8447de6eb4e27945fc69115b06..3cdbd5354de3c4ffc170305dc7f55f59c02b33c2 100644
--- a/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/RCallNode.java
+++ b/com.oracle.truffle.r.nodes/src/com/oracle/truffle/r/nodes/function/RCallNode.java
@@ -86,14 +86,17 @@ import com.oracle.truffle.r.runtime.builtins.RBuiltinDescriptor;
import com.oracle.truffle.r.runtime.conn.RConnection;
import com.oracle.truffle.r.runtime.context.RContext;
import com.oracle.truffle.r.runtime.data.RArgsValuesAndNames;
+import com.oracle.truffle.r.runtime.data.RAttributeStorage;
import com.oracle.truffle.r.runtime.data.RDataFactory;
import com.oracle.truffle.r.runtime.data.REmpty;
import com.oracle.truffle.r.runtime.data.RFunction;
+import com.oracle.truffle.r.runtime.data.RList;
import com.oracle.truffle.r.runtime.data.RMissing;
import com.oracle.truffle.r.runtime.data.RPromise;
import com.oracle.truffle.r.runtime.data.RPromise.Closure;
import com.oracle.truffle.r.runtime.data.RStringVector;
import com.oracle.truffle.r.runtime.data.RTypedValue;
+import com.oracle.truffle.r.runtime.env.REnvironment;
import com.oracle.truffle.r.runtime.nodes.RBaseNode;
import com.oracle.truffle.r.runtime.nodes.RFastPathNode;
import com.oracle.truffle.r.runtime.nodes.RNode;
@@ -279,8 +282,12 @@ public abstract class RCallNode extends RCallBaseNode implements RSyntaxNode, RS
@Cached("createWithError()") S3FunctionLookupNode dispatchLookup,
@Cached("createIdentityProfile()") ValueProfile builtinProfile,
@Cached("createBinaryProfile()") ConditionProfile implicitTypeProfile,
+ @Cached("createBinaryProfile()") ConditionProfile isAttributableProfile,
@Cached("createBinaryProfile()") ConditionProfile resultIsBuiltinProfile,
- @Cached("create()") GetBaseEnvFrameNode getBaseEnvFrameNode) {
+ @Cached("create()") GetBaseEnvFrameNode getBaseEnvFrameNode,
+ @Cached("createBinaryProfile()") ConditionProfile isS4Profile, //
+ @Cached("createEqualityProfile()") ValueProfile attrProfiles,
+ @Cached("new()") PromiseCheckHelperNode promiseHelper) {
RBuiltinDescriptor builtin = builtinProfile.profile(function.getRBuiltin());
Object dispatchObject = dispatchArgument.execute(frame);
// Cannot dispatch on REmpty
@@ -289,6 +296,23 @@ public abstract class RCallNode extends RCallBaseNode implements RSyntaxNode, RS
}
FrameSlot slot = dispatchTempSlot.initialize(frame, dispatchObject);
try {
+ if (internalDispatchCall == null) {
+ CompilerDirectives.transferToInterpreterAndInvalidate();
+ internalDispatchCall = insert(FunctionDispatchNodeGen.create(this, false, slot));
+ }
+
+ if (isAttributableProfile.profile(dispatchObject instanceof RAttributeStorage) && isS4Profile.profile(((RAttributeStorage) dispatchObject).isS4())) {
+ RList list = (RList) promiseHelper.checkEvaluate(frame, REnvironment.getRegisteredNamespace("methods").get(".BasicFunsList"));
+// int index = list.getElementIndexByName(attrProfiles, builtin.getName());
+ int index = 0;
+ if (index != -1) {
+ RFunction basicFun = (RFunction) list.getDataAt(index);
+ Object result = internalDispatchCall.execute(frame, basicFun, lookupVarArgs(frame), null, null);
+ if (result != RRuntime.DEFERRED_DEFAULT_MARKER) {
+ return result;
+ }
+ }
+ }
RStringVector type = classHierarchyNode.execute(dispatchObject);
S3Args s3Args;
RFunction resultFunction;
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RRuntime.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RRuntime.java
index 364e2d84845ab4342aec11ec046c780fefad8c6f..0db9b9784f79af67b103dff695e126ce9123c909 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RRuntime.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/RRuntime.java
@@ -164,6 +164,8 @@ public class RRuntime {
public static final String DOT_SIG_ARGS = ".SigArgs";
+ public static final RSymbol DEFERRED_DEFAULT_MARKER = new RSymbol("__Deferred_Default_Marker__");
+
public static final String R_TARGET = "target";
public static final String R_DOT_TARGET = ".target";
public static final String R_DEFINED = "defined";
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/RVector.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/RVector.java
index e0d3de69805cc1ae9818feff2efeba042e25f70e..87837333182d158bf2fd5e69233afc31be675da4 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/RVector.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/data/RVector.java
@@ -30,6 +30,7 @@ import com.oracle.truffle.api.CompilerAsserts;
import com.oracle.truffle.api.CompilerDirectives;
import com.oracle.truffle.api.CompilerDirectives.TruffleBoundary;
import com.oracle.truffle.api.object.DynamicObject;
+import com.oracle.truffle.api.profiles.ValueProfile;
import com.oracle.truffle.r.runtime.RError;
import com.oracle.truffle.r.runtime.RInternalError;
import com.oracle.truffle.r.runtime.RRuntime;
@@ -203,6 +204,20 @@ public abstract class RVector<ArrayT> extends RSharingAttributeStorage implement
return -1;
}
+ @TruffleBoundary
+ public final int getElementIndexByName(ValueProfile profile, String name) {
+ if (getNames() == null) {
+ return -1;
+ }
+ RStringVector names = getNamesFromAttrs();
+ for (int i = 0; i < names.getLength(); i++) {
+ if (names.getDataAt(i).equals(name)) {
+ return i;
+ }
+ }
+ return -1;
+ }
+
/**
* Find the first element in the names list that {@code name} is a prefix of, and return its
* index. If there are no names, or none is found, or there are multiple inexact matches, return
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
index 83b6bca2e5c7aa57fa66cfb50c50c58da9eb08a6..4f2f013d106679b9393f46f39220046e9cd180f4 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/ExpectedTestOutput.test
@@ -1,3 +1,296 @@
+##com.oracle.truffle.r.test.S4.TestS4.testAllocation#
+#{ new("numeric") }
+numeric(0)
+
+##com.oracle.truffle.r.test.S4.TestS4.testAllocation#
+#{ setClass("foo", representation(j="numeric")); new("foo", j=42) }
+An object of class "foo"
+Slot "j":
+[1] 42
+
+
+##com.oracle.truffle.r.test.S4.TestS4.testClassCreation#
+#{ setClass("foo"); setClass("bar", representation(j = "numeric"), contains = "foo"); is.null(getClass("foo")@prototype) }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testClassCreation#Ignored.OutputFormatting#
+#{ setClass("foo", representation(j="numeric")); getClass("foo") }
+Class "foo" [in ".GlobalEnv"]
+
+Slots:
+
+Name: j
+Class: numeric
+
+##com.oracle.truffle.r.test.S4.TestS4.testConversions#
+#{ asS4(7:42) }
+ [1] 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
+[26] 32 33 34 35 36 37 38 39 40 41 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testConversions#
+#{ asS4(NULL); isS4(NULL) }
+[1] TRUE
+
+##com.oracle.truffle.r.test.S4.TestS4.testConversions#
+#{ isS4(NULL) }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testConversions#
+#{ x<-42; isS4(x) }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testConversions#
+#{ x<-42; y<-asS4(x); isS4(y) }
+[1] TRUE
+
+##com.oracle.truffle.r.test.S4.TestS4.testInternalDispatch#
+#setClass('foo', representation(d='numeric')); setMethod(`$`, signature('foo'), function(x, name) 'FOO'); obj <- new('foo'); obj$asdf
+[1] "$"
+[1] "FOO"
+
+##com.oracle.truffle.r.test.S4.TestS4.testMethods#Ignored.OutputFormatting#
+#{ gen<-function(object) 0; setGeneric("gen"); res<-print(gen); removeGeneric("gen"); res }
+function (object)
+standardGeneric("gen")
+<environment: 0x2983900>
+attr(,"generic")
+[1] "gen"
+attr(,"generic")attr(,"package")
+[1] ".GlobalEnv"
+attr(,"package")
+[1] ".GlobalEnv"
+attr(,"group")
+list()
+attr(,"valueClass")
+character(0)
+attr(,"signature")
+[1] "object"
+attr(,"default")
+Method Definition (Class "derivedDefaultMethod"):
+
+function (object)
+0
+
+Signatures:
+ object
+target "ANY"
+defined "ANY"
+attr(,"skeleton")
+(function (object)
+0)(object)
+attr(,"class")
+[1] "standardGeneric"
+attr(,"class")attr(,"package")
+[1] "methods"
+standardGeneric for "gen" defined from package ".GlobalEnv"
+
+function (object)
+standardGeneric("gen")
+<environment: 0x2983900>
+Methods may be defined for arguments: object
+Use showMethods("gen") for currently available ones.
+
+##com.oracle.truffle.r.test.S4.TestS4.testMethods#
+#{ gen<-function(object) 0; setGeneric("gen"); setClass("foo", representation(d="numeric")); setMethod("gen", signature(object="foo"), function(object) object@d); res<-print(gen(new("foo", d=42))); removeGeneric("gen"); res }
+[1] 42
+[1] 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testMethods#
+#{ setClass("foo"); setMethod("diag<-", "foo", function(x, value) 42); removeMethod("diag<-", "foo"); removeGeneric("diag<-"); removeClass("foo") }
+Creating a generic function for ‘diag<-’ from package ‘base’ in the global environment
+[1] TRUE
+
+##com.oracle.truffle.r.test.S4.TestS4.testMethods#
+#{ setClass("foo", representation(d="numeric")); setClass("bar", contains="foo"); setGeneric("gen", function(o) standardGeneric("gen")); setMethod("gen", signature(o="foo"), function(o) "FOO"); setMethod("gen", signature(o="bar"), function(o) "BAR"); res<-print(c(gen(new("foo", d=7)), gen(new("bar", d=42)))); removeGeneric("gen"); res }
+[1] "FOO" "BAR"
+[1] "FOO" "BAR"
+
+##com.oracle.truffle.r.test.S4.TestS4.testMethods#
+#{ setGeneric("gen", function(o) standardGeneric("gen")); res<-print(setGeneric("gen", function(o) standardGeneric("gen"))); removeGeneric("gen"); res }
+[1] "gen"
+[1] "gen"
+
+##com.oracle.truffle.r.test.S4.TestS4.testMethods#Ignored.OutputFormatting#
+#{ setGeneric("gen", function(object) standardGeneric("gen")); res<-print(gen); removeGeneric("gen"); res }
+function(object) standardGeneric("gen")
+<environment: 0x11f3000>
+attr(,"generic")
+[1] "gen"
+attr(,"generic")attr(,"package")
+[1] ".GlobalEnv"
+attr(,"package")
+[1] ".GlobalEnv"
+attr(,"group")
+list()
+attr(,"valueClass")
+character(0)
+attr(,"signature")
+[1] "object"
+attr(,"default")
+`\001NULL\001`
+attr(,"skeleton")
+(function (object)
+stop("invalid call in method dispatch to 'gen' (no default method)",
+ domain = NA))(object)
+attr(,"class")
+[1] "standardGeneric"
+attr(,"class")attr(,"package")
+[1] "methods"
+standardGeneric for "gen" defined from package ".GlobalEnv"
+
+function (object)
+standardGeneric("gen")
+<environment: 0x11f3000>
+Methods may be defined for arguments: object
+Use showMethods("gen") for currently available ones.
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+# { x<-42; attr(x, "foo")<-7; x@foo }
+Error: trying to get slot "foo" from an object of a basic class ("numeric") with no slots
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ `@`(getClass("ClassUnionRepresentation"), "virtual") }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ `@`(getClass("ClassUnionRepresentation"), c("virtual", "foo")) }
+Error: invalid type or length for slot name
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ `@`(getClass("ClassUnionRepresentation"), virtual) }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ c(42)@.Data }
+[1] 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ c(42)@foo }
+Error: trying to get slot "foo" from an object of a basic class ("numeric") with no slots
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ getClass("ClassUnionRepresentation")@.S3Class }
+[1] "classRepresentation"
+attr(,"package")
+[1] "methods"
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ getClass("ClassUnionRepresentation")@foo }
+Error: no slot of name "foo" for this object of class "classRepresentation"
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ getClass("ClassUnionRepresentation")@virtual }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ setClass("foo", contains="numeric"); x<-new("foo"); res<-slot(x, ".Data"); removeClass("foo"); res }
+numeric(0)
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ setClass("foo", contains="numeric"); x<-new("foo"); res<-x@.Data; removeClass("foo"); res }
+numeric(0)
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-42; `@`(x, ".Data") }
+[1] 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-42; `@`(x, .Data) }
+[1] 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-42; attr(x, "foo")<-7; slot(x, "foo") }
+[1] 7
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-42; slot(x, ".Data") }
+[1] 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ x<-NULL; `@`(x, foo) }
+Error: trying to get slot "foo" from an object of a basic class ("NULL") with no slots
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ x<-NULL; x@foo }
+Error: trying to get slot "foo" from an object of a basic class ("NULL") with no slots
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ x<-c(42); class(x)<-"bar"; x@foo }
+Error: trying to get slot "foo" from an object (class "bar") that is not an S4 object
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-function() 42; attr(x, "foo")<-7; y<-asS4(x); y@foo }
+[1] 7
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-getClass("ClassUnionRepresentation"); slot(x, "virtual") }
+[1] FALSE
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#Output.IgnoreErrorContext#
+#{ x<-getClass("ClassUnionRepresentation"); slot(x, virtual) }
+Error in slot(x, virtual) : object 'virtual' not found
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotAccess#
+#{ x<-paste0(".", "Data"); y<-42; slot(y, x) }
+[1] 42
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#Output.IgnoreErrorContext#
+#{ x<-NULL; `@<-`(x, foo, "bar") }
+Error in (function (cl, name, valueClass) :
+ ‘foo’ is not a slot in class “NULLâ€
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#Output.IgnoreErrorContext#
+#{ x<-NULL; x@foo<-"bar" }
+Error in (function (cl, name, valueClass) :
+ ‘foo’ is not a slot in class “NULLâ€
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#Output.IgnoreErrorContext#
+#{ x<-function() 42; attr(x, "foo")<-7; slot(y, "foo")<-42 }
+Error in slot(y, "foo") <- 42 : object 'y' not found
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#Output.IgnoreErrorContext#
+#{ x<-function() 42; attr(x, "foo")<-7; y<-asS4(x); y@foo<-42 }
+Error in (function (cl, name, valueClass) :
+ ‘foo’ is not a slot in class “functionâ€
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#Output.IgnoreErrorContext#
+#{ x<-function() 42; attr(x, "foo")<-7; y@foo<-42 }
+Error in y@foo <- 42 : object 'y' not found
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#
+#{ x<-getClass("ClassUnionRepresentation"); slot(x, "virtual", check=TRUE)<-TRUE; x@virtual }
+[1] TRUE
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#
+#{ x<-getClass("ClassUnionRepresentation"); x@virtual<-TRUE; x@virtual }
+[1] TRUE
+
+##com.oracle.truffle.r.test.S4.TestS4.testSlotUpdate#
+#{ x<-initialize@valueClass; initialize@valueClass<-"foo"; initialize@valueClass<-x }
+
+##com.oracle.truffle.r.test.S4.TestS4.testStdGeneric#
+#{ standardGeneric("") }
+Error in standardGeneric("") :
+ argument to 'standardGeneric' must be a non-empty character string
+
+##com.oracle.truffle.r.test.S4.TestS4.testStdGeneric#
+#{ standardGeneric("foo", 42) }
+Error: expected a generic function or a primitive for dispatch, got an object of class "numeric"
+
+##com.oracle.truffle.r.test.S4.TestS4.testStdGeneric#
+#{ standardGeneric(42) }
+Error in standardGeneric(42) :
+ argument to 'standardGeneric' must be a non-empty character string
+
+##com.oracle.truffle.r.test.S4.TestS4.testStdGeneric#
+#{ standardGeneric(character()) }
+Error in standardGeneric(character()) :
+ argument to 'standardGeneric' must be a non-empty character string
+
+##com.oracle.truffle.r.test.S4.TestS4.testStdGeneric#Output.IgnoreErrorContext#
+#{ x<-42; class(x)<-character(); standardGeneric("foo", x) }
+Error: expected a generic function or a primitive for dispatch, got an object of class "numeric"
+
##com.oracle.truffle.r.test.builtins.TestBuiltin_Arg.testArg1#
#argv <- list(1+2i);Arg(argv[[1]]);
[1] 1.107149
diff --git a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/S4/TestS4.java b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/S4/TestS4.java
index 4719890c6b743ade75373ea91fcada000a3342a8..821615e7d7643119a400274a1dc1f960e6ebf8b8 100644
--- a/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/S4/TestS4.java
+++ b/com.oracle.truffle.r.test/src/com/oracle/truffle/r/test/S4/TestS4.java
@@ -24,14 +24,16 @@ package com.oracle.truffle.r.test.S4;
import org.junit.Test;
-import com.oracle.truffle.r.test.TestRBase;
+import com.oracle.truffle.r.test.TestBase;
+import com.oracle.truffle.r.test.TestBase.Ignored;
+import com.oracle.truffle.r.test.TestBase.Output;
// Checkstyle: stop LineLength
/**
* Tests for the S4 object model implementation.
*/
-public class TestS4 extends TestRBase {
+public class TestS4 extends TestBase {
@Test
public void testSlotAccess() {
assertEval("{ `@`(getClass(\"ClassUnionRepresentation\"), virtual) }");
@@ -123,11 +125,7 @@ public class TestS4 extends TestRBase {
assertEval("{ standardGeneric(character()) }");
assertEval("{ standardGeneric(\"\") }");
assertEval("{ standardGeneric(\"foo\", 42) }");
- assertEval("{ x<-42; class(x)<-character(); standardGeneric(\"foo\", x) }");
+ assertEval(Output.IgnoreErrorContext, "{ x<-42; class(x)<-character(); standardGeneric(\"foo\", x) }");
}
- @Override
- public String getTestDir() {
- return "S4";
- }
}
diff --git a/mx.fastr/mx_fastr.py b/mx.fastr/mx_fastr.py
index b61e314d5c722c2df25a2a138f773cef4e72ff30..782257b532a78329e952b39f4c02db0d82a52882 100644
--- a/mx.fastr/mx_fastr.py
+++ b/mx.fastr/mx_fastr.py
@@ -404,7 +404,7 @@ def _test_subpackage(name):
return '.'.join((_test_package(), name))
def _simple_generated_unit_tests():
- return ','.join(map(_test_subpackage, ['engine.shell', 'library.base', 'library.grid', 'library.methods', 'library.stats', 'library.utils', 'library.fastr', 'builtins', 'functions', 'parser', 'rng', 'runtime.data']))
+ return ','.join(map(_test_subpackage, ['engine.shell', 'library.base', 'library.grid', 'library.methods', 'library.stats', 'library.utils', 'library.fastr', 'builtins', 'functions', 'parser', 'rng', 'runtime.data', 'S4']))
def _simple_unit_tests():
return ','.join([_simple_generated_unit_tests(), _test_subpackage('tck')])